diff --git a/src/bootsupport/modules/overtype-1.7.4.tm b/src/bootsupport/modules/overtype-1.7.4.tm index e9a5d737..1b71be1f 100644 --- a/src/bootsupport/modules/overtype-1.7.4.tm +++ b/src/bootsupport/modules/overtype-1.7.4.tm @@ -289,6 +289,7 @@ tcl::namespace::eval overtype { # @c can/should we use something like this?: 'format "%-*s" $len $overtext variable default_ellipsis_horizontal + if {[llength $args] < 1} { error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } @@ -397,8 +398,16 @@ 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] + set opt_console [tcl::dict::get $opts -console] + set cursor_style_overtype {3 underline-blink} + set cursor_style_insert {5 beam-blink} + if {$opt_insert_mode} { + punk::console::cursor_style -console $opt_console $cursor_style_insert + } else { + punk::console::cursor_style -console $opt_console $cursor_style_overtype + } # ---------------------------- # -experimental dev flag to set flags etc @@ -465,7 +474,8 @@ tcl::namespace::eval overtype { # -- --- --- --- #REVIEW - do we need ansi resets in the underblock? if {$underblock eq ""} { - set underlines [lrepeat $renderheight ""] + set blankline [string repeat \u0000 $renderwidth] + set underlines [lrepeat $renderheight $blankline] } else { #---- @@ -627,6 +637,7 @@ tcl::namespace::eval overtype { set loop 0 #while {$overidx < [llength $inputchunks]} { } set renderedrow "" + set renderedrow_max 1 while {[llength $inputchunks]} { #set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' lassign [lpop inputchunks 0] overtext_type overtext @@ -639,7 +650,7 @@ tcl::namespace::eval overtype { #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" set undertext [lindex $outputlines [expr {$row -1}]] - #renderline pads each underaly line to width with spaces and should track where end of data is + #renderline pads each underly line to width with spaces and should track where end of data is switch -- $overtext_type { mixed { @@ -673,10 +684,15 @@ tcl::namespace::eval overtype { ###################### set renderedrow $row + if {$renderedrow > $renderedrow_max} { + set renderedrow_max $renderedrow + } 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\ @@ -701,6 +717,7 @@ tcl::namespace::eval overtype { 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? @@ -725,7 +742,7 @@ tcl::namespace::eval overtype { 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] + 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" @@ -848,22 +865,29 @@ tcl::namespace::eval overtype { if {$post_render_row > [llength $outputlines]} { if {$opt_appendlines} { set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] + lappend outputlines {*}[lrepeat $diff $bce_line] + #lappend outputlines {*}[lrepeat $diff ""] } - lappend outputlines "" + lappend outputlines $bce_line + #lappend outputlines "" } } set row $post_render_row set col $post_render_col } else { + puts stderr "renderspace down - data_mode 1 - review" if {$post_render_row > [llength $outputlines]} { if {$opt_appendlines} { set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] + lappend outputlines {*}[lrepeat $diff $bce_line] + #lappend outputlines {*}[lrepeat $diff ""] } - lappend outputlines "" + lappend outputlines $bce_line + #lappend outputlines "" } } # ---- @@ -931,6 +955,7 @@ tcl::namespace::eval overtype { #todo!!! # 2025 fix - this does nothing - so what is the intention?? create a test! + puts stderr ">>>renderspace<<< overflow_right during restore_cursor - inserting foldline: [ansistring VIEW $foldline]" linsert outputlines $renderedrow $foldline #review - row & col set by restore - but not if there was no save.. } @@ -941,15 +966,17 @@ tcl::namespace::eval overtype { ######## 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 { + #puts stderr ">m from row $row to post_render_row: $post_render_row outputlines: [llength $outputlines] opt_appendlines: $opt_appendlines< replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff $bce_line] + } + set row $post_render_row + } else { set row [llength $outputlines] - #} + } } else { set row $post_render_row } @@ -968,35 +995,39 @@ tcl::namespace::eval overtype { 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 - } + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m + + #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"} { + # #review + # incr numcells 1 + # } elseif {$grapheme eq "\t"} { + # #set tstops [lsort -integer -unique [punk::console::get_tabstops]] + # puts stderr "tab at numcells: $numcells - REVIEW renderspace" + # set nexttabstop [expr {((int($numcells / 8) + 1) * 8)}] + # incr numcells [expr {$nexttabstop - $numcells}] + # } else { + # incr numcells [grapheme_width_cached $grapheme] + # } + # } + # } + + # } + # } + #} + ##replays/resets each line + #lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $numcells]\x1b\[0m } set outputlines $clearedlines #todo - determine background/default to be in effect - DECECM ? @@ -1014,13 +1045,14 @@ tcl::namespace::eval overtype { set row $renderedrow incr row if {$row > [llength $outputlines]} { - lappend outputlines "" + #lappend outputlines "" + # BCE + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] } set col $opt_startcolumn # ---------------------- } lf_mid { - set edit_mode 0 if {$edit_mode} { #set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] @@ -1043,7 +1075,8 @@ tcl::namespace::eval overtype { #set col $post_render_col set col $opt_startcolumn if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] + #lappend outputlines {*}[lrepeat 1 ""] + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] } } else { if 1 { @@ -1061,6 +1094,8 @@ tcl::namespace::eval overtype { if {[tcl::dict::get $vtstate autowrap_mode]} { #set outputlines [linsert $outputlines $renderedrow $overflow_right] #ledit outputlines $renderedrow $renderedrow-1 $overflow_right + puts stderr "REVIEW wrap overflow_right to next line: $overflow_right" + #this looks wrong ledit outputlines $renderedrow -1 $overflow_right set overflow_right "" set row [expr {$renderedrow + 2}] @@ -1104,7 +1139,10 @@ tcl::namespace::eval overtype { set row $post_render_row set col $opt_startcolumn if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + #puts "row: $row > outputlines: [llength $outputlines] overlay replay:[ansistring VIEW $replay_codes_overlay]" + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] } } else { #old version - known to work with various ansi graphics - e.g fruit.ans @@ -1140,7 +1178,9 @@ tcl::namespace::eval overtype { #incr row #only add newline if we're at the bottom if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] + #lappend outputlines {*}[lrepeat 1 ""] + # BCE + lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] } set col $opt_startcolumn @@ -1159,7 +1199,10 @@ tcl::namespace::eval overtype { set row $renderedrow #set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] #ledit outputlines $renderedrow-1 $renderedrow-2 {*}[lrepeat $insert_lines_above ""] - ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above ""] + # BCE (background color erase) + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + ledit outputlines $renderedrow-1 -1 {*}[lrepeat $insert_lines_above $bce_line] + #ledit outputlines $renderedrow-1 -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? } @@ -1189,7 +1232,9 @@ tcl::namespace::eval overtype { set row $renderedrow #only add newline if we're at the bottom if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + lappend outputlines {*}[lrepeat $insert_lines_below $bce_line] + #lappend outputlines {*}[lrepeat $insert_lines_below ""] } incr row $insert_lines_below set col $opt_startcolumn @@ -1199,10 +1244,14 @@ tcl::namespace::eval overtype { if {$post_render_row > [llength $outputlines]} { if {$opt_appendlines} { set diff [expr {$post_render_row - [llength $outputlines]}] + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] + if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] + lappend outputlines {*}[lrepeat $diff $bce_line] + #lappend outputlines {*}[lrepeat $diff ""] } - lappend outputlines "" + lappend outputlines $bce_line + #lappend outputlines "" } } else { set existingdata [lindex $outputlines [expr {$post_render_row -1}]] @@ -1223,12 +1272,14 @@ tcl::namespace::eval overtype { set r $post_render_row if {$post_render_col > $renderwidth} { set i $c + set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth] while {$i <= $post_render_col} { if {$c == $renderwidth+1} { incr r if {$opt_appendlines} { if {$r < [llength $outputlines]} { - lappend outputlines "" + #lappend outputlines "" + lappend outputlines $bce_line } } set c $opt_startcolumn @@ -1237,13 +1288,14 @@ tcl::namespace::eval overtype { } incr i } - set col $c + #set col $c } else { #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" + #puts stderr "wrapmoveforward - unexpected post_render_col: $post_render_col <= renderwidth: $renderwidth review" set r [expr {$post_render_row +1}] set c $post_render_col } + #puts stderr "wrapmoveforward - moving from row $row col $col to row $r col $c" set row $r set col $c } @@ -1291,6 +1343,7 @@ tcl::namespace::eval overtype { #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 + #puts stderr "overflow autowrap - wrap to next line row: $row autowrap: [tcl::dict::get $vtstate autowrap_mode] renderwidth: $renderwidth visualwidth: $visualwidth [ansistring VIEW $unapplied]" if {[tcl::dict::get $vtstate autowrap_mode]} { incr row set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? @@ -1535,7 +1588,50 @@ tcl::namespace::eval overtype { } } - set result [join $outputlines \n] + #JMN + if {[tcl::dict::get $vtstate insert_mode]} { + puts "setting cursor to insert style" + punk::console::cursor_style -console $opt_console $cursor_style_insert + } else { + punk::console::cursor_style -console $opt_console $cursor_style_overtype + } + + #puts "renderedrow_max: $renderedrow_max" + #check for null lines below renderedrow_max (and at tail) and trim. + #set resultlines [lrange $outputlines 0 [expr {$renderedrow_max-1}]] + + #set unrenderedlines [lrange $outputlines $renderedrow_max end] + #set unrenderedlines_count [llength $unrenderedlines] + set unrenderedlines_count [expr {[llength $outputlines] - $renderedrow_max}] + if {$unrenderedlines_count > 0} { + #trim in reverse + set num_to_remove 0 + for {set i [expr {$renderedrow_max + $unrenderedlines_count -1}]} {$i >= $renderedrow_max} {incr i -1} { + set line [lindex $outputlines $i] + set strippedline [punk::ansi::ansistrip $line] + set strippedline [string map {\u0000 ""} $strippedline] + if {$strippedline eq ""} { + #trim + incr num_to_remove + } else { + #stop trimming at first non-empty line + break + } + } + if {$num_to_remove > 0} { + #puts stderr "overtype::renderspace - trimming $num_to_remove additional unrendered lines that were empty" + #set resultlines [lrange $outputlines 0 [expr {$renderedrow_max + $unrenderedlines_count -1 - $num_to_remove}]] + set resultlines [lrange $outputlines 0 end-$num_to_remove] + } else { + set resultlines $outputlines + } + } else { + set resultlines $outputlines + } + + set result [join $resultlines \n] + + if {!$opt_info} { return $result } else { @@ -2116,7 +2212,19 @@ tcl::namespace::eval overtype { -crm_mode -default 0 -type boolean -autowrap_mode -default 1 -type boolean -reverse_mode -default 0 -type boolean - -info -default 0 -type boolean -help\ + -info -default 0 -type integer -choicecolumns 2 -choices {1 9 2 10 3 11 4 12 0} -choicelabels\ + { + 1 "return a dict with raw fields" + 2 "return a dict using ansistring VIEW" + 3 "return a dict using ansistring VIEWCODES" + 4 "return a dict using ansistring VIEWSTYLE" + 9 "display version of 1" + 10 "display version of 2" + 11 "display version of 3" + 12 "display version of 4" + 0 "return just the resulting string" + }\ + -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 @@ -2270,7 +2378,7 @@ tcl::namespace::eval overtype { 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 + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -etabs - -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type { tcl::dict::set opts $k $v } @@ -2344,7 +2452,6 @@ tcl::namespace::eval overtype { 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 @@ -2354,6 +2461,16 @@ tcl::namespace::eval overtype { } else { set tw 8 } + if {[string first \t $under] >= 0 || [string first \t $overdata] >= 0} { + #todo - make tabstops an option that can be passed in - as it is expensive to query the terminal for them, and they are needed for correct tab processing - but they are not needed if there are no tabs in either string. + set tstops [lsort -integer -unique [punk::console::get_tabstops]] + if {$tstops eq ""} { + set termsize [punk::console::get_size] + set termcols [dict get $termsize columns] + set tstops [lrange [punk::lib::range 1 $termcols $tw] 1 end] + } + } + # if 0 { if {!$cp437_glyphs} { @@ -2422,9 +2539,12 @@ tcl::namespace::eval overtype { 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 {$p1 ne "\t"} { + #we only want to do this optimisation if the run is not made of tabs - as tabs are a special case that we need to handle differently. + 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} { set width [grapheme_width_cached $p1] ;# when zero??? @@ -2449,6 +2569,8 @@ tcl::namespace::eval overtype { } else { foreach grapheme [punk::char::grapheme_split $pt] { + incr i_u + #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 @@ -2464,6 +2586,18 @@ tcl::namespace::eval overtype { #use of this will probably collide with some application at some point #consider an option to set the empty cell character set width 1 + } elseif {$grapheme eq "\t"} { + #tabs are a special case - they are treated by terminals as a cursor movement operation, but we want to retain the literal tab in the underlay. + #review -etabs + #REVIEW + set tab_column [expr {$i_u + $opt_colstart}] + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + set width $this_tab_width + + #set nexttabstop [expr {((int($numcells / 8) + 1) * 8)}] + #set width [expr {$nexttabstop - $numcells}] } else { #zero width still acts as 1 below??? review what should happen set width [grapheme_width_cached $grapheme] @@ -2483,19 +2617,30 @@ tcl::namespace::eval overtype { } #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? + #puts "----> wide grapheme '$grapheme' at under column [expr {$i_u+1}] width $width" ;#debug + #*usually* there are no triple-column or wider unicode chars.. + #emoji combinations should generally be at most 2 wide - can they be wider than 2? + #Some scripts can render wider (arabic, devanagari etc) + #tabs are a special case. They are treated by terminals as a cursor movement operation, but we want to retain the literal tab in the underlay. #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 "" + if {$grapheme eq "\t"} { + set replacement \u0000 + } else { + #wide unicode graphemes other than tab + set replacement "" + } + for {set wi 1} {$wi < $width} {incr wi} { + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + #review + lappend undercols $replacement + } } } @@ -2557,7 +2702,7 @@ tcl::namespace::eval overtype { #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"} { + if {$graphemeplus ne "\u0000"} { append graphemeplus $code } else { set graphemeplus $code @@ -2655,6 +2800,7 @@ tcl::namespace::eval overtype { #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] + #puts ! set overmap [punk::ansi::ta::split_codes_single $overdata] lset overmap 0 "$startpadding[lindex $overmap 0]" @@ -2666,6 +2812,7 @@ tcl::namespace::eval overtype { } else { set overmap [list] } + #puts [ansistring VIEW $overmap] ;#debug #### @@ -2832,7 +2979,8 @@ tcl::namespace::eval overtype { } } } else { - lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_stacks $o_codestack ;#we want a record of the stack prior to each point in the overlay - even if it's not a grapheme. + #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) set code_endswith_m [expr {[tcl::string::index $code end] eq "m"}] ;#skip SGR regexp testing for cases that don't end with m - as they can't be SGR @@ -3023,7 +3171,9 @@ tcl::namespace::eval overtype { #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] + #review - for tab we need to emit a tab char - but also treat it as a movement control. + + set chtest [tcl::string::map [list \n \x85 \b \r \v \t \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 { @@ -3058,10 +3208,19 @@ tcl::namespace::eval overtype { break } else { incr cursor_row - #don't adjust the overflow_idx - priv::render_to_unapplied $overlay_grapheme_control_list $gci set instruction lf_mid - break ;# could have overdata following the \n - don't keep processing + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - we are inserting a linefeed in the middle of the line, so everything after it is now overflow + priv::render_to_unapplied $overlay_grapheme_control_list $gci + break + + + + # #old version + # incr cursor_row + # #don't adjust the overflow_idx + # set instruction lf_mid + # priv::render_to_unapplied $overlay_grapheme_control_list $gci + # break ;# could have overdata following the \n - don't keep processing } } @@ -3111,16 +3270,87 @@ tcl::namespace::eval overtype { set instruction vt break } + "" { + #tab moves to next tab stop or right margin - never wraps to next line. + #(tab is a noop when it is at rightmost margin) + + if {$insert_mode} { + set tab_column $cursor_column + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + + set graphemes [list \t {*}[lrepeat [expr {$this_tab_width -1}] "\u0000"]] + priv::render_insertgraphemes $idx $graphemes [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] + incr idx $this_tab_width + incr cursor_column $this_tab_width + + #priv::render_addchar $idx \t [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #incr idx + #incr cursor_column + #for {set e 0} {$e < $this_tab_width-1} {incr e} { + # priv::render_addchar [expr {$idx + $e}] "\u0000" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #} + #incr idx [expr {$this_tab_width -1}] + #incr cursor_column [expr {$this_tab_width -1}] + + continue + } else { + #in overtype mode we treat tab as a movement control. + if {$idx == $overflow_idx-1} { + #tab at last column. + #NOOP + } else { + #set current_column [expr {$idx + $opt_colstart}] + set tab_column $cursor_column + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our current_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + set o_width $this_tab_width + #if $o_width-1 chars going forward are currently nulls - render the tab and move forward. + # + if {$overflow_idx != -1} { + #we have a limit + set max [llength $outcols] + if {$idx + ($o_width -1) >= $max} { + set twidth [expr {$max - $idx}] + } else { + set twidth $o_width + } + } else { + #expand_right true - we don't have a limit - but we still need to know how many null chars we have to work with for the tab expansion + set twidth $o_width + } + + incr idx $twidth + incr cursor_column $twidth + + if {$overflow_idx == -1} { + #expand_right true - we can expand as much as we want - so add extra columns as needed to the outcols and understacks + set extra_cols_needed [expr {$idx - [llength $outcols] +1}] + for {set ec 0} {$ec < $extra_cols_needed} {incr ec} { + lappend outcols " " + lappend understacks [list] ;#REVIEW + lappend understacks_gx [list] ;#REVIEW + } + } + } + } + } 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? + #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 aside from scripts such as arabic/devangari etc? #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc if {$idx == $overflow_idx-1} { + #tab in overlay already handled above. set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { + #? arabic devanagari ? + #TODO! + #puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + 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 + #we don't want to make the decision here to split a wide grapheme 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. @@ -3134,11 +3364,6 @@ tcl::namespace::eval overtype { #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 @@ -3176,107 +3401,171 @@ tcl::namespace::eval overtype { 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} { + #null? 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 + lappend understacks_gx [list] ;#REVIEW incr idx incr cursor_column } else { #todo - punk::char::char_width - set g [lindex $outcols $idx] + set existing_outchar [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 ? + if {$existing_outchar eq "\t"} { + #REVIEW incr idx incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { + #we simply treat the tab char in the underlay as transparent + # - the final outcols run will detect any tabs that have had their following nul chars overwritten and backtrack to re-render the tab char as a space if necessary. + + + #set tab_column [expr {$idx + $opt_colstart}] + #set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + #set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + #set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + #set owidth $this_tab_width + #incr idx $this_tab_width-1 + #incr cursor_column $this_tab_width-1 + } else { + set uwidth [grapheme_width_cached $existing_outchar] + if {[lindex $outcols $idx] eq "\u0000"} { + #2nd col of 2-wide char in underlay + # (or subsequent col if char wider than 2 e.g tab or arabic etc - REVIEW) 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]} { + } 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 == 2} { + 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 { - #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 + 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 { - #? todo - decide what transparency even means for insert mode + #2wide transparency over 2wide in underlay - review incr idx incr cursor_column } } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column + # what about chars wider than 2 ? (we have already excluded tabs in this branch - but could be something else in future) + puts stderr "overtype::renderline unexpected existing underlay grapheme width $uwidth for char '[ansistring VIEW -lf 1 -vt 1 $existing_outchar]' at column $idx" + incr idx [expr {$uwidth -1}] + incr cursor_column [expr {$uwidth -1}] } } } } else { - set idxchar [lindex $outcols $idx] + set existing_outcol_char [lindex $outcols $idx] ;#existing char in the output at this column - could be from underlay or previously rendered overlay grapheme #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { + if {$existing_outcol_char eq "\u0000"} { #empty/erased cell indicator set uwidth 1 + } elseif {$existing_outcol_char eq "\t"} { + #REVIEW + set tab_column [expr {$idx + $opt_colstart}] + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + set uwidth $this_tab_width } else { - set uwidth [grapheme_width_cached $idxchar] + set uwidth [grapheme_width_cached $existing_outcol_char] } 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 + if {$existing_outcol_char eq ""} { + #REVIEW - broken for tabs. + ##2nd col of 2wide char in underlay + ##review - or subsequent col of char wider than 2? + #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 + # #an exception is if the current empty cell is due to a tab character or some other wider than 2 character - in which case we should just render the overlay char and move on + # #- but this is hard to determine without looking back through the overstack for a tab or other wide char - review + # 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 {$existing_outcol_char eq ""} { + #get the width of the previous char to determine if this is a 2nd half of a 2wide char or just an empty cell + set prevcolchar [lindex $outcols $idx-1] + set prev_uwidth [grapheme_width_cached $prevcolchar] + if {$insert_mode} { + 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 {$prev_uwidth == 2} { + #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startposn 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 { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + if {$prevcolchar eq "\t"} { + #could be any width + #nothing to do. + } else { + if {$prev_uwidth == 2} { + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + } elseif {$prev_uwidth > 2} { + puts stderr "overtype::renderline unexpected underlay grapheme width $prev_uwidth for char '[ansistring VIEW -lf 1 -vt 1 $prevcolchar]' at column [expr {$idx-1}]" + } + } } - 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 } @@ -3300,8 +3589,17 @@ tcl::namespace::eval overtype { #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 + if {$insert_mode} { + #render_insertgraphemes does reflow for later tabs in the line for us. + #This reflows for each grapheme inserted - but for now this is simpler than trying to handle multiple graphemes at once. + priv::render_insertgraphemes $idx [list $ch] [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] + incr idx + #don't incr cursor_column - review. + + } else { + 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 @@ -3319,22 +3617,49 @@ tcl::namespace::eval overtype { } elseif {$uwidth > 1} { set owidth [grapheme_width_cached $ch] if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { + if {$uwidth == 2} { + #todo - fix - tab could be 2 wide too! + #1wide over 2wide in underlay 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 + if {!$insert_mode} { + 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 + } } 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 + if {$insert_mode} { + priv::render_insertgraphemes $idx [list $ch] [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] ;#does tab reflow. + incr idx + incr cursor_column + #if insert mode - just pushes all to right - no exposition char here. + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + incr idx + incr cursor_column + if {$existing_outcol_char eq "\t"} { + set exposed_char "^" + } else { + set exposed_char $opt_exposed1 + } + set extra_cols_needed [expr {$owidth -1}] + for {set uw 0} {$uw < $extra_cols_needed} {incr uw} { + priv::render_addchar [expr {$idx+$uw}] $exposed_char [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #incr idx + #incr cursor_column + } + } } } else { + #review #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + if {$insert_mode} { + priv::render_insertgraphemes $idx [list $ch] [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] ;#does tab reflow for tabs later in the line. + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + } incr idx 2 incr cursor_column 2 } @@ -3502,6 +3827,7 @@ tcl::namespace::eval overtype { switch -exact -- $code_end { A { #Row move - up + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] #todo lassign [split $param {;}] num modifierkey @@ -3670,8 +3996,8 @@ tcl::namespace::eval overtype { incr cursor_column -$num } else { if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 + set cursor_column 1 + set idx 0 } else { set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]] incr cursor_column -$num @@ -3717,7 +4043,7 @@ tcl::namespace::eval overtype { } else { set upmove [expr {$param}] } - puts stderr "renderline CPL up-by-$upmove" + puts stderr "renderline CPL up-by-$upmove (codenorm:$codenorm)" set cursor_column 1 set cursor_row [expr {$cursor_row -$upmove}] if {$cursor_row < 1} { @@ -3845,6 +4171,9 @@ tcl::namespace::eval overtype { } default { puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #TODO - take account of BCE (Background Colour Erase) + #modern default is BCE enabled - which means we should use background colour for cleared areas when erasing + if {$param eq ""} {set param 0} switch -exact -- $param { 0 { @@ -3854,7 +4183,7 @@ tcl::namespace::eval overtype { #clear from cursor to beginning of screen } 2 { - #clear entire screen + #clear entire screen CSI 2J #ansi.sys - move cursor to upper left REVIEW set cursor_row 1 set cursor_column 1 @@ -4386,7 +4715,30 @@ tcl::namespace::eval overtype { set insert_mode 0 } } + 7 { + #review - in old ansi art we sometimes see CSI 7h instead of the more common CSI ?7h for autowrap. + #for now we will ignore if setting already matches current config - and warn if it doesn't. + if {$code_end eq "h"} { + if {$autowrap_mode == 0} { + puts stderr "overtype::renderline warning - CSI 7 h - enabling autowrap - but this is an unexpected code as autowrap is usually enabled with CSI ?7h" + 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 { + if {$autowrap_mode == 1} { + puts stderr "overtype::renderline warning - CSI 7 l - disabling autowrap - but this is an unexpected code as autowrap is usually enabled with CSI ?7h and disabled with CSI ?7l" + set autowrap_mode 0 + set overflow_idx -1 + } + } + } default { + # CSI 20 h/l - LF/NL (default off) - automatically follow echo of LF, VT or FF with CR. puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } } @@ -4558,6 +4910,7 @@ tcl::namespace::eval overtype { #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"} { + #REVIEW #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 @@ -4828,19 +5181,21 @@ tcl::namespace::eval overtype { #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW set in_overflow 1 } - set trailing_nulls 0 - foreach ch [lreverse $outcols] { - if {$ch eq "\u0000"} { - incr trailing_nulls - } else { - break - } - } - if {$trailing_nulls} { - set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] - } else { - set first_tail_null_posn -1 - } + + #review + #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]" @@ -4848,6 +5203,8 @@ tcl::namespace::eval overtype { #NOTE understacks has been updated with data from the overlay - so it should reflect the final state of the stacks for each grapheme in outcols + set in_tab_expansion [dict create idx -1 remaining 0] + set final_outcols [list] ;#we need to build as a list because we may need to backtrack to handle tab expansion areas that have been overwritten (by movements) after seeing the next char foreach ch $outcols { #puts "---- [ansistring VIEW $ch]" @@ -4955,34 +5312,107 @@ tcl::namespace::eval overtype { append overflow_right $ch } } else { + set this_outstring "" 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} { + #REVIEW - create test in test::overtype package regarding tab in particular. + if {$ch ne "\t" && [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 " " + if {[dict get $in_tab_expansion remaining] > 0} { + if {$ch eq "\u0000"} { + #we expect nulls in the tab expansion area - they represent placeholders for the columns occupied by the tab expansion + #assuming there are enough nulls remaining in the outcols to cover the tab expansion area, we can just add no string for this char and move on. + #If we run out of nulls before the tab expansion area is covered, then we will need to backtrack and invalidate the tab char + lappend final_outcols [list $gxleader $sgrleader ""] ;#we need to maintain the same number of columns in final_outcols as in outcols, even if some of them are empty strings, so we can backtrack and fill if necessary. + dict incr in_tab_expansion remaining -1 } else { - if {$trailing_nulls && $i < $first_tail_null_posn} { - append outstring " " ;#map inner nulls to space - } else { - append outstring \u0000 + #A non-null within the tab expansion area - probably due to later movement operations in the overlay overfilling into the middle of a tab expansion area. + #we need to backtrack and replace the tab with a space and then insert the correct number of following spaces and then output the non-null char, and then continue with the rest of the tab expansion area as normal. + #(insertion into any column of a wide-grapheme - whether tab or not - means we can't display the grapheme as it was in the underlay, + # so we need to replace the non-overwritten parts with an exposed char - in the case of tabs, we use a space as the exposed chars) + #the column that had the tab is stored in the in_tab_expansion dict, along with the remaining width to expand. + set tab_idx [dict get $in_tab_expansion idx] + set tab_remaining [dict get $in_tab_expansion remaining] + + set tabvalue [lindex $outcols $tab_idx] ;#will be some ANSI string (possibly empty string) followed by \t + set tabansi [string trimright $tabvalue "\t"] ;#strip the tab char to get just the ANSI that was before it in the underlay + #we need to backtrack to the tab char and replace it with a space, and then update the correct number of following spaces and then output the non-null char, and then continue with the rest of the tab expansion area as normal. + lset final_outcols $tab_idx [list $gxleader $sgrleader " "] + + for {set next_idx [expr {$tab_idx +1}]} {$next_idx < $i} {incr next_idx} { + if {[lindex $final_outcols $next_idx 2] eq ""} { + #empty aside from the ANSI that was before the tab char in the underlay - we can just add a space here to fill in the tab expansion area, and keep going until we have filled in the whole tab expansion area. + lset final_outcols $next_idx [list $gxleader $sgrleader " "] + } else { + #we have a non-null char already in the final_outcols in the tab expansion area? + #This shouldn't happen as we should have been tracking the remaining width in the tab expansion area and backtracking to the tab char as soon as we see the first non-null char, + puts stderr "overtype::renderline - unexpected non-null char '$ch' at idx:$i already in final_outcols in tab expansion area. This suggests a logic error in the handling of tab expansion areas. Please report this with a test case that reproduces it." + #review + break + } } + set in_tab_expansion [dict create idx -1 remaining 0] + + #for {set j 1} {$j < $i} {incr j} { + # set next_idx [expr {$tab_idx + $j}] + # if {[lindex $final_outcols $next_idx] eq ""} { + # #empty aside from the ANSI that was before the tab char in the underlay - we can just add a space here to fill in the tab expansion area, and keep going until we have filled in the whole tab expansion area. + # lset final_outcols $next_idx " " + # } else { + # #we have a non-null char already in the final_outcols in the tab expansion area + # #- this means we have already backtracked for this tab char, so we shouldn't need to do anything more for this char + # #review + # } + #} + + #append this_outstring $gxleader $sgrleader $ch + lappend final_outcols [list $gxleader $sgrleader $ch] + set this_outstring "" } } else { - append outstring $ch + #append this_outstring $gxleader + #append this_outstring $sgrleader + if {$ch eq "\t"} { + set tab_column [expr {$i+1}] + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + #todo - first check if there was an existing in_tab_expansion. + set in_tab_expansion [dict create idx $i remaining [expr {$this_tab_width -1}]] + set this_char \t + } elseif {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + set this_char " " + } else { + set this_char " " + #if {$trailing_nulls && $i < $first_tail_null_posn} { + # append outstring " " ;#map inner nulls to space + #} else { + # append outstring \u0000 + #} + } + } else { + set this_char $ch + } + #lappend final_outcols $this_outstring + lappend final_outcols [list $gxleader $sgrleader $this_char] } } incr i } + #set outstring [join $final_outcols ""] + set outstring "" + foreach triple $final_outcols { + append outstring [join $triple ""] + } + + #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? @@ -5055,9 +5485,9 @@ tcl::namespace::eval overtype { } } } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } + #if {[string length $overflow_right]} { + # puts stderr "remainder:$overflow_right" + #} #pdict $understacks if {[punk::ansi::ta::detect_sgr $outstring]} { @@ -5095,6 +5525,14 @@ tcl::namespace::eval overtype { #and overflow_right reopen? } + if {$instruction eq "reflow"} { + dict set opts -insert_mode $insert_mode + dict set opts -autowrap_mode $autowrap_mode + dict set opts -cursor_column $cursor_column + dict set opts -cursor_row $cursor_row + return [renderline {*}$opts $outstring $overflow_right] + } + 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 @@ -5140,32 +5578,57 @@ tcl::namespace::eval overtype { } replay_codes_overlay $replay_codes_overlay {*}{ } pm_list $pm_list {*}{ }] - if {$opt_returnextra == 1} { - #puts stderr "renderline: $result" - return $result - } else { + + #if {$opt_returnextra == 1} { + # #puts stderr "renderline: $result" + # #return $result + #} + + if {$opt_returnextra != 1 && $opt_returnextra != 9} { #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. - } + #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. + # } + #} + + #-info values 2,3,4 for view modes + if {($opt_returnextra | 3) == $opt_returnextra} { + set viewop VIEWCODES + } elseif {($opt_returnextra | 4) == $opt_returnextra} { + set viewop VIEWSTYLE } + + 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 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 overflow_right [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result unapplied_ansisplit [ansistring $viewop -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 + } + + #-info values 9,10,11,12 + if {($opt_returnextra | 8) == $opt_returnextra} { + return [pdict -channel none result] + } else { return $result } + + } else { #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" return $outstring @@ -5230,6 +5693,12 @@ interp alias "" piper_renderline "" overtype::piper::renderline #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} { + #special case error on tab character. It is a movement code rather than a grapheme and will manifest as different widths depending on the column position. + #we don't have the context of the column position here, so we can't give a correct answer - and it would also make no sense to cache an answer for a tab character. + #It is the caller's responsibility to not pass a tab character to this function, or to handle the error and deal with tabs separately. + if {$ch eq "\t"} { + error "grapheme_width_cached does not support tab character. Tabs are movement codes rather than graphemes and will manifest as different widths depending on the column position. Query was [ansistring VIEW -lf 1 -vt 1 -nul 1 $ch]" + } variable grapheme_widths if {[tcl::dict::exists $grapheme_widths $ch]} { return [tcl::dict::get $grapheme_widths $ch] @@ -5439,18 +5908,49 @@ tcl::namespace::eval overtype::priv { set unapplied [join $unapplied_list ""] } proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks + #todo - like render_insertgraphemes we need to reflow later tabs in the line. + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar tstops tstops + set nxt [llength $o] if {$i < $nxt} { - #set o [lreplace $o $i $i] - ledit o $i $i - #set ustacks [lreplace $ustacks $i $i] - ledit ustacks $i $i + if {[set tpos [lsearch -exact -start $i $o "\t"]] >= 0} { + #strip our precalculated nulls from tabs + set nullposns [lsearch -all -exact -start $tpos $o "\u0000"] + #puts "nullposns for tab at $tpos: $nullposns" + set num_removed 0 + foreach np $nullposns { + set delidx [expr {$np - $num_removed}] + ledit o $delidx $delidx + ledit ustacks $delidx $delidx + ledit gxstacks $delidx $delidx + incr num_removed + } + } + ledit o $i $i + ledit ustacks $i $i #review - do we need to ensure that stack at new $i has a reset code at the start? - #set gxstacks [lreplace $gxstacks $i $i] - ledit gxstacks $i $i + ledit gxstacks $i $i + + + set tpos [lsearch -exact -start $i $o "\t"] + while {$tpos >= 0 && $tpos < [llength $o]} { + set tpos_sgrstack [lindex $ustacks $tpos] + set tpos_gxstack [lindex $gxstacks $tpos] + set tab_column [expr {$tpos+1}] + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + for {set wi 1} {$wi < $this_tab_width} {incr wi} { + set nullidx [expr {$tpos+$wi}] + ledit o $nullidx -1 \u0000 + ledit ustacks $nullidx -1 $tpos_sgrstack + ledit gxstacks $nullidx -1 $tpos_gxstack + } + set tpos [lsearch -exact -start [expr {$tpos + $this_tab_width}] $o "\t"] + } } elseif {$i == 0 || $i == $nxt} { #nothing to do } else { @@ -5497,13 +5997,17 @@ tcl::namespace::eval overtype::priv { 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"} { + if {$existing eq "\u0000"} { lset o $i $c } else { lset o $i $existing$c } } + + #is actually addgrapheme? + #when we have tabs later in the line than our insertion point + #- we will need to update the outcols for those tabs to reflect the new column positions of the graphemes after the insertion point proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { upvar outcols o upvar understacks ustacks @@ -5525,7 +6029,7 @@ tcl::namespace::eval overtype::priv { # 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 codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info] set codestate_reverse [dict get $codeinfo codestate reverse] switch -- $codestate_reverse { 7 { @@ -5611,6 +6115,112 @@ tcl::namespace::eval overtype::priv { } } + #insert graphemes at index i - all with same sgrstack and gx0stack - caller is responsible for ensuring this is correct for all graphemes being inserted + proc render_insertgraphemes {i glist sgrstack gx0stack} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar tstops tstops + + # -- --- --- + #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] + #} + + if {$sgrstack eq ""} { + #An overlay char with no sgrstack should not take on any attributes of the underlay + set ustack_lengths [lmap s $ustacks {llength $s}] + set nonzero [lsearch -integer -not $ustack_lengths 0] + if {$nonzero >= 0} { + set sgrstack [list "\x1b\[m"] + } + } + + #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] + 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] + set num_graphemes [llength $glist] + #todo? + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + if {[set tpos [lsearch -exact -start $i $o "\t"]] >= 0} { + #strip our precalculated nulls from tabs + set nullposns [lsearch -all -exact -start $tpos $o "\u0000"] + #puts "nullposns for tab at $tpos: $nullposns" + set num_removed 0 + foreach np $nullposns { + set delidx [expr {$np - $num_removed}] + ledit o $delidx $delidx + ledit ustacks $delidx $delidx + ledit gxstacks $delidx $delidx + incr num_removed + } + } + + #JMN insert via ledit + ledit o $i -1 {*}$glist + ledit ustacks $i -1 {*}[lrepeat $num_graphemes $sgrstack] + ledit gxstacks $i -1 {*}[lrepeat $num_graphemes $gx0stack] + + #JJJ + set tpos [lsearch -exact -start $i+1 $o "\t"] + while {$tpos >= 0 && $tpos < [llength $o]} { + set tpos_sgrstack [lindex $ustacks $tpos] + set tpos_gxstack [lindex $gxstacks $tpos] + set tab_column [expr {$tpos+1}] + set prev_stop_idx [lsearch -integer -bisect $tstops $tab_column] + set next_stop [lindex $tstops $prev_stop_idx+1] ;#if our tab_column is exactly on a stop, we still want to move to the next stop. + set this_tab_width [expr {$next_stop - $tab_column}] ;#diff between two adjacent columns is one. + for {set wi 1} {$wi < $this_tab_width} {incr wi} { + set nullidx [expr {$tpos+$wi}] + ledit o $nullidx -1 \u0000 + ledit ustacks $nullidx -1 $tpos_sgrstack + ledit gxstacks $nullidx -1 $tpos_gxstack + } + set tpos [lsearch -exact -start [expr {$tpos + $this_tab_width}] $o "\t"] + } + + } else { + lappend o {*}$glist + lappend ustacks {*}[lrepeat $num_graphemes $sgrstack] + lappend gxstacks {*}[lrepeat $num_graphemes $gx0stack] + } + } + } diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 54f56f04..22c27388 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -123,6 +123,7 @@ tcl::namespace::eval punk::aliascore { stripansi ::punk::ansi::ansistrip ansiwrap ::punk::ansi::ansiwrap grepstr ::punk::ansi::grepstr + untabify ::punk::ansi::untabify colour ::punk::console::colour color ::punk::console::colour ansi8 ::punk::ansi8 diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 1c9f2bbc..7e7bc823 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -726,19 +726,28 @@ tcl::namespace::eval punk::ansi { } else { set cols 80 } - set rows 24 if {[dict exists $sdict columns]} { set c [dict get $sdict columns] if {$c > 0} { set cols $c } } + #set rows 24 + set rows -1 if {[dict exists $sdict rows]} { set r [dict get $sdict rows] if {$r > 0} { set rows $r } } + if {$rows == -1} { + set consize [punk::console::get_size] + if {$consize ne ""} { + set rows [expr {[dict get $consize rows] -1}] + } else { + set rows 24 + } + } set dimensions ${cols}x${rows} } lassign [split $dimensions x] cols rows @@ -1169,6 +1178,17 @@ tcl::namespace::eval punk::ansi { a form where the ANSI only represents SGR styling (and perhaps other non-movement codes) using something like overtype::renderline or overtype::rendertext. + Note that traditional terminals and most modern emulators treat the tab character as a + movement code + So even though the a regex such as {\s} will match various whitespace characters including tabs, + - ANSI SGR codes will not highlight, underline etc the tab characters themselves. + + ********************************************************************************************** + Also - tab characters are *currently* likely to cause output misalignment/truncation + especially if multiple rounds of grepstr are applied. + TODO - find a better way to handle tab characters in input. + For now - the input should be untabified first e.g with punk::ansi::untabify or similar. + ********************************************************************************************** Examples for returning matched lines only in the help output of the 'i' command: @@ -1359,6 +1379,9 @@ tcl::namespace::eval punk::ansi { if {[dict exists $received -ansistrip]} { set data [punk::ansi::ansistrip $data] } + if {[string first \t $data] >= 0} { + puts stderr "Warning: grepstr does not currently handle tab characters in the input data. Tabs should be expanded to spaces first e.g with punk::ansi::untabify or similar." + } set highlight [dict get $opts -highlight] set opt_returnlines [dict get $opts -return] set opt_invert [dict exists $received -invert-match] @@ -6229,40 +6252,44 @@ be as if this was off - ie lone CR. #https://crates.io/crates/unicode-display-width #JMN - set width 0 set sumwidth 0 foreach g $outchars { set dec_codes [scan $g [tcl::string::repeat %c [string length $g]]] - set maxwidth 0 + set max_component_width 0 ;#longest width of any single char in the grapheme cluster + set gwidth 0 ;#width of the whole grapheme cluster foreach dec $dec_codes { if {$dec <= 255} { if {$dec >= 31 && $dec != 127} { - incr sumwidth 1 - if {$maxwidth == 0} { - set maxwidth 1 + incr gwidth 1 + if {$max_component_width == 0} { + set max_component_width 1 } } } elseif {$c < 917504 || $c > 917631} { #codepoint not in the zero-width unicode tag block - \UE0000-\UE000F #set w [punk::char::char_width $dec] set w [textutil::wcswidth_char $dec] - if {$w > $maxwidth} { - set maxwidth $w - } - if {$maxwidth == 2} { - #we can stop looking at this grapheme - it's already double width - break + #if {$max_component_width == 2 && $w == 2} { + # #we can stop looking at this grapheme - it's already double width + # break + #} + if {$w > $max_component_width} { + set max_component_width $w } - incr sumwidth $w + incr gwidth $w } } - if {$maxwidth == 2} { - set width 2 - } else { - set width $sumwidth + + if {$max_component_width == 2} { + #if any char in the grapheme is double width - then the whole grapheme is double width + #This is a simplification that doesn't handle complex scripts such as arabic ligatures. + #review - find a more broadly accurate method of calculating grapheme width that handles complex cases such as ligatures and combiners affecting width. + #we could for example restrict this rule to cases where the base char is east asian width 2 - which would cover the common cases of double-width CJK chars and emojis - but would still allow for combiners and ligatures to affect width in other cases. + set gwidth 2 } + incr sumwidth $gwidth } - return $width + return $sumwidth #return [punk::char::ansifreestring_width [join $outchars ""]] } namespace eval internal { @@ -6705,7 +6732,8 @@ be as if this was off - ie lone CR. set scopeinfo [dict create tabstops $tabstops columncount $ccount columnmaxwidths $colmaxwidths] } else { #same number of tabs as previous row - so same scope - set scope_key [expr {$r-1}] + #set scope_key [expr {$r-1}] ;#wrong - scope key is the first row in the scope - which is only necessarily the previous row if the previous row is the first row in the scope. + #just leave scope_key as it is from the previous iteration of the loop. set scopeinfo [dict get $scopes $scope_key] set update_colmaxwidths [dict get $scopeinfo columnmaxwidths] set update_tstops [dict get $scopeinfo tabstops] @@ -6866,7 +6894,7 @@ be as if this was off - ie lone CR. -with -type list|literal(spaces)|literal(unicode) -minsize 2 -maxsize 2 -default spaces -help\ "Whether to replace the tab characters with a custom pair of characters, a plain string of spaces, or to use the default unicode characters to represent the tabs and following whitespace. - The character \U21E5 followed by a calculated number of \U00A0 (non-breaking space) characters is used when 'unicode' + The character \\U21E5 (\U21E5) followed by a calculated number of \\U00A0 (non-breaking space) characters is used when 'unicode' is specified. A 2 element list can be supplied to specify the character to use for the tab and the character to use for the @@ -6997,6 +7025,7 @@ be as if this was off - ie lone CR. #puts stderr "tstops: $tstops maxdiff: $maxdiff" set num [lindex $tstops 0] set out [list] + set lines [list] foreach line [split $textblock \n] { #lappend out [untabifyLine $line $maxdiff] set currPos 0 @@ -7955,23 +7984,21 @@ tcl::namespace::eval punk::ansi { #safe jumptable test #dict for {k v} $codestate {} tcl::dict::for {k v} $codestate { - switch -- $v { - "" {} - default { - switch -- $k { - underlinecolour { - append unmergeable "${v}\;" - } - underextended { - #review - append unmergeable "${v}\;" - } - default { - append codemerge "${v}\;" - } + if {$v ne ""} { + switch -- $k { + underlinecolour - underextended { + append unmergeable "${v}\;" + } + default { + append codemerge "${v}\;" } } } + #switch -- $v { + # "" {} + # default { + # } + #} } } set reset_prior 0 diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index e601a97f..9c378b1a 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -1445,15 +1445,15 @@ namespace eval punk::console { set width [dict get $tsize columns] set mod [expr {$width % $w}] set max [expr {$width - $mod}] - set tstops "" + set tstop_ansi "" set c 1 while {$c <= $max} { - append tstops [string repeat " " $w][punk::ansi::set_tabstop] + append tstop_ansi [string repeat " " $w][punk::ansi::set_tabstop] incr c $w } - set punk::console::tabwidth $w ;#we also attempt to read terminal's tabstops and set tabwidth to the apparent spacing of first non-1 value in tabstops list. - catch {textutil::tabify::untabify2 "" $w} ;#textutil tabify can end up uninitialised and raise errors like "can't read Spaces().." after a tabstop change This call seems to keep tabify happy - review. - puts -nonewline "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstops" + set ::punk::console::tabwidth $w ;#we also attempt to read terminal's tabstops and set tabwidth to the apparent spacing of first non-1 value in tabstops list. + #catch {textutil::tabify::untabify2 "" $w} ;#textutil tabify can end up uninitialised and raise errors like "can't read Spaces().." after a tabstop change This call seems to keep tabify happy - review. + puts -nonewline "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstop_ansi" } @@ -2574,6 +2574,46 @@ namespace eval punk::console { dict set DECRQSS_DICT $name $str } + + namespace eval argdoc { + proc decrqss_choices_and_help {} { + #return a string for use in the punk::args definition for ::punk::console::dec_request_setting that lists the valid choices for the name argument, and their help text. + #This requires a -choices and -choicelabels pair in the args definition, to allow the help text to be directly associated with the choices. + upvar ::punk::console::DECRQSS_DATA DECRQSS_DATA + set outstr "name -type string -choices \{" + foreach {desc name str} $DECRQSS_DATA { + append outstr " $name" + } + append outstr " \}" + append outstr " -choicecolumns 4 -choicelabels \{" \n + foreach {desc name str} $DECRQSS_DATA { + append outstr " $name \{ ${desc}\}" \n + } + append outstr " \} -help " + append outstr " {Dec setting name to query.}" + return $outstr + + #append argdef " \} -choicecolumns $opt_columns -choicelabels \{" \n + #append argdef " $choicelabelsdict" \n + #append argdef " \} -choiceinfo \{$choiceinfodict\} -unindentedfields \{-choicelabels\}" \n + } + set DECRQSS_CHOICES [::punk::console::argdoc::decrqss_choices_and_help] + lappend PUNKARGS [list { + @id -id ::punk::console::dec_request_setting + @cmd -name punk::console::dec_request_setting\ + -summary\ + {Perform DECRQSS query to get DECRPSS response}\ + -help\ + {DECRQSS query for DEC Selection or Setting. + Return payload from console's DECRPSS response. + } + @opts + -console -type list -minsize 2 -default {stdin stdout} + @values -min 1 -max 1 + ${$DECRQSS_CHOICES} + } + ] + } #emit DECRQSS and get DECRPSS response # --------------------- #NOTE: https://vt100.net/docs/vt510-rm/DECRPSS.html @@ -2582,23 +2622,9 @@ namespace eval punk::console { # shown at: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html #REVIEW # --------------------- - #Note also on Freebsd xterm we seem to getresponse ': 1 $ r D...D ST' - #(no leading DCS) - this + #Note also on Freebsd xterm we seem to get response ': 1 $ r D...D ST' + #(no leading DCS) - review - lappend PUNKARGS [list { - @id -id ::punk::console::dec_request_setting - @cmd -name punk::console::dec_request_setting\ - -summary\ - {Perform DECRQSS query to get DECRPSS response}\ - -help\ - {DECRQSS query for DEC Selection or Setting. - Return payload from console's DECRPSS response. - } - @opts - -console -type list -minsize 2 -default {stdin stdout} - @values -min 1 -max 1 - name -type string - }] proc dec_request_setting {args} { set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] lassign [dict values $argd] leaders opts values @@ -2631,6 +2657,106 @@ namespace eval punk::console { return [string range $payload 3 end] } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::console::cursor_style + @cmd -name punk::console::cursor_style\ + -summary\ + {Get/Set cursor style}\ + -help\ + {Set cursor style using DECSCUSR. + Note that support for DECSCUSR may be inconsistent across terminals. + Some terminals may only support a subset of the possible styles.} + @opts + -console -type list -minsize 2 -default {stdin stdout} + @values -min 0 -max 1 + style -type dict -optional 1 -choicerestricted 0 -choices {0 default 1 block-blink 2 block-steady 3 underline-blink 4 underline-steady 5 beam-blink 6 beam-steady} -choicecolumns 2 -help\ + "Cursor style to set + May be an integer or name as in the choices or a dict of the form { } + as returned by a query of the current style. + + e.g to set block-blink style, you could specify style as 1, block-blink or {1 block-blink} + + After setting to 0 (default) - a subsequent query will not return {0 default} but rather the number and name + of the actual style that the terminal has reset to. + + If not supplied, the current style will be queried and returned as a dict + where num is the key and name is the value, e.g. {2 block-steady}. + This allows querying the current style and then re-setting it after temporarily changing it." + }] + } + proc cursor_style {args} { + set argd [punk::args::parse $args -cache 1 withid ::punk::console::cursor_style] + lassign [dict values $argd] leaders opts values + set console [dict get $opts -console] + set style "" ;#if not supplied, will query current style instead of setting + set style_num_to_name [dict create {*}{ + 0 default + 1 block-blink + 2 block-steady + 3 underline-blink + 4 underline-steady + 5 beam-blink + 6 beam-steady + }] + set style_name_to_num [dict create {*}{ + default 0 + block-blink 1 + block-steady 2 + underline-blink 3 + underline-steady 4 + beam-blink 5 + beam-steady 6 + }] + if {[dict exists $values style]} { + set style [dict get $values style] + } + if {$style eq ""} { + #query current style using DECRQSS/DECRPSS (dec_request_setting DECSCUSR) + set resultnum [dec_request_setting -console $console DECSCUSR] + if {![string is integer -strict $resultnum]} { + error "cursor_style query for current style returned non-integer result '$resultnum'" + } + if {![dict exists $style_num_to_name $resultnum]} { + error "cursor_style query for current style returned unrecognised style number '$resultnum'. Known styles: [dict keys $style_num_to_name]" + } + set resultname [dict get $style_num_to_name $resultnum] + set result [dict create $resultnum $resultname] + return $result + } + if {[string is integer -strict $style]} { + set style_num $style + if {![dict exists $style_num_to_name $style_num]} { + error "cursor_style unrecognised style number '$style_num'. Known styles: [dict keys $style_num_to_name]" + } + } elseif {[::punk::args::lib::string_is_dict $style]} { + #allow setting cursor using the response from a previous call to query the current style. + if {[dict size $style] != 1} { + error "cursor_style style dict should have exactly one key-value pair {