diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 31d40115..aa0de50e 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -94,6 +94,7 @@ set bootsupport_modules [list\ modules punk::unixywindows\ modules punk::zip\ modules punk::winpath\ + modules overtype\ modules shellfilter\ modules shellrun\ modules shellthread\ diff --git a/src/bootsupport/modules/overtype-1.6.6.tm b/src/bootsupport/modules/overtype-1.6.6.tm deleted file mode 100644 index b4e59ec6..00000000 --- a/src/bootsupport/modules/overtype-1.6.6.tm +++ /dev/null @@ -1,4774 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# 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) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.6 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.6] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6- -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -#PERFORMANCE notes -#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised -#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps -#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. -#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code -#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... -#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes -#generally using 'list' is preferred for the map as less error prone. -#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range -# - need to extract and replace ansi codes? - -tcl::namespace::eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - tcl::namespace::eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -tcl::namespace::eval overtype { - variable grapheme_widths [tcl::dict::create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ 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 "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [tcl::dict::create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::ansistrip $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -tcl::namespace::eval overtype::priv { -} - -#could return larger than renderwidth -proc _get_row_append_column {row} { - #obsolete? - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$expand_right} { - return $endpos - } else { - if {$endpos > $renderwidth} { - return $renderwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r - #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. - #The underlay and overlay can be multiline blocks of text of varying line lengths. - #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. - #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. - # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline - proc renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - set optargs [lrange $args 0 end-2] - if {[llength $optargs] % 2 == 0} { - set overblock [lindex $args end] - set underblock [lindex $args end-1] - #lassign [lrange $args end-1 end] underblock overblock - set argsflags [lrange $args 0 end-2] - } else { - set optargs [lrange $args 0 end-1] - if {[llength $optargs] %2 == 0} { - set overblock [lindex $args end] - set underblock "" - set argsflags [lrange $args 0 end-1] - } else { - error "renderspace expects opt-val pairs followed by: or just " - } - } - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -expand_right 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -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.. - # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) - # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. - # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, - # expand_right being primarily to support other operations such as textblock::table - - #todo - viewport width/height as separate concept to terminal width/height? - #-ellipsis args not used if -wrap is true - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental - - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode - - -cp437 - - -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]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] - #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] - set opt_startcolumn [tcl::dict::get $opts -startcolumn] - set opt_appendlines [tcl::dict::get $opts -appendlines] - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - 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] - - - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #only non-cursor affecting and non-width occupying ANSI codes should be present. - #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already - #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set renderheight $opt_height - } - } else { - 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? - if {$underblock eq ""} { - set underlines [lrepeat $renderheight ""] - } else { - set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} - # -- --- --- --- - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [tcl::dict::get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[tcl::string::length $overblock] + 10}] - } - - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height - - set scheme 4 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] - } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - - } - 4 { - set inputchunks [list] - foreach ln [split $overblock \n] { - lappend inputchunks $ln\n - } - if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] - } - } - } - - - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "[punk::ansi::a]" - set unapplied "" - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - #if {$data_mode} { - # set col [_get_row_append_column $row] - #} else { - set col $opt_startcolumn - #} - - set instruction_stats [tcl::dict::create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext - } - #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 renderopts [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\ - ] - set rinfo [renderline {*}$renderopts $undertext $overtext] - - 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 - - #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 && [tcl::dict::get $vtstate reverse_mode]} { - #test branch - todo - prune - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - #review - #JMN3 - set existing_reverse_state 0 - #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence - #e.g \x1b\[0;31;7m has a reset,colour red and reverse - set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - } - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::dict::size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - 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 { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - 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 -expand_right]\ - ""\ - $overflow_right\ - ] - 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.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - 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 - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col $opt_startcolumn - # ---------------------- - } - lf_mid { - - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - 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 {[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 - } - } - set overflow_right [join $remaining_overflow ""] - } - } - } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #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 "" - - #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 - } - - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col $opt_startcolumn - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col $opt_startcolumn - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $renderwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $renderwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #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 {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #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 {[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 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col $opt_startcolumn - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - 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'" - } - - } - - - 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 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::renderspace looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" - tcl::dict::for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - 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 - } - } - } - - #todo - left-right ellipsis ? - proc centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set opts [tcl::dict::create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$renderwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - proc right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set opts [tcl::dict::create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_align [tcl::dict::get $opts -align] - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline\ - -info 1\ - -insert_mode 0\ - -transparent $opt_transparent\ - -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ - -startcolumn [expr {1 + $startoffset}]\ - $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis $replay_codes$opt_ellipsistext - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - #foreach {underblock overblock} [lrange $args end-1 end] break - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_textalign [tcl::dict::get $opts -textalign] - set opt_blockalign [tcl::dict::get $opts -blockalign] - if {$opt_blockalign eq "center"} { - set opt_blockalign "centre" - } - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - set left_exposed 0 - } - } - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - # if {[tcl::string::trim $lostdata] eq ""} { - # set show_ellipsis 0 - # } - # } - # if {$show_ellipsis} { - # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - # #todo - overflow on left if allign = right?? - # set rendered [overtype::right $rendered $ellipsis] - # } - #} - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches - - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? - # This would probably be impractical to support for different fonts) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? - proc renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - #puts stderr "renderline '$args'" - variable optimise_ptruns - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} - } - set under [lindex $args end-1] - set over [lindex $args end] - #lassign [lrange $args end-1 end] under over - if {[string last \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) - set opts [tcl::dict::create\ - -etabs 0\ - -width \uFFEF\ - -expand_right 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -crm_mode 0\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_expand_right [tcl::dict::get $opts -expand_right] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [tcl::dict::get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM - set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set cp437_glyphs [tcl::dict::get $opts -cp437] - set cp437_map [tcl::dict::create] - if {$cp437_glyphs} { - set cp437_map [set ::punk::ansi::cp437_map] - #for cp437 images we need to map these *after* splitting ansi - #some old files might use newline for its glyph.. but we can't easily support that. - #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::dict::get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) - set reverse_mode $opt_reverse_mode - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - #todo - we also need to handle the new threaded repl where console config is in a different thread. - # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - if {[punk::ansi::ta::detect $under]} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - #single plaintext part - set undermap [list $under] - } - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - set pm_list [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$pt ne ""} { - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex - set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] - } - if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # set width 1 - # } - # default { - # if {$p1 eq "\u0000"} { - # #use null as empty cell representation - review - # #use of this will probably collide with some application at some point - # #consider an option to set the empty cell character - # set width 1 - # } else { - # set width [grapheme_width_cached $p1] ;# when zero??? - # } - # } - #} - set width [grapheme_width_cached $p1] ;# when zero??? - set ptlen [string length $pt] - if {$width <= 1} { - #review - 0 and 1? - incr i_u $ptlen - lappend understacks {*}[lrepeat $ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] - lappend undercols {*}[lrepeat $ptlen $p1] - } else { - incr i_u $ptlen ;#2nd col empty str - so same as above - set 2ptlen [expr {$ptlen * 2}] - lappend understacks {*}[lrepeat $2ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] - lappend undercols {*}$l - unset l - } - - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - #todo - test decimal value instead, compare performance - 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 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - #zero width still acts as 1 below??? review what should happen - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. - set grapheme $gvis - set width 1 - } - } - } - } - } - - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - } - } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #keep any remaining PMs in place - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - \x1b^ 7PMX\ - \x1bX 7SOS\ - ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - 7PMX - 7SOS { - #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! - #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. - - #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string - set graphemeplus [lindex $undercols end] - if {$graphemeplus ne "\0"} { - append graphemeplus $code - } else { - set graphemeplus $code - } - lset undercols end $graphemeplus - #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width - variable grapheme_widths - #stripped and plus version keys pointing to same length - dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] - - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } else { - set renderwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpadding [string repeat " " [expr {$opt_colstart -1}]] - #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] - } else { - #single plaintext part - set overmap [list $startpadding$overdata] - } - } else { - set overmap [list] - } - #### - - - #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) - #will that allow some optimisations? - - #todo - detect repeated transparent char in overlay - #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. - # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - if {$pt ne ""} { - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] - - #leading only? we would have to check for graphemes at the trailing boundary? - #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] - #if {$is_ptrun && 1} { - #} - } - if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) - #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) - set len [string length $pt] - set g_element [list g $p1] - - #lappend overstacks {*}[lrepeat $len $o_codestack] - #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len - #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] - #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] - - set pi 0 - incr i_o $len - while {$pi < $len} { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element - lappend overlay_grapheme_control_stacks $o_codestack - incr pi - } - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" - } - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - #we need to immediately set crm_mode here if \x1b\[3h received - if {$code eq "\x1b\[3h"} { - set crm_mode 1 - } elseif {$code eq "\x1b\[3l"} { - set crm_mode 0 - } - #else crm_mode could be set either way from options - if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? - #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. - set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] - #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop - set chars [split $code_as_pt ""] - set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } - foreach c $chars { - if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish - lappend codeparts [list crmcontrol "\x1b\[00001E"] - } else { - if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { - set existing [lindex $codeparts end 1] - lset codeparts end [list g [string cat $existing $c]] - } else { - lappend codeparts [list g $c] - } - } - } - - set partidx 0 - foreach record $codeparts { - lassign $record rtype rval - switch -exact -- $rtype { - g { - append pt_overchars $rval - foreach grapheme [punk::char::grapheme_split $rval] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - crmcontrol { - #leave o_codestack - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol $rval] - } - } - } - } else { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - #review - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_expand_right} { - #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - #we currently only support horizontal expansion to the right (review regarding RTL text!) - set overflow_idx -1 - } else { - #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -expand_right 1 "" data - - #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - #set re_row_move {\x1b\[([0-9]*)(A|B)$} - #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - #set re_cursor_restore {\x1b\[u$} - #set re_cursor_save_dec {\x1b7$} - #set re_cursor_restore_dec {\x1b8$} - #set re_other_single {\x1b(D|M|E)$} - #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - #crm_mode affects both graphic and control - if {0 && $crm_mode} { - set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] - set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - #incr idx_over - break - } else { - set ch $chars - } - } - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $renderwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - 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 - } - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied - #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #change the overflow_idx - set overflow_idx $idx - incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci - #throw back to caller's loop - add instruction to caller as this is not the usual case - #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line - set instruction overflow_splitchar - break - } elseif {$owidth > 2} { - #? tab? - #TODO! - puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" - #tab of some length dependent on tabstops/elastic tabstop settings? - } - } elseif {$idx >= $overflow_idx} { - #REVIEW - set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break - } else { - #no point throwing back to caller for each grapheme that is overflowing - #without this branch - renderline would be called with overtext reducing only by one grapheme per call - #processing a potentially long overtext each time (ie - very slow) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 - - } - } - } else { - #review. - #overflow_idx = -1 - #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? - #lset understacks $idx [list] ;#will get index $i out of range error - lappend understacks [list] ;#REVIEW - incr idx - incr cursor_column - } else { - #todo - punk::char::char_width - set g [lindex $outcols $idx] - #JMN - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay - if {$next_pt_overchar eq ""} { - #special-case trailing transparent - no next_pt_overchar - incr idx - incr cursor_column - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - incr idx - incr cursor_column - } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } - } ;# end switch - - - } - other - crmcontrol { - if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { - if {$item eq "\x1b\[3l"} { - set crm_mode 0 - } else { - #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations - #set within_undercols [expr {$idx <= $renderwidth-1}] - #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] - set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - - break - } - } - - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? - set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - set c1 [tcl::string::index $code 0] - set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(somewhat surprising) - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x1bY 7MAP\ - \x1bP 7DCS\ - \x90 8DCS\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - set codenorm $leadernorm[tcl::string::range $code 2 end] - } - 7DCS { - #ESC P - #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 8DCS { - #8-bit Device Control String - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 7MAP { - #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 7ESC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len - #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches - set codenorm $code - } - } - - switch -- $leadernorm { - 7MAP { - switch -- [lindex $codenorm 4] { - Y { - #vt52 movement. we expect 2 chars representing position (limited range) - set params [tcl::string::range $codenorm 5 end] - if {[tcl::string::length $params] != 2} { - #shouldn't really get here or need this branch if ansi splitting was done correctly - puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - set line [tcl::string::index $params 5] - set column [tcl::string::index $params 1] - set r [expr {[scan $line %c] -31}] - set c [expr {[scan $column %c] -31}] - - #MAP to: - #CSI n;m H - CUP - Cursor Position - set leadernorm 7CSI - set codenorm "$leadernorm${r}\;${c}H" - } - } - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode - - switch -exact -- $code_end { - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #todo - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #CUD - Cursor Down - #Row move - down - lassign [split $param {;}] num modifierkey - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - C { - #CUF - Cursor Forward - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_right and unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - #review - dead branch - if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[tcl::dict::exists $understacks $idx]} { - # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [tcl::dict::get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - E { - #CNL - Cursor Next Line - if {$param eq ""} { - set downmove 1 - } else { - set downmove [expr {$param}] - } - puts stderr "renderline CNL down-by-$downmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row + $downmove}] - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - F { - #CPL - Cursor Previous Line - if {$param eq ""} { - set upmove 1 - } else { - set upmove [expr {$param}] - } - puts stderr "renderline CPL up-by-$upmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row -$upmove}] - if {$cursor_row < 1} { - set cursor_row 1 - } - set idx [expr {$cursor_column - 1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - G { - #CHA - Cursor Horizontal Absolute (move to absolute column no) - if {$param eq ""} { - set targetcol 1 - } else { - set targetcol $param - if {![string is integer -strict $targetcol]} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" - } - set targetcol [expr {$param}] - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$targetcol > $max} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" - set targetcol $max - } - } - #adjust to colstart - as column 1 is within overlay - #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - - set cursor_column $targetcol - #puts stderr "renderline absolute col move ESC G (TEST)" - } - H - f { - #CSI n;m H - CUP - Cursor Position - - #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes - # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW - #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - - #test e.g ansicat face_2.ans - #$re_both_move - lassign [split $param {;}] paramrow paramcol - #missing defaults to 1 - #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 - - if {$paramcol eq ""} {set paramcol 1} - if {$paramrow eq ""} {set paramrow 1} - if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { - puts stderr "renderline CUP (CSI H) unrecognised param $param" - #ignore? - } else { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$paramcol > $max} { - set target_column $max - } else { - set target_column [expr {$paramcol}] - } - - - if {$paramrow < 1} { - puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" - set target_row 1 - } else { - set target_row [expr {$paramrow}] - } - if {$target_row == $cursor_row} { - #col move only - no need for break and move - #puts stderr "renderline CUP col move only to col $target_column param:$param" - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - } else { - set cursor_row $target_row - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - } - } - J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - #CSI ? Pn J - selective erase - puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - 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 clear_and_move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - - } - default { - } - } - - } - } - } - K { - #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - depending on DECSCA - } - 1 { - #clear from cursor to beginning of line - depending on DECSCA - - } - 2 { - #clear entire line - depending on DECSCA - } - default { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line - - } - 2 { - #clear entire line - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - } - } - } - L { - puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - M { - #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - } - T { - #CSI Pn T - SD Pan Up (empty lines introduced at top) - #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) - #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} - if {[string index $param end] eq "+"} { - puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } else { - puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - X { - puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - q { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - {"} { - #DECSCA - Select Character Protection Attribute - #(for use with selective erase: DECSED and DECSEL) - set param [tcl::string::range $codenorm 4 end-2] - if {$param eq ""} {set param 0} - #TODO - store like SGR in stacks - replays? - switch -exact -- $param { - 0 - 2 { - #canerase - puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 1 { - #cannoterase - puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - #code conflict between ansi emulation and DECSLRM - REVIEW - #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC - # todo - when parameters - support DECSLRM instead - - if {$param ne ""} { - #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right - puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$margin_left eq ""} { - set margin_left 1 - } - set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? - if {$margin_right eq ""} { - set margin_right $columns_per_page - } - puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" - if {![string is integer -strict $margin_left] || $margin_left < 0} { - puts stderr "DECSLRM invalid margin_left" - } - if {![string is integer -strict $margin_right] || $margin_right < 0} { - puts stderr "DECSLRM invalid margin_right" - } - set scrolling_region_size [expr {$margin_right - $margin_left}] - if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { - puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" - } - #todo - - - } else { - #DECSC - #//notes on expected behaviour: - #DECSC - saves following items in terminal's memory - #cursor position - #character attributes set by the SGR command - #character sets (G0,G1,G2 or G3) currently in GL and GR - #Wrap flag (autowrap or no autowrap) - #State of origin mode (DECOM) - #selective erase attribute - #any single shift 2 (SS2) or single shift 3(SSD) functions sent - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - } - } - u { - #ANSISYSRC save cursor (when no parameters) (DECSC) - - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - "{" { - - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - "}" { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - ' { - puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - default { - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - } - } - ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ - switch -exact -- $code_secondlast { - ' { - #DECDC - editing sequence - Delete Column - puts stderr "renderline warning - DECDC - unimplemented" - } - default { - #$re_vt_sequence - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - } - - } - h - l { - #set mode unset mode - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = - switch -exact -- $modegroup { - ? { - set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l - #one or more modes can be set - set smparam_list [split $smparams {;}] - foreach num $smparam_list { - switch -- $num { - "" { - #ignore empties e.g extra/trailing semicolon in params - } - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$code_end eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? - # presume not usually - but sanity check with warning for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - #REVIEW! - set overflow_idx -1 - } - } - 25 { - if {$code_end eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - 117 { - #DECECM - Erase Color Mode - #https://invisible-island.net/ncurses/ncurses.faq.html - #The Erase color selection controls the background color used when text is erased or new - #text is scrolled on to the screen. Screen background causes newly erased areas or - #scrolled text to be written using color index zero, the screen background. This is VT - #and DECterm compatible. Text background causes erased areas or scrolled text to be - #written using the current text background color. This is PC console compatible and is - #the factory default. - - #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen - } - } - } - } - = { - set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l - puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - default { - #e.g CSI 4 h - set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l - switch -exact -- $num { - 3 { - puts stderr "CRM MODE $code_end" - #CRM - Show control character mode - # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # - #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 - #https://vt100.net/docs/vt510-rm/CRM.html - #NOTE - vt100 CRM always does auto-wrap at right margin. - #disabling auto-wrap in set-up or by sequence is disabled. - #We should default to turning off auto-wrap when crm_mode enabled.. but - #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) - #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, - #although this would be potentially an annoying difference to some.. REVIEW - if {$code_end eq "h"} { - set crm_mode 1 - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } else { - set crm_mode 0 - } - } - 4 { - #IRM - Insert/Replace Mode - if {$code_end eq "h"} { - #CSI 4 h - set insert_mode 1 - } else { - #CSI 4 l - #replace mode - set insert_mode 0 - } - } - default { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - } - } - | { - switch -- [tcl::string::index $codenorm end-1] { - {$} { - #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) - #real terminals generally only supported 80/132 - #some other virtuals support any where from 2 to 65,536? - #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. - #CSI $ | - #empty or 0 param is 80 for compatibility - other numbers > 2 accepted - set page_width -1 ;#flag as unset - if {$param eq ""} { - set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { - set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr - } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" - } - - if {$page_width > 2} { - puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" - #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement - - } - - } - default { - puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - # - #re_other_single {\x1b(D|M|E)$} - #also vt52 Y.. - #also PM \x1b^...(ST) - switch -- [tcl::string::index $codenorm 4] { - c { - #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! - puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset - break - } - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "renderline ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "overtype::renderline ESC E unimplemented" - - } - H { - #\x88 - #Tab Set - puts stderr "overtype::renderline ESC H tab set unimplemented" - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "overtype::renderline ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - N { - #\x8e - affects next character only - puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - O { - #\x8f - affects next character only - puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - #\x90 - #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST - } - V { - #\x96 - - } - W { - #\x97 - } - X { - #\x98 - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - ^ { - #puts stderr "renderline PM" - #Privacy Message. - if {[string index $code end] eq "\007"} { - set pm_content [string range $code 2 end-1] ;#ST is \007 - } else { - set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #We don't want to render it - but we need to make it available to the application - #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix - #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' - if {$pm_content eq "\b"} { - #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ - #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs - #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. - #If the terminal has the space problem AND does support PMs - then this just won't fix it. - #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. - - #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #idx has been incremented after last grapheme added - priv::render_append_to_char [expr {$idx -1}] $code - } - #lappend to a dict element in the result for application-specific processing - lappend pm_list $pm_content - } - _ { - #APC Application Program Command - #just warn for now.. - puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - } - - } - 7DCS - 8DCS { - puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ - if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - - } - 7OSC - 8OSC { - # 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 2 end] ;#strip 4 and first semicolon - set cmap [dict create] - foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { - #todo - parse spec from names like 'red' to RGB - #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) - #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? - dict set cmap $cnum $spec - } else { - #todo - log - puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - 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]" - } - 99 { - #kitty desktop notifications - #https://sw.kovidgoyal.net/kitty/desktop-notifications/ - # 99 ; metadata ; payload - puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 104 { - #reset colour palette - #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt - 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 - } - 1337 { - #iterm2 graphics and file transfer - puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - 5113 { - puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - default { - puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - } - } - - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_expand_right == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #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]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [tcl::dict::get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {$g0 ne $prev_g0} { - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } else { - set gxleader "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - - set sgrleader "" - if {$i < [llength $understacks]} { - #set cstack [tcl::dict::get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - 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 - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - #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} { - if {$overflow_idx == -1} { - #set tail_idx [tcl::dict::size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [tcl::dict::create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - crm_mode $crm_mode\ - reverse_mode $reverse_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - expand_right $opt_expand_right\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - pm_list $pm_list\ - ] - if {$opt_returnextra == 1} { - #puts stderr "renderline: $result" - return $result - } else { - #human/debug - map special chars to visual glyphs - set viewop VIEW - switch -- $opt_returnextra { - 2 { - #codes and character data - set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others - } - 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. - } - } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] - return $result - } - } else { - #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -tcl::namespace::eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} - - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [tcl::dict::merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -tcl::namespace::eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended primarily for single grapheme - but will work for multiple -#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! -#We deliberately allow this for PM/SOS attached within a column -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::dict::set grapheme_widths $ch $width - return $width -} - - - -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[tcl::string::first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistrip $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -tcl::namespace::eval overtype::priv { - variable cache_is_sgr [tcl::dict::create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - # better named render_to_unapplied? - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } elseif {$i == 0 || $i == $nxt} { - #nothing to do - } else { - puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" - } - } - proc render_erasechar {i count} { - 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 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" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - #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 } { - upvar outcols o - lset o $i $c - } - - #Initial usecase is for old-terminal hack to add PM-wrapped \b - #review - can be used for other multibyte sequences that occupy one column? - #combiners? diacritics? - proc render_append_to_char {i c} { - upvar outcols o - if {$i > [llength $o]-1} { - error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" - } - set existing [lindex $o $i] - if {$existing eq "\0"} { - lset o $i $c - } else { - lset o $i $existing$c - } - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - # -- --- --- - #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review - #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes - upvar reverse_mode do_reverse - #if {$do_reverse} { - # lappend sgrstack [a+ reverse] - #} else { - # lappend sgrstack [a+ noreverse] - #} - - #JMN3 - if {$do_reverse} { - #note we can't just look for \x1b\[7m or \x1b\[27m - # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - - set existing_reverse_state 0 - set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set sgrstack [list [dict get $codeinfo mergeresult] $rflip] - #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - } - - # -- --- --- - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.6 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/bootsupport/modules/overtype-1.7.1.tm b/src/bootsupport/modules/overtype-1.7.4.tm similarity index 78% rename from src/bootsupport/modules/overtype-1.7.1.tm rename to src/bootsupport/modules/overtype-1.7.4.tm index 18fa78ea..e4ea54d7 100644 --- a/src/bootsupport/modules/overtype-1.7.1.tm +++ b/src/bootsupport/modules/overtype-1.7.4.tm @@ -7,7 +7,7 @@ # (C) Julian Noble 2003-2023 # # @@ Meta Begin -# Application overtype 1.7.1 +# Application overtype 1.7.4 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin overtype_module_overtype 0 1.7.1] +#[manpage_begin overtype_module_overtype 0 1.7.4] #[copyright "2024"] #[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] #[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] @@ -117,7 +117,7 @@ tcl::namespace::eval overtype { priv::_init } proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" + return "ANSI capable text formatting. Author JMN. BSD-License" } tcl::namespace::eval overtype { @@ -193,6 +193,79 @@ tcl::namespace::eval overtype { #[para] Core API functions for overtype #[list_begin definitions] + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + interp alias "" ::overtype::example "" ::punk::args::helpers::example + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderspace + @cmd -name overtype::renderspace\ + -summary\ + {}\ + -help\ + {} + @opts + #because underblocks value is optional - restrict opts to flag pairs (no solos) + #We don't use punk::args::parse in the actual function to parse args - so keep it simpler. + -bias -default left -type string -choices {left right} -help ignored + -width -default \uFFEF -type integer + -height -default \uFFEF -type integer + -startcolumn -default 1 -type integer + -startrow -default 1 -type integer + -ellipsis -default 0 -type boolean + -ellipsistext -default ${$::overtype::default_ellipsis_horizontal} -type char + -ellipsiswhitespace -default 0 -type boolean + -expand_right -default 0 -type boolean + -appendlines -default 1 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -exposed1 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + + -experimental -default 0 + -cp437 -default 0 -type boolean + -looplimit -default \uFFEF\ -type integer -help\ + "internal failsafe - experimental" + -crm_mode -default 0 -type boolean + -reverse_mode -default 0 -type boolean + -insert_mode -default 1 -type boolean + -wrap -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary (experimental)" + -binarytext -default "" -type string -choices {"" bios ice} + -console -default {stdin stdout stderr} -type list + + @values -min 1 -max 2 + underblock -type string -optional 1 + overblock -type string -optional 0 + }] + } #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r @@ -211,7 +284,7 @@ tcl::namespace::eval overtype { # @c can/should we use something like this?: 'format "%-*s" $len $overtext variable default_ellipsis_horizontal - if {[llength $args] < 2} { + if {[llength $args] < 1} { error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } set optargs [lrange $args 0 end-2] @@ -221,20 +294,26 @@ tcl::namespace::eval overtype { #lassign [lrange $args end-1 end] underblock overblock set argsflags [lrange $args 0 end-2] } else { - set optargs [lrange $args 0 end-1] - if {[llength $optargs] %2 == 0} { - set overblock [lindex $args end] - set underblock "" - set argsflags [lrange $args 0 end-1] - } else { - error "renderspace expects opt-val pairs followed by: or just " - } + #no solo flags - so we assume only an overblock was supplied + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + + #set optargs [lrange $args 0 end-1] + #if {[llength $optargs] %2 == 0} { + # set overblock [lindex $args end] + # set underblock "" + # set argsflags [lrange $args 0 end-1] + #} else { + # error "renderspace expects opt-val pairs followed by: or just " + #} } set opts [tcl::dict::create\ -bias ignored\ -width \uFFEF\ -height \uFFEF\ -startcolumn 1\ + -startrow 1\ -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ -ellipsiswhitespace 0\ @@ -251,6 +330,7 @@ tcl::namespace::eval overtype { -insert_mode 0\ -wrap 0\ -info 0\ + -binarytext ""\ -console {stdin stdout stderr}\ ] #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. @@ -266,12 +346,12 @@ tcl::namespace::eval overtype { #-ellipsis args not used if -wrap is true foreach {k v} $argsflags { switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + -looplimit - -width - -height - -startcolumn - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -transparent - -exposed1 - -exposed2 - -experimental - -expand_right - -appendlines - -reverse_mode - -crm_mode - -insert_mode - -cp437 - - -info - -console { + - -info - -binarytext - -console { tcl::dict::set opts $k $v } -wrap - -autowrap_mode { @@ -292,6 +372,7 @@ tcl::namespace::eval overtype { set opt_width [tcl::dict::get $opts -width] set opt_height [tcl::dict::get $opts -height] set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_startrow [tcl::dict::get $opts -startrow] set opt_appendlines [tcl::dict::get $opts -appendlines] set opt_transparent [tcl::dict::get $opts -transparent] set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] @@ -310,6 +391,7 @@ tcl::namespace::eval overtype { # -- --- --- --- --- --- set opt_cp437 [tcl::dict::get $opts -cp437] set opt_info [tcl::dict::get $opts -info] + set opt_binarytext [tcl::dict::get $opts -binarytext] @@ -333,6 +415,10 @@ tcl::namespace::eval overtype { set underblock [tcl::string::map {\r\n \n} $underblock] set overblock [tcl::string::map {\r\n \n} $overblock] + if {$opt_startrow > 1} { + set down [expr {$opt_startrow -1}] + set overblock [punk::ansi::move_down $down]$overblock + } #set underlines [split $underblock \n] @@ -410,13 +496,14 @@ tcl::namespace::eval overtype { switch -- $scheme { 0 { #one big chunk - set inputchunks [list $overblock] + set inputchunks [list mixed $overblock] } 1 { + #todo set inputchunks [punk::ansi::ta::split_codes $overblock] } 2 { - + #todo #split into lines if possible first - then into plaintext/ansi-sequence chunks ? set inputchunks [list ""] ;#put an empty plaintext split in for starters set i 1 @@ -433,6 +520,7 @@ tcl::namespace::eval overtype { } } 3 { + #todo #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice set lflines [list] set inputchunks [split $overblock \n] @@ -449,11 +537,45 @@ tcl::namespace::eval overtype { } 4 { set inputchunks [list] - foreach ln [split $overblock \n] { - lappend inputchunks $ln\n - } - if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + switch -- $opt_binarytext { + "" { + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] + } + if {[llength $inputchunks]} { + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] + } + } + bios { + #16 fg, 8 fg + possible blink + set input "" + set ansisplit [list ""] + set charpair 0 + foreach {ch at} [split $overblock ""] { + #review - does binarytext only apply to cp437??? we need to know the original encoding + set at [encoding convertto cp437 $at] + if {[catch {punk::ansi::colour::byteAnsi $at} code]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + #append input [punk::ansi::a+ brightred White] \uFFef + set code [punk::ansi::a+ brightred White] + set ch \uFFeF + } + append input $code $ch + lappend ansisplit $code $ch + incr charpair + } + #lappend inputchunks [list mixed $input] + lappend inputchunks [list ansisplit $ansisplit] + } + ice { + #16 fg, 16 bg (no blink) + set input "" + foreach {ch at} [split $overblock ""] { + set at [encoding convertto cp437 $at] + append input [punk::ansi::colour::byteAnsiIce $at]$ch + } + lappend inputchunks [list mixed $input] + } } } } @@ -484,23 +606,54 @@ tcl::namespace::eval overtype { set loop 0 #while {$overidx < [llength $inputchunks]} { } - + set renderedrow "" while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { + #set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' + lassign [lpop inputchunks 0] overtext_type overtext + + #use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list + if {$overtext eq ""} { incr loop continue } #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row #renderline pads each underaly line to width with spaces and should track where end of data is + switch -- $overtext_type { + mixed { + set overtext $replay_codes_overlay$overtext + } + ansisplit { + ledit overtext -1 -1 "" $replay_codes_overlay + } + default { + error "renderspace unsupported overtext type: $overtext_type overtext: $overtext" + } + } + + + ###################### + #debug + #set partinfo "" + #if {$overtext_type eq "ansisplit"} { + # set partinfo [llength $overtext] + #} else { + # set partinfo [string length $overtext] + #} + #if {$renderedrow eq $row} { + # puts -nonewline stderr <$row>$overtext_type$partinfo + #} else { + # puts -nonewline stderr \n<$row>$overtext_type$partinfo + #} + #if {$overtext_type eq "mixed"} { + # puts -nonewline stderr "\n[ansistring VIEW $overtext]\n" + #} + ###################### + + set renderedrow $row - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext if {[tcl::dict::exists $replay_codes_underlay $row]} { set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext } @@ -521,6 +674,7 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ + -overtext_type $overtext_type\ ] set rinfo [renderline {*}$renderopts $undertext $overtext] @@ -540,6 +694,7 @@ tcl::namespace::eval overtype { set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] set unapplied [tcl::dict::get $rinfo unapplied] set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit] set post_render_col [tcl::dict::get $rinfo cursor_column] set post_render_row [tcl::dict::get $rinfo cursor_row] set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] @@ -602,568 +757,644 @@ tcl::namespace::eval overtype { - set nextprefix "" + set nextprefix_list [list] - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - 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 + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + 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)" } - {} { - #end of supplied line input - #lf included in data - set row $post_render_row + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #puts stderr "up $post_render_row" + #puts stderr "$rinfo" + + #puts stdout "1 row:$row col $col" + set row $post_render_row + #data_mode (naming?) determines if we move to end of existing data or not. + #data_mode 0 means ignore existing line length and go to exact column + #set by -experimental flag + if {$data_mode == 0} { set col $post_render_col - if {![llength $unapplied_list]} { - if {$overflow_right ne ""} { - incr row - } + } else { + #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data + #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] } else { - puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + set col $renderwidth } - set col $opt_startcolumn } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" + #puts stdout "2 row:$row col $col" + #puts stdout "-----------------------" + #puts stdout $rinfo + #flush stdout + } + down { + if {$data_mode == 0} { + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] } + lappend outputlines "" } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] } + lappend outputlines "" } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - 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 -expand_right]\ - ""\ - $overflow_right\ - ] - 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.. - } - set overflow_handled 1 + # ---- + # review + set col $post_render_col + #just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025 + #---- + + #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + #set lastdatacol [punk::ansi::printing_length $existingdata] + + #set col [expr {$lastdatacol+1}] + + #if {$lastdatacol < $renderwidth} { + # set col [expr {$lastdatacol+1}] + #} else { + # set col $renderwidth + #} } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? + } + restore_cursor { + #testfile belinda.ans uses this + + #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" + if {[tcl::dict::exists $cursor_saved_position row]} { + set row [tcl::dict::get $cursor_saved_position row] + set col [tcl::dict::get $cursor_saved_position column] + #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" + #set nextprefix $cursor_saved_attributes + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" } - clear_and_move { - #e.g 2J - if {$post_render_row > [llength $outputlines]} { + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + 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 -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + + #todo!!! + # 2025 fix - this does nothing - so what uses it?? create a test! + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { 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 { + #} + } else { + set row $post_render_row + } + ####### + 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 - } - default { - if {$grapheme eq "\u0000"} { - incr numcells 1 - } else { - incr numcells [grapheme_width_cached $grapheme] - } + } else { + incr numcells [grapheme_width_cached $grapheme] } } - } + } } - #replays/resets each line - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m } + #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 - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col $opt_startcolumn - # ---------------------- + 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 + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" } - lf_mid { + set col $opt_startcolumn + # ---------------------- + } + lf_mid { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { + set edit_mode 0 + if {$edit_mode} { + #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + #JMN + #ledit inputchunks -1 -1 $overflow_right$unapplied + + set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] + #join the trailing and leading pt parts of the 2 lists + ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" + lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] + + ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form + + set overflow_right "" + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list] + + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + 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 { - #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 + if {[tcl::dict::get $vtstate autowrap_mode]} { + set outputlines [linsert $outputlines $renderedrow $overflow_right] set overflow_right "" + set row [expr {$renderedrow + 2}] } else { - 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 - } + 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 - } + 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 + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code } - set overflow_right [join $remaining_overflow ""] } + set overflow_right [join $remaining_overflow ""] } } } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 + append rendered $overflow_right + set overflow_right "" + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] } } - } - lf_overflow { - #linefeed after renderwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save + } + } + lf_overflow { + #linefeed after renderwidth e.g at column 81 for an 80 col width + #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 "" + 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 "" - #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 - } + #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 + } - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col $opt_startcolumn + set row $post_render_row + #set row $renderedrow + #incr row + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + set col $opt_startcolumn + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + puts "--->newlines_above" + puts "rinfo: $rinfo" + #renderline doesn't advance the row for us - the caller has the choice to implement or not + set row $post_render_row + set col $post_render_col + if {$insert_lines_above > 0} { + set row $renderedrow + #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] + incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + #? set row $post_render_row #can renderline tell us? } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not + } + newlines_below { + #obsolete? - use for ANSI insert lines sequence + if {$data_mode == 0} { + puts --->nl_below set row $post_render_row set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + + #rendered + append rendered $overflow_right + # - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat $insert_lines_below ""] + } + incr row $insert_lines_below + set col $opt_startcolumn + } + } else { + set row $post_render_row + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] } - incr row $insert_lines_below - set col $opt_startcolumn + lappend outputlines "" } } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] + if {$r < [llength $outputlines]} { + lappend outputlines "" } - lappend outputlines "" } + set c $opt_startcolumn } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } + incr c } + incr i } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth } else { - incr c + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break } - incr i + } else { + incr c -1 } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col + incr i -1 } - set row $r set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" } - wrapmovebackward { - set c $renderwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $renderwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + + + #renderspace gives us an overflow when there is a grapheme followed by a non-grapheme + #This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else) + #followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc) + #we want to strip out this leading run of graphemes + #NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline + #REVIEW!!! + + #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] + + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs + #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate + #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + + set drop_graphemes [list] ;#list of contiguous grapheme indices + set new_unapplied_list [list] + set unapplied_ansisplit [list ""] + set idx 0 + + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + #puts stderr "g$idx:$u" + if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} { + #we are in the first run of uninterrupted graphemes + #drop by doing nothing with it here + lappend drop_graphemes $idx } else { - incr c -1 + lappend new_unapplied_list $u + ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u" } - incr i -1 + } else { + lappend new_unapplied_list $u + lappend unapplied_ansisplit $u "" } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" + incr idx } - set row $r - set col $c + #debug + if {[llength $drop_graphemes]} { + set idx0 [lindex $drop_graphemes 0] + set dbg "" + if {$idx0 > 0} { + for {set i 0} {$i < $idx0} {incr i} { + #leading SGR + append dbg [lindex $unapplied_list $i] + } + } + foreach idx $drop_graphemes { + append dbg [lindex $unapplied_list $idx] + } + puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m" + } + set unapplied [join $new_unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied_list $new_unapplied_list + + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any } - overflow { - #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 {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #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 {[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 - set next_grapheme_index -1 + set triggering_grapheme_index -1 foreach u $unapplied_list { if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx + set triggering_grapheme_index $idx break } incr idx } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #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 {[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 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col $opt_startcolumn - incr row - } + #set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + incr idx } + #set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient + puts -nonewline stderr . + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] } - } - vt { - #can vt add a line like a linefeed can? - 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'" - } + } + vt { + #can vt add a line like a linefeed can? + 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'" } + } + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { #not allowed to overflow column or wrap therefore we get overflow data to truncate @@ -1210,10 +1441,25 @@ tcl::namespace::eval overtype { } if {!$overflow_handled} { - append nextprefix $overflow_right + #append nextprefix $overflow_right + set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right] + if {![llength $nextprefix_list]} { + set nextprefix_list $overflow_right_pt_code_pt + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]" + lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end] + } } - append nextprefix $unapplied + #append nextprefix $unapplied + if {![llength $nextprefix_list]} { + set nextprefix_list $unapplied_ansisplit + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]" + lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] + } if 0 { if {$nextprefix ne ""} { @@ -1227,8 +1473,10 @@ tcl::namespace::eval overtype { } } - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] + if {[llength $nextprefix_list]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $nextprefix_list] } @@ -1771,22 +2019,129 @@ tcl::namespace::eval overtype { return [join $outputlines \n] } - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + #variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + variable optimise_ptruns 5 + + + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderline + @cmd -name overtype::renderline\ + -summary\ + {Render a line of text/ANSI input over a line of text.}\ + -help\ + {renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode + commandline repl for the Tcl Punk Shell. + It is also a central part of an ansi (micro) virtual terminal-emulator of sorts. + This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that + can be joined & framed for layout display within a unix or windows terminal. + Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't + affect another. + Calling on the punk::ansi library - it can coalesce codes to keep the size down. + + It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + Renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a + static underlay. + The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous + to a terminal screen - but it can also be ragged in line length, or just blank. + The overlay couuld be similar - in which case it may often be used to overwrite a column or section of + the underlay. + The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + + Renderline itself only deals with a single line - or sometimes a single character. It is generally + called from a loop that does further terminal-like or textblock processing. + By suppyling the ${$B}-info${$N} 1 option - it can return various fields indicating the state of the render. + The main 3 are: result, overflow_right, and unapplied. + Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the + aforementioned loop will need to be in place to manage the set of lines under manipulation. + } + @opts + -etabs -default 0 -type boolean + -width -default \uFFEF -type integer + -expand_right -default 0 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -startcolumn -default 1 -type integer + -cursor_column -default 1 -type integer -help\ + {First column is 1. Cursor column can be zero or negative} + -cursor_row -default "" -type integer + -insert_mode -default 1 -type boolean + -crm_mode -default 0 -type boolean + -autowrap_mode -default 1 -type boolean + -reverse_mode -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary of settings useful for + processing ANSI input in a loop. When zero, the resulting + string will contain the updated line, but not all the + overtext may have been applied." + -exposed1 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -cursor_restore_attributes -default "" + -cp437 -default 0 -type boolean + -experimental -default {} + -overtext_type -type string -choices {mixed plain ansisplit} -default mixed + @values -min 2 -max 2 + undertext -type string -help\ + "A single line of text which may contain pre-rendered ANSI. + 'pre-rendered' in this context means that it may contain + various static ANSI codes such as SGR colours and attributes + but not motion-control or more complex ANSI sequences. + It is an error to supply a newline (lf) character in the + undertext." + overtext -type string -help\ + "ANSI (or plain text) to overlay onto the undertext. + May contain ANSI movement codes even if they would move the + cursor to another line. If -info is zero, the output will + only display up to the point where the cursor moved off-line. + If -info is 1, the line moved to may be reflected in the + cursor_row element of the result. Overtext may contain an lf + which is effectively a form of 'movement control' to increment + the row. + Other ANSI codes may perform operations such as changing the + insert_mode or reverse_mode - and these are reflected in the + result dictionary when '-info 1' is used, so that the state + can then be applied to subsequent lines." + }] + } - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? - # This would probably be impractical to support for different fonts) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? proc renderline {args} { + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # + # + #-returnextra enables returning of overflow and length + #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? + #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? + # This would probably be impractical to support for different fonts) + #todo - review transparency issues with single/double width characters + #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? + + + #*** !doctools #[call [fun overtype::renderline] [arg args] ] #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell @@ -1840,7 +2195,10 @@ tcl::namespace::eval overtype { -cursor_restore_attributes ""\ -cp437 0\ -experimental {}\ + -overtext_type mixed\ ] + #-overtext_type plain|mixed|ansisplit + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return @@ -1854,7 +2212,7 @@ tcl::namespace::eval overtype { switch -- $k { -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v } default { @@ -1869,6 +2227,7 @@ tcl::namespace::eval overtype { set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay set opt_row_context [tcl::dict::get $opts -cursor_row] + set opt_overtext_type [tcl::dict::get $opts -overtext_type] if {[string length $opt_row_context]} { if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" @@ -1942,9 +2301,16 @@ tcl::namespace::eval overtype { #set under [textutil::tabify::untabify2 $under] set under [textutil::tabify::untabifyLine $under $tw] } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] + + #review - is untabifying sensible at this point?? + if {$opt_overtext_type eq "ansisplit"} { + #todo - something for each pt part? + } else { + #plain|mixed + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } } } } @@ -1973,8 +2339,12 @@ tcl::namespace::eval overtype { set i_u -1 ;#underlay may legitimately be empty set undercols [list] set u_codestack [list] + #------------- #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + # + #------------- + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation set remainder [list] ;#for returnextra foreach {pt code} $undermap { @@ -1992,29 +2362,14 @@ tcl::namespace::eval overtype { set is_ptrun [regexp $re $pt] } if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # set width 1 - # } - # default { - # if {$p1 eq "\u0000"} { - # #use null as empty cell representation - review - # #use of this will probably collide with some application at some point - # #consider an option to set the empty cell character - # set width 1 - # } else { - # set width [grapheme_width_cached $p1] ;# when zero??? - # } - # } - #} set width [grapheme_width_cached $p1] ;# when zero??? set ptlen [string length $pt] + #puts -nonewline stderr !$ptlen! if {$width <= 1} { #review - 0 and 1? incr i_u $ptlen lappend understacks {*}[lrepeat $ptlen $u_codestack] + #we need to store the gx0 state per column - as characters with or without gx0 can be overlayed anywhere lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] lappend undercols {*}[lrepeat $ptlen $p1] } else { @@ -2195,24 +2550,6 @@ tcl::namespace::eval overtype { } - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - #trailing codes in effect for underlay if {[llength $u_codestack]} { #set replay_codes_underlay [join $u_codestack ""] @@ -2229,11 +2566,21 @@ tcl::namespace::eval overtype { set startpadding [string repeat " " [expr {$opt_colstart -1}]] #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + if {$opt_overtext_type eq "ansisplit"} { + set overmap $overdata + lset overmap 0 "$startpadding[lindex $overmap 0]" } else { - #single plaintext part - set overmap [list $startpadding$overdata] + if {[punk::ansi::ta::detect $overdata]} { + #TODO!! rework this. + #e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data. + #set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + set overmap [punk::ansi::ta::split_codes_single $overdata] + lset overmap 0 "$startpadding[lindex $overmap 0]" + + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } } } else { set overmap [list] @@ -2266,9 +2613,13 @@ tcl::namespace::eval overtype { set o_gxstack [list] set pt_overchars "" set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment set overlay_grapheme_control_stacks [list] + #REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit) + #we are re-generating the overlay_grapheme_control_stacks list each time + #this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string. + #todo - return also the unapplied portion of the overlay_grapheme_control_stacks list?? foreach {pt code} $overmap { if {$pt ne ""} { #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) @@ -2296,6 +2647,7 @@ tcl::namespace::eval overtype { #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) set len [string length $pt] set g_element [list g $p1] + #puts -nonewline stderr "!$len!" #lappend overstacks {*}[lrepeat $len $o_codestack] #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] @@ -2413,6 +2765,21 @@ tcl::namespace::eval overtype { set o_codestack [lremove $o_codestack {*}$dup_posns] lappend o_codestack $code lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b\[[0-1];[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?t} $code]} { + #pablodraw 24bit color - convert to standard sgr RGB code + #we could do a more precise 000-255 regexp for each r g b, something like: ((?:[0-1]?[0-9]?[0-9])|(?:2[0-4][0-9])|(?:25[0-5])) + #but that seems more expensive for little likely use (?) review + lassign [regexp -all -inline {\x1b\[([0-1]);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?)t} $code] _ isfg pablo_r pablo_g pablo_b + #todo - if any r g b value > 255 - add as [list other $code] + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + set dup_posns [lsearch -all -exact $o_codestack $rgbcode] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $rgbcode + lappend overlay_grapheme_control_list [list sgr $rgbcode] } elseif {[regexp {\x1b7|\x1b\[s} $code]} { #experiment #cursor_save - for the replays review. @@ -2425,7 +2792,7 @@ tcl::namespace::eval overtype { set o_codestack [list $temp_cursor_saved] lappend overlay_grapheme_control_list [list other $code] } else { - #review + #review - gx0 should just be a flag like autowrap_mode and insert_mode? if {[punk::ansi::codetype::is_gx_open $code]} { set o_gxstack [list "gx0_on"] lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets @@ -2479,6 +2846,7 @@ tcl::namespace::eval overtype { set unapplied "" ;#if we break for move row (but not for /v ?) set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#pt code ... pt set insert_lines_above 0 ;#return key set insert_lines_below 0 @@ -2537,10 +2905,14 @@ tcl::namespace::eval overtype { set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] set chars [string map [list \n "\x1b\[00001E"] $chars] if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN - backwards compat ledit from punk::lib for tcl <9 + ledit unapplied_list -1 -1 {*}[split $chars ""] set unapplied [join $unapplied_list ""] + lset unapplied_ansisplit 0 $chars ;#no existing ? + #incr idx_over break } else { @@ -2572,7 +2944,7 @@ tcl::namespace::eval overtype { #linefeed at column 1 #leave the overflow_idx ;#? review set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci break } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { #linefeed after final column @@ -2580,7 +2952,7 @@ tcl::namespace::eval overtype { incr cursor_row set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci break } else { #linefeed occurred in middle or at end of text @@ -2592,12 +2964,12 @@ tcl::namespace::eval overtype { set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 } set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci break } else { incr cursor_row #don't adjust the overflow_idx - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction lf_mid break ;# could have overdata following the \n - don't keep processing } @@ -2625,7 +2997,7 @@ tcl::namespace::eval overtype { set flag 0 if $flag { #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction backspace_at_start break } @@ -2645,7 +3017,7 @@ tcl::namespace::eval overtype { incr cursor_row set overflow_idx $idx #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction vt break } @@ -2667,7 +3039,7 @@ tcl::namespace::eval overtype { set overflow_idx $idx incr idx incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci #throw back to caller's loop - add instruction to caller as this is not the usual case #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line set instruction overflow_splitchar @@ -2682,13 +3054,18 @@ tcl::namespace::eval overtype { #REVIEW set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { + if {$autowrap_mode} { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #don't incr idx beyond the overflow_idx #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + #priv::render_to_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } elseif {0 && $next_type ne "g"} { + incr idx_over -1 priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# set instruction overflow break @@ -2897,10 +3274,14 @@ tcl::namespace::eval overtype { #set within_undercols [expr {$idx <= $renderwidth-1}] #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + #JMN + ledit unapplied_list -1 -1 {*}[split $chars ""] set unapplied [join $unapplied_list ""] + #ledit unapplied_ansisplit -1 -1 $chars + lset unapplied_ansisplit 0 $chars ;#?? break } @@ -2965,7 +3346,17 @@ tcl::namespace::eval overtype { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #JMN + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "ARGS:" + foreach a $args { + puts stderr " $a" + } + puts stderr ----- + foreach {xpt ycode} $overmap { + puts stderr "t:'$xpt'" + puts stderr "c:[ansistring VIEW $ycode]" + } #we haven't made a mapping for this #could in theory be 1,2 or 3 in len #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches @@ -3036,7 +3427,7 @@ tcl::namespace::eval overtype { #ensure rest of *overlay* is emitted to remainder incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction up #retain cursor_column break @@ -3055,7 +3446,7 @@ tcl::namespace::eval overtype { incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column break @@ -3109,7 +3500,7 @@ tcl::namespace::eval overtype { incr cursor_column $num ;#give our caller the necessary info as columns from start of row #incr idx_over #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction wrapmoveforward break } else { @@ -3193,7 +3584,7 @@ tcl::namespace::eval overtype { } else { set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction wrapmovebackward break } @@ -3221,7 +3612,7 @@ tcl::namespace::eval overtype { set idx [expr {$cursor_column -1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move break @@ -3242,7 +3633,7 @@ tcl::namespace::eval overtype { set idx [expr {$cursor_column - 1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move break @@ -3322,7 +3713,7 @@ tcl::namespace::eval overtype { set idx [expr {$cursor_column -1}] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move break } @@ -3356,7 +3747,7 @@ tcl::namespace::eval overtype { if {[llength $outcols]} { priv::render_erasechar 0 [llength $outcols] } - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction clear_and_move break } @@ -3486,7 +3877,7 @@ tcl::namespace::eval overtype { set cursor_row 1 incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction move ;#own instruction? decstbm? break } @@ -3621,25 +4012,39 @@ tcl::namespace::eval overtype { set replay_codes_overlay "" #} - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + #like priv::render_to_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code incr idx_over - set unapplied "" - set unapplied_list [list] + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#remove below if nothing added foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" + switch -- $type { + g { + lappend unapplied_list $item + ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" } - } else { - lappend unapplied_list $item } #incr idx_over } set unapplied [join $unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. set instruction restore_cursor break @@ -3900,6 +4305,32 @@ tcl::namespace::eval overtype { } } } + t { + set params [split $param {;}] + if {[llength $params] == 4} { + #pablodraw 24bit color + #see also: https://github.com/ansilove/libansilove/blob/master/src/loaders/ansi.c + lassign $params isfg pablo_r pablo_g pablo_b + #e.g esc\[0\;171\;87\;0t + set stack [lindex $overlay_grapheme_control_stacks $gci] + puts stderr "pablodraw debug [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #foreach s $stack { + # puts stderr " - [ansistring VIEW -lf 1 -vt 1 -nul 1 $s]" + #} + #we expect first param to be 0 for background, 1 for foreground + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + #too late here !! + #lappend stack $rgbcode + #lset overlay_grapheme_control_stacks $gci $stack + + } else { + puts stderr "overtype::renderline unrecognised custom CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } default { puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } @@ -3914,7 +4345,7 @@ tcl::namespace::eval overtype { c { #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction reset break } @@ -3924,7 +4355,7 @@ tcl::namespace::eval overtype { #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" puts stderr "renderline ESC D not fully implemented" incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction down #retain cursor_column break @@ -3958,7 +4389,7 @@ tcl::namespace::eval overtype { set cursor_row 1 } #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction up ;#need instruction for scroll-down? #retain cursor_column break @@ -4061,7 +4492,7 @@ tcl::namespace::eval overtype { switch -exact -- $osc_code { 2 { set newtitle [tcl::string::range $code_content 2 end] - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction [list set_window_title $newtitle] break } @@ -4121,7 +4552,7 @@ tcl::namespace::eval overtype { #reset colour palette #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - priv::render_unapplied $overlay_grapheme_control_list $gci + priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction [list reset_colour_palette] break } @@ -4348,6 +4779,10 @@ tcl::namespace::eval overtype { } else { set overflow_right_column [expr {$overflow_idx+1}] } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set result [tcl::dict::create\ result $outstring\ visualwidth [punk::ansi::printing_length $outstring]\ @@ -4356,13 +4791,14 @@ tcl::namespace::eval overtype { overflow_right_column $overflow_right_column\ overflow_right $overflow_right\ unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - crm_mode $crm_mode\ - reverse_mode $reverse_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ + unapplied_list $unapplied_list\ + unapplied_ansisplit $unapplied_ansisplit\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ cursor_saved_position $cursor_saved_position\ cursor_saved_attributes $cursor_saved_attributes\ cursor_column $cursor_column\ @@ -4388,14 +4824,15 @@ tcl::namespace::eval overtype { set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. } } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] return $result } } else { @@ -4430,7 +4867,7 @@ tcl::namespace::eval overtype::piper { # -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { +proc overtype::renderline_transparent {args} { foreach {under over} [lrange $args end-1 end] break set argsflags [lrange $args 0 end-2] set defaults [tcl::dict::create\ @@ -4527,54 +4964,83 @@ tcl::namespace::eval overtype::priv { tcl::dict::set cache_is_sgr $code $answer return $answer } - # better named render_to_unapplied? - proc render_unapplied {overlay_grapheme_control_list gci} { + proc render_to_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + + #----------------------------------------- + #review - this is a lot of copies of the same thing. + # ultimately we want to reduce expensive things like redundant grapheme-splits + # perhaps unapplied_tagged of some sort e.g - {g g code pt } ?? + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...? + #----------------------------------------- + + upvar overstacks overstacks upvar overstacks_gx overstacks_gx upvar overlay_grapheme_control_stacks og_stacks #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list ""] #append unapplied [join [lindex $overstacks $idx_over] ""] #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] if {$sgr_merged ne ""} { lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" } switch -- [lindex $overstacks_gx $idx_over] { "gx0_on" { - lappend unapplied_list "\x1b(0" + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" } "gx0_off" { - lappend unapplied_list "\x1b(B" + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" } } foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { lassign $gc type item #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" } - } else { - lappend unapplied_list $item } } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } set unapplied [join $unapplied_list ""] } #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack proc render_this_unapplied {overlay_grapheme_control_list gci} { upvar idx_over idx_over + #-------------- upvar unapplied unapplied upvar unapplied_list unapplied_list + upvar unapplied_ansisplit unapplied_ansisplit + #-------------- + upvar overstacks overstacks upvar overstacks_gx overstacks_gx upvar overlay_grapheme_control_stacks og_stacks @@ -4582,33 +5048,50 @@ tcl::namespace::eval overtype::priv { #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] set unapplied "" set unapplied_list [list] + set unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged + lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" } switch -- [lindex $overstacks_gx $idx_over] { "gx0_on" { - lappend unapplied_list "\x1b(0" + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" } "gx0_off" { - lappend unapplied_list "\x1b(B" + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" } } foreach gc [lrange $overlay_grapheme_control_list $gci end] { lassign $gc type item #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" } - } else { - lappend unapplied_list $item } } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } set unapplied [join $unapplied_list ""] } proc render_delchar {i} { @@ -4737,13 +5220,18 @@ tcl::namespace::eval overtype::priv { } else { #insert of single-width vs double-width when underlying is double-width? if {$i < $nxt} { - set o [linsert $o $i $c] + #set o [linsert $o $i $c] + #JMN insert via ledit + ledit o $i $i-1 $c } else { lappend o $c } if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] + #set ustacks [linsert $ustacks $i $sgrstack] + #set gxstacks [linsert $gxstacks $i $gx0stack] + #insert via ledit + ledit ustacks $i $i-1 $sgrstack + ledit gxstacks $i $i-1 $gx0stack } else { lappend ustacks $sgrstack lappend gxstacks $gx0stack @@ -4760,11 +5248,18 @@ tcl::namespace::eval overtype { interp alias {} ::overtype::center {} ::overtype::centre } + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::overtype ::overtype::argdoc +} + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide overtype [tcl::namespace::eval overtype { variable version - set version 1.7.1 + set version 1.7.4 }] return