jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1285 Commits
1 Branch
1 Tag
204 MiB
 
 
 
 
 
 
Tree: 0d80cf6771
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '0d80cf6771'
${ noResults }
punkshell/src/modules/overtype-999999.0a1.0.tm

6281 lines
371 KiB
Raw Blame History

# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-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 999999.0a1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 999999.0a1.0]
#[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 <julian@precisium.com.au> - 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 {
if {[info commands ::overtype::assert] eq ""} {
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 "ANSI capable 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]
}
set dostrip 0
#return [punk::char::ansifreestring_width $text]
return [punk::ansi::printing_length $text $dostrip]
}
#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 [expr {$renderwidth + 1}]
} else {
return $endpos
}
}
}
}
tcl::namespace::eval overtype {
#*** !doctools
#[subsection {Namespace 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} -choiceprefix 0 -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.}
-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)"
-format -default ansi -type string -choices {ansi binarytext-bios binarytext-ice xbin} -choiceprefix 0 -help\
"Format of new data being applied as an overlay"
-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
#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] < 1} {
error {usage: ?-width <int>? ?-startcolumn <int>? ?-transparent [0|1|<char>]? ?-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 {
#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: <underblock> <overblock> or just <overblock>"
#}
}
set opts [tcl::dict::create {*}{
-bias ignored
-width \uFFEF
-height \uFFEF
-startcolumn 1
-startrow 1
-ellipsis 0
} -ellipsistext $default_ellipsis_horizontal {*}{
-ellipsiswhitespace 0
-expand_right 0
-appendlines 1
-transparent 0
-exposed1 \uFFFD
-exposed2 \uFFFD
-cp437 0
-looplimit \uFFEF
-crm_mode 0
-reverse_mode 0
-insert_mode 0
-wrap 0
-info 0
-format ansi
-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 - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace
- -transparent - -exposed1 - -exposed2
- -expand_right - -appendlines
- -reverse_mode - -crm_mode - -insert_mode
- -cp437
- -info - -format - -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_startrow [tcl::dict::get $opts -startrow]
#review -appendlines - this needs thought regarding interaction with terminal height concept and scrolling
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]
set opt_format [tcl::dict::get $opts -format]
set opt_console [tcl::dict::get $opts -console]
#--------------------------------------------------------------------------
#TODO
#REVIEW - punk::console package may not be loaded
#set cursor_style_overtype {3 underline-blink}
#set cursor_style_insert {5 beam-blink}
#if {$opt_insert_mode} {
# set initial_cursor_style $cursor_style_insert
#} else {
# set initial_cursor_style $cursor_style_overtype
#}
#catch {
# punk::console::cursor_style -console $opt_console $cursor_style_overtype
#}
#--------------------------------------------------------------------------
#---------------------------------------------------------
#underblock is expected to be pre-rendered - ie any ANSI codes have already been processed and rendered into the text.
#This is because the underblock is used as the basis for calculating the layout of the output
#- so it needs to be in a form where we can determine the width of each line and how many lines there are.
set underblock [tcl::string::map {\r\n \n} $underblock]
#do not split the overblock into lines at this stage - it may contain binary data.
#REVIEW - xbin (or binarytext?) may contain binary data which could be corrupted by mapping \r\n to \n.
#set overblock [tcl::string::map {\r\n \n} $overblock]
#---------------------------------------------------------
if {$opt_startrow > 1} {
set down [expr {$opt_startrow -1}]
#when vt52?
set overblock [punk::ansi::move_down $down]$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 {*}{
} row 1 {*}{
} col 1 {*}{
} topmargin 1 {*}{
} bottommargin $renderheight {*}{
}
]
#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
dict set vtstate col $opt_startcolumn
# -- --- --- ---
#REVIEW - do we need ansi resets in the underblock?
if {$underblock eq ""} {
set blankline [string repeat \u0000 $renderwidth]
set underlines [lrepeat $renderheight $blankline]
} else {
#----
#this splits into lines - only to rejoin - which is inefficient.
#It also has code to handle joining multiple blocks - but we only have one in this case.
#set underblock [textblock::join_basic_raw $underblock];#ensure properly rendered - ansi per-line resets & replays
#set underlines [split $underblock \n]
#----
if {[punk::ansi::ta::detectcode $underblock]} {
#-ansireplays 1 quite expensive e.g ~15us for only 3 short lines on a 2026 threadripper pro
set underlines [punk::lib::linelist -ansireplays 1 $underblock]
} else {
set underlines [split $underblock \n]
}
}
#underlines are not necessarily processed in order - depending on cursor-moves applied from overtext
# -- --- --- ---
#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 inputchunks [list]
switch -- $opt_format {
ansi {
#ansi is commonly but not always line-based.
#some ansi is a string of data with ansi movements and no linefeeds.
set overblock [tcl::string::map {\r\n \n} $overblock]
foreach ln [split $overblock \n] {
lappend inputchunks [list mixed $ln\n]
}
if {[llength $inputchunks]} {
#strip trailing newline from last line.
lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1]
}
}
binarytext-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
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]
}
if {[catch {encoding convertfrom cp437 $ch} ch]} {
puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]"
set ch \uFFeF
}
append input $code $ch
lappend ansisplit $code $ch
incr charpair
}
#lappend inputchunks [list mixed $input]
lappend inputchunks [list ansisplit $ansisplit]
}
binarytext-ice {
#16 fg, 16 bg (no blink)
set input ""
foreach {ch at} [split $overblock ""] {
if {$at ne ""} {
append input [punk::ansi::colour::byteAnsiIce $at]
}
set ch [encoding convertfrom cp437 $ch]
append input $ch
}
lappend inputchunks [list mixed $input]
}
xbin {
set parse_dict [punk::ansi::xbin::parse $overblock]
set ansisplit [dict get $parse_dict ansisplit]
set xbin_header_info [dict get $parse_dict header]
set flags [dict get $xbin_header_info flags]
set xbin_width [dict get $xbin_header_info width]
set xbin_height [dict get $xbin_header_info height]
puts stdout "xbin dimensions ${xbin_width}x${xbin_height} decoded [dict get $parse_dict decoded_cells] of [dict get $parse_dict expected_cells] expected cells"
puts stdout "xbin flags $flags"
set warnings [dict get $parse_dict warnings]
foreach w $warnings {
puts stderr "xbin warning: $w"
}
puts stdout "xbin decoded"
flush stdout
lappend inputchunks [list ansisplit $ansisplit]
}
}
#we have a list of 2 element input chunks {overtext_type overtext} in $inputchunks
#- each chunk is either a string of text with embedded ANSI codes (type 'mixed')
#- or a list of alternating ANSI code and text segments (type 'ansisplit')
#For ansi files each chunk may commonly correspond to a line of text - but this is not necessarily the case, as ANSI cursor movements and other codes may be present which affect the layout in ways that can't be determined until processing.
#for binary files - there may be no newlines at all - just a stream of bytes with ANSI codes interspersed to control the layout and colours.
#The chunks are processed in order, with the output of each chunk being rendered onto the current 'underlay' of the output,
#and then becoming the new 'underlay' for the next chunk to render onto.
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
set instruction_stats [tcl::dict::create]
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
#use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member is an 'ansisplit' list
if {$overtext eq ""} {
incr loop
continue
}
#puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----"
set undertext [lindex $outputlines [dict get $vtstate row]-1]
if {[tcl::dict::exists $replay_codes_underlay [dict get $vtstate row]]} {
set undertext [tcl::dict::get $replay_codes_underlay [dict get $vtstate row]]$undertext
}
#renderline pads each underly 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"
#}
######################
#remember the row we are just about to render.
set renderedrow [dict get $vtstate row]
if {$renderedrow > $renderedrow_max} {
set renderedrow_max $renderedrow
}
#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 {*}{
} -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 [tcl::dict::get $vtstate col] {*}{
} -cursor_row [tcl::dict::get $vtstate row] {*}{
} -overtext_type $overtext_type {*}{
}
]
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 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]
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]
#review - this assumes lines are rendered in order - but this isn't always true.
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]
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 {[dict get $vtstate row] > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == [dict get $vtstate 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_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 virtual terminal' (not underlying terminal)
set vtstate [tcl::dict::merge $vtstate $initial_state]
#todo - clear screen
}
{} {
#end of supplied line input
#lf included in data
dict set vtstate row $post_render_row
#dict set vtstate col $post_render_col
if {![llength $unapplied_list]} {
if {$overflow_right ne ""} {
dict incr vtstate row
}
} else {
puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)"
}
dict set vtstate 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"
dict set vtstate row $post_render_row
dict set vtstate col $post_render_col
}
down {
#cursor down. Will not force scroll if at bottom of screen.
if {$post_render_row > [llength $outputlines]} {
#renderline doesn't know how far down we can go..
set post_render_row [llength $outputlines]
}
dict set vtstate row $post_render_row
dict set vtstate col $post_render_col
}
down_scrolling {
#todo - scrolling region. take account of decstbm.
#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]}]
set bce_line \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]
if {$diff > 0} {
lappend outputlines {*}[lrepeat $diff $bce_line]
}
lappend outputlines $bce_line
}
}
dict set vtstate row $post_render_row
dict set vtstate col $post_render_col
}
restore_cursor {
#testfile belinda.ans uses this
#puts stdout "[a+ blue bold]CURSOR_RESTORE[a]"
if {[tcl::dict::exists $cursor_saved_position row]} {
dict set vtstate row [tcl::dict::get $cursor_saved_position row]
dict set vtstate 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 ">>>renderspace<<<[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 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..
}
set overflow_handled 1
}
decstbm {
#scrolling region - CSI r
#renderline will have rendered the line based on the current vtstate row/col
#- but the scrolling region change may have caused a move to be rendered to the output which changes the row/col for the next line
#- so we need to update our vtstate cursor position.
lassign $instruction _ margin_top margin_bottom
set margins_valid 1 ;#default assumption
#todo - validate margins. A valid scrolling region requires at least two lines.
if {$margin_top eq ""} {set margin_top 1}
if {$margin_bottom eq ""} {set margin_bottom $screen_rows}
if {![string is integer -strict $margin_top] || $margin_top < 1} {
puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set margins_valid 0
}
if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} {
puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set margins_valid 0
}
if {$margin_bottom - $margin_top < 1} {
puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set margins_valid 0
}
if {$margins_valid} {
#todo - return these for the caller to process..
puts stderr "overtype::renderspace DECSTBM set top and bottom margin not implemented"
#Also moves the cursor to col 1 line 1 of the page
#review - examine DECOM state to determine new cursor position?
dict set vtstate row 1
dict set vtstate col 1
#incr idx_over
#priv::render_to_unapplied $overlay_grapheme_control_list $gci
#set instruction [list decstbm $margin_top $margin_bottom]
dict set vtstate topmargin $margin_top
dict set vtstate bottommargin $margin_bottom
} else {
puts stderr "overtype::renderspace DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#don't update the vtstate margins.
}
}
move {
########
if {$post_render_row > [llength $outputlines]} {
#Ansi moves need to create new lines ?
#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]
}
dict set vtstate row $post_render_row
} else {
dict set vtstate row [llength $outputlines]
}
} else {
dict set vtstate row $post_render_row
}
#######
dict set vtstate col $post_render_col
#overflow + unapplied?
}
clear_to_end_display {
#ED 0
#review - needs to operate within top and bottom margins if set (decstbm) - but for now we assume full screen clear
#Current row already partially erased by renderline.
if {$post_render_row > [llength $outputlines]} {
dict set vtstate row [llength $outputlines]
} else {
dict set vtstate row $post_render_row
}
dict set vtstate col $post_render_col
set overflow_right ""
set start_idx [expr {[dict get $vtstate row]}]
if {$start_idx < 0} {set start_idx 0}
for {set i $start_idx} {$i < [llength $outputlines]} {incr i} {
lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m
}
}
clear_to_start_display {
#ED 1
#Current row already partially erased by renderline.
if {$post_render_row > [llength $outputlines]} {
dict set vtstate row [llength $outputlines]
} else {
dict set vtstate row $post_render_row
}
dict set vtstate col $post_render_col
set overflow_right ""
set stop_idx [expr {[dict get $vtstate row] - 1}]
if {$stop_idx >= [llength $outputlines]} {
set stop_idx [expr {[llength $outputlines] - 1}]
}
for {set i 0} {$i < $stop_idx} {incr i} {
lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m
}
}
clear_and_move {
#ED 2J
if {$post_render_row > [llength $outputlines]} {
dict set vtstate row [llength $outputlines]
} else {
dict set vtstate row $post_render_row
}
dict set vtstate col $post_render_col
set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant
for {set i 0} {$i < [llength $outputlines]} {incr i} {
lset outputlines $i \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]\x1b\[0m
}
#todo - determine background/default to be in effect - DECECM ?
puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]"
}
delete_lines {
#DL n
set delete_count [lindex $instruction 1]
set r $renderedrow
puts stderr "delete_lines $delete_count at row $r"
if {$delete_count > 0} {
#set outputlines [lreplace $outputlines [dict get $vtstate row] [expr {[dict get $vtstate row] + $delete_count - 1}]]
set delidx_first [expr {$r - 1}] ;#convert to 0-based index
set delidx_last [expr {$delidx_first + ($delete_count - 1)}] ;#inclusive index of last line to delete
#if delete_count is 1 - we are only deleting the current line.
ledit outputlines $delidx_first $delidx_last
}
dict set vtstate row $renderedrow
if {[llength $outputlines] < [dict get $vtstate row]} {
dict set vtstate row [llength $outputlines]
}
#we need to ensure 'unapplied' data is still applied to the current line after deletion.
#Any overflow on the current line should be abandoned.
if {[llength $unapplied_ansisplit]} {
#set inputchunks [linsert $inputchunks 0 $nextprefix]
#JMN - assume backwards compat ledit available from punk::lib (for tcl <9)
ledit inputchunks -1 -1 [list ansisplit $unapplied_ansisplit]
}
incr overidx
incr loop
continue
}
lf_start {
#raw newlines
# ----------------------
#test with fruit.ans
#test - treating as newline below...
#append rendered $overflow_right
#set overflow_right ""
dict set vtstate row [expr {$renderedrow + 1}]
if {[dict get $vtstate row] > [llength $outputlines]} {
#lappend outputlines ""
# BCE
lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]
}
set col $opt_startcolumn
# ----------------------
}
lf_mid {
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]
#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 ""
#review - why are we setting this here when we override it below?
dict set vtstate 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 ""]
}
}
}
}
dict set vtstate row $post_render_row
dict set vtstate col $opt_startcolumn
if {[dict get $vtstate row] > [llength $outputlines]} {
#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]
}
}
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 {![tcl::dict::get $vtstate insert_mode]} {
assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode
}
dict set vtstate row $post_render_row
#only add newline if we're at the bottom
if {[dict get $vtstate row] > [llength $outputlines]} {
#lappend outputlines {*}[lrepeat 1 ""]
# BCE
lappend outputlines \x1b\[0m$replay_codes_overlay[string repeat \u0000 $renderwidth]
}
dict set vtstate col $opt_startcolumn
}
newlines_above {
#we get a newlines_above instruction when <lf> 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 <lf> at column 1 the same as any other <lf>
puts "--->newlines_above"
puts "rinfo: $rinfo"
#renderline doesn't advance the row for us - the caller has the choice to implement or not
set temp_row $post_render_row
if {$insert_lines_above > 0} {
set temp_row $renderedrow
#set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]]
#ledit outputlines $renderedrow-1 $renderedrow-2 {*}[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 temp_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?
}
dict set vtstate row $temp_row
dict set vtstate col $post_render_col
}
newlines_below {
#obsolete? - use for ANSI insert lines sequence
puts --->nl_below
set temp_row $post_render_row
set temp_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 temp_row $renderedrow
#only add newline if we're at the bottom
if {$temp_row > [llength $outputlines]} {
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 temp_row $insert_lines_below
set temp_col $opt_startcolumn
}
dict set vtstate row $temp_row
dict set vtstate col $temp_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
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 $bce_line
}
}
set c $opt_startcolumn
} else {
incr c
}
incr i
}
#set col $c
} else {
#why are we getting this instruction then?
#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"
dict set vtstate row $r
dict set vtstate 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???"
}
dict set vtstate row $r
dict set vtstate 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 r $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 r
set c $opt_startcolumn ;#whether wrap or not - next data is at column 1 ??
} else {
set c $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 {
lappend new_unapplied_list $u
ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u"
}
} else {
lappend new_unapplied_list $u
lappend unapplied_ansisplit $u ""
}
incr idx
}
#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
}
dict set vtstate row $r
dict set vtstate col $c
}
overflow_splitchar {
set r $post_render_row ;#renderline will not advance row when reporting overflow char
set c $post_render_col
#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] ""]
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 c $opt_startcolumn
incr r
}
} 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] ""]
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]
}
}
dict set vtstate row $r
dict set vtstate col $c
}
vt {
#can vt add a line like a linefeed can?
dict set vtstate row $post_render_row
dict set vtstate 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
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 <list> end end <val> will work with empty list (ledit <list> end <val> does not)
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
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 {[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]
}
incr overidx
incr loop
if {$loop >= $looplimit} {
puts stderr "overtype::renderspace looplimit reached ($looplimit)"
lappend outputlines "[a+ red bold]<truncated> - 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 "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
}
}
#JMN
#REVIEW - we don't want to emit cursor_style ANSI unless it changes.
#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 {
#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]
}
}
}
#JULZ
#lappend outputlines $rendered
lappend outputlines $rendered\x1b\[m
#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]
#JULZ
#lappend outputlines [tcl::dict::get $rinfo result]
lappend outputlines [tcl::dict::get $rinfo result]\x1b\[m
}
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|<char>? 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
#broken:
#todo - renderline -overflow is invalid.
# we need renderline to support -expand_left ??
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]
}
}
}
#JULZ
#lappend outputlines $rendered
lappend outputlines $rendered\x1b\[m
} 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]
#JULZ
#lappend outputlines [tcl::dict::get $rinfo result]
lappend outputlines [tcl::dict::get $rinfo result]\x1b\[m
}
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|<char>? 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]
# }
#}
}
#JULZ
lappend outputlines $rendered\x1b\[m
} 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]
#JULZ
#lappend outputlines [tcl::dict::get $rinfo result]
lappend outputlines [tcl::dict::get $rinfo result]\x1b\[m
}
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
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 integer -choicecolumns 2 -choices {1 9 2 10 3 11 4 12 0} -choiceprefix 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
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
-overtext_type -type string -choices {mixed plain ansisplit} -choiceprefix 0 -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."
}]
}
proc stack_eq {a b} {
#single level list equality test to avoid generating internal string representations of the lists unnecessarily.
if {[llength $a] != [llength $b]} {
return 0
}
foreach code1 $a code2 $b {
if {$code1 ne $code2} {
return 0
}
}
return 1
}
#todo: tests
#set j [overtype::renderline -transparent " " -insert_mode 0 -expand_right 1 "[a+ red underline]xxx[a+ blue][a+ nounderline]" "[a green]J" ]yyy
# yyy should be blue with no underline - and the J should be green - and the x's should be red with underline and the J should overwrite the first x
#At the moment we return a reset at the end of the renderline result instead of the replay codes.
proc renderline {args} {
#-------------------------------------------------------------------------------------------------------------------------------------
#todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext/xbin which is not line-based.
#All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and very 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
#[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 <int>? ?-cursor_column <int>? ?-cursor_row <int>|""? ?-transparent [0|1|<regexp>]? ?-expand_right [1|0]? undertext overtext}
}
set under [lindex $args end-1]
set overdata [lindex $args end]
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
-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
#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 {
-cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row
- -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - -etabs
- -info - -exposed1 - -exposed2 - -cursor_restore_attributes - -overtext_type {
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]
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'"
}
}
# -- --- --- --- --- --- --- --- --- --- --- ---
#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"} {
#review - [\s] will match horizontal tabs as well as spaces - is this desirable for the default transparent character class?
#This would result in a tab in the overlay becoming transparent - but only always as width 1.
#Perhaps more reasonable would be to expand tabs when processing the transparency.
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
}
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} {
#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]
set under [punk::ansi::untabify -with spaces -stop $tw $under]
}
#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 $overdata] >= 0} {
#set overdata [textutil::tabify::untabify2 $overdata]
#set overdata [textutil::tabify::untabifyLine $overdata $tw]
set overdata [punk::ansi::untabify -with unicode -stop $tw $overdata]
}
}
}
}
}
#-------
#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]
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???
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 {
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] {
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
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
} 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]
#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]
lappend understacks $u_codestack
lappend understacks_gx $u_gx_stack
lappend undercols $grapheme
if {$width > 1} {
#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
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
}
}
}
}
}
#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]} {
#will normalize all resets to the same code - including 8bit reset.
#set u_codestack [list "\x1b\[m"]
set u_codestack [list $code]
} 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 "\u0000"} {
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]
}
}
}
#----------------------------------------
#set test_c [showlist $undercols]
##set test_s [showlist $understacks %ansiview]
#set sview [list]
#foreach us $understacks {
# lappend sview [ansistring VIEW $us]
#}
#set test_s [showlist $sview]
#puts stderr "undercols/stacks:\n[textblock::join -- $test_c " " $test_s]"
#----------------------------------------
if {$opt_width ne "\uFFEF"} {
set renderwidth $opt_width
} else {
set renderwidth [llength $undercols]
}
#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]
#u_codestack was built from codes split using split_codes_single
#- so should already be simplified to single codes with no multiple SGR params in one code
set replay_codes_underlay [punk::ansi::codetype::sgr_merge_singles $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 {$opt_overtext_type eq "ansisplit"} {
set overmap $overdata
lset overmap 0 "$startpadding[lindex $overmap 0]"
} else {
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]
#puts !
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]
}
#puts [ansistring VIEW $overmap] ;#debug
####
#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
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)
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]
#puts -nonewline stderr "!$len!"
#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 <ansi>} or {g <text>}
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 ;#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
if {$code_endswith_m && [punk::ansi::codetype::is_sgr_reset $code]} {
#reset better than empty list - fixes some ansi art issues
#set o_codestack [list "\x1b\[m"]
set o_codestack [list $code]
lappend overlay_grapheme_control_list [list sgr $code]
} elseif {$code_endswith_m && [punk::ansi::codetype::has_sgr_leadingreset $code]} {
set o_codestack [list $code]
lappend overlay_grapheme_control_list [list sgr $code]
} elseif {$code_endswith_m && [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 {\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.
#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 - 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
} 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 ""]
if {[llength $o_codestack]} {
#set replay_codes_overlay [join $o_codestack ""]
set replay_codes_overlay [punk::ansi::codetype::sgr_merge_singles $o_codestack]
} else {
set replay_codes_overlay [list]
}
#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 unapplied_ansisplit [list ""] ;#pt code ... pt
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_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 ""]]
#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 {
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
#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 <lf> \x85 <lf> \b <bs> \r <cr> \v <vt> \t <tb> \x7f <del>] $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 {
"<lf>" {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]]
if {$idx == 0} {
#puts "---a <lf> 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_to_unapplied $overlay_grapheme_control_list $gci
break
} elseif {$overflow_idx != -1 && $idx == $overflow_idx} {
#linefeed after final column
#puts "---c <lf> 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_to_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_to_unapplied $overlay_grapheme_control_list $gci
break
} else {
incr cursor_row
set instruction lf_mid
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
}
}
}
"<cr>" {
#will we want/need to use raw <cr> for keypresses in terminal? (terminal with LNM in standard reset mode means enter=<cr> this is the usual config for terminals)
#So far we are assuming the caller has translated to <lf> 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 ;#?
}
"<bs>" {
#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_to_unapplied $overlay_grapheme_control_list $gci
set instruction backspace_at_start
break
}
}
}
"<del>" {
#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
}
"<vt>" {
#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_to_unapplied $overlay_grapheme_control_list $gci
set instruction vt
break
}
"<tb>" {
#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.
#insert the tab and the correct number of null columns for the tab expansion.
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 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]
#? 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 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.
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_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
break
}
} 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} {
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci-1]]
#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_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
} 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 [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} {
#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 existing_outchar [lindex $outcols $idx]
#JMN
if {$existing_outchar eq "\t"} {
#REVIEW
incr idx
incr cursor_column
#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 == 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 {
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 {
# 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 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 {$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 $existing_outcol_char]
}
if {$within_undercols} {
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}]"
}
}
}
}
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} {
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
} 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
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} {
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
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 {
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
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
}
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_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 ""]]
#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
}
}
#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
#e.g sixel
#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 {
#e.g sixel
#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 {
#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
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 [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
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_to_unapplied $overlay_grapheme_control_list $gci
set instruction up
#retain cursor_column
break
}
B {
#CUD - Cursor Down
#CSI n B
#Row move - down
lassign [split $param {;}] num modifierkey
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [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_to_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 [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_to_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 [lindex $overlay_grapheme_control_stacks $gci]]
incr cursor_column -$num
priv::render_to_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}]
#sgr_merge_list
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]]
#sgr_merge_singles ??
incr idx_over
priv::render_to_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 (codenorm:$codenorm)"
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 [lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction move
break
}
G {
#CHA - Cursor Horizontal Absolute (move to absolute column no)
#see also HPA - Horizontal Position Absolute (same functionality)
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)"
}
` {
#https://vt100.net/docs/vt510-rm/HPA.html
#docs don't mention that it defaults to one if $parm omitted - but it seems to do in practice
if {$param eq ""} {
set targetcol 1
} else {
set targetcol $param
if {![string is integer -strict $targetcol]} {
puts stderr "renderline HPA (Horizontal Position 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 HPA (Horizontal Position Absolute) error. Param '$param' > max: $max"
set targetcol $max
}
}
set idx [expr {($targetcol -1) + $opt_colstart -1}]
set cursor_column $targetcol
}
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 <param> 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 <param> 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 [lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
priv::render_to_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]"
#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 {
#ED 0 - clear from cursor to end of screen (including cursor position)
#Current-line part can be done here; remaining lines are handled by caller.
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols] && $idx < [llength $outcols]} {
priv::render_erasechar $idx [expr {[llength $outcols] - $idx}]
}
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction clear_to_end_display
break
}
1 {
#ED 1 - clear from start of screen to cursor
#Current-line part can be done here; previous lines are handled by caller.
set replay_codes_overlay [punk::ansi::codetype::sgr_merge [lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols] && $idx >= 0} {
set count [expr {$idx + 1}]
if {$count > [llength $outcols]} {
set count [llength $outcols]
}
if {$count > 0} {
priv::render_erasechar 0 $count
}
}
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction clear_to_start_display
break
}
2 {
#clear entire screen CSI 2J
#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 [lindex $overlay_grapheme_control_stacks $gci]]
incr idx_over
if {[llength $outcols]} {
priv::render_erasechar 0 [llength $outcols]
}
priv::render_to_unapplied $overlay_grapheme_control_list $gci
set instruction clear_and_move
break
}
3 {
#clear entire screen. As well as scrollback buffer if supported (unimplemented)
puts stderr "overtype::renderline ED 3 - clear entire screen and scrollback buffer if supported (unimplemented) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
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
if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete
if {![string is integer -strict $param] || $param < 0} {
puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set param 1
}
priv::render_to_unapplied $overlay_grapheme_control_list $gci
#The current line will be deleted by the calling function - along with more below if param > 1
#we clear the outcols so that the result for this line is empty.
ledit outcols 0 end
ledit understacks 0 end
ledit understacks_gx 0 end
#puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
#todo - rename insert_lines_below to affect_lines_below or something equally generic (use for multiple instructions)
set instruction [list delete_lines $param]
break
}
P {
#DCH - Delete Character(s)
#Deletes Pn characters from cursor position, shifts line left,
#and fills vacated rightmost cells with erased cells.
if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to delete
if {![string is integer -strict $param] || $param < 0} {
puts stderr "overtype::renderline DCH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set param 1
}
set orig_len [llength $outcols]
for {set di 0} {$di < $param} {incr di} {
priv::render_delchar $idx
}
#Maintain line width by padding erased cells at right edge.
set removed [expr {$orig_len - [llength $outcols]}]
for {set fi 0} {$fi < $removed} {incr fi} {
lappend outcols \u0000
lappend understacks [list $replay_codes_overlay]
lappend understacks_gx [list]
#review - should we be appending gx0state here? or just empty list?
#- presumably we should be appending gx0state from the end of the line - which may be different from current gx0state if there are codes in the line that change it - but we don't want to track those changes as we delete chars - so maybe we should be appending the gx0state from the end of the line before deletion started?
#lappend understacks_gx [list $gx0state]
}
#cursor position doesn't change.
}
@ {
#ICH - Insert Character(s)
#Inserts Pn blank characters at the cursor position, shifts line right,
#and fills vacated leftmost cells with erased cells.
#The characters shifted beyond the right margin are lost.
if {$param eq "" || $param eq "0"} {set param 1}; #param=number of chars to insert
if {![string is integer -strict $param] || $param < 1} {
puts stderr "overtype::renderline ICH bad param '$param' - assuming 1 [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set param 1
}
set orig_len [llength $outcols]
if {$overflow_idx != -1 && $param > [llength $outcols]} {
#since characters at rhs are lost, we can't insert more than the width.
set param $orig_len
}
set this_sgrstack [lindex $overlay_grapheme_control_stacks $gci]
set this_gxstack [lindex $overstacks_gx $idx_over]
#use space for inserted blanks; helper handles tab reflow
priv::render_insertgraphemes $idx [lrepeat $param " "] $this_sgrstack $this_gxstack
#Keep line width fixed unless expand-right mode is active.
if {$overflow_idx != -1} {
if {[llength $outcols] > $orig_len} {
#truncate
ledit outcols $orig_len end
ledit understacks $orig_len end
ledit understacks_gx $orig_len end
}
}
#cursor position doesn't change.
}
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
set margins_valid 1 ;#default assumption
#todo - validate margins. A valid scrolling region requires at least two lines.
if {$margin_top eq ""} {set margin_top 1}
if {$margin_bottom eq ""} {set margin_bottom $screen_rows}
if {![string is integer -strict $margin_top] || $margin_top < 1} {
puts stderr "DECSTBM invalid margin_top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set margins_valid 0
}
if {![string is integer -strict $margin_bottom] || $margin_bottom < 1} {
puts stderr "DECSTBM invalid margin_bottom '$margin_bottom' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set margins_valid 0
}
if {$margin_bottom - $margin_top < 1} {
puts stderr "DECSTBM invalid margins - bottom '$margin_bottom' must be greater than top '$margin_top' [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
set margins_valid 0
}
if {$margins_valid} {
#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_to_unapplied $overlay_grapheme_control_list $gci
set instruction [list decstbm $margin_top $margin_bottom]
break
} else {
puts stderr "overtype::renderline DECSTBM invalid margins - ignoring [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
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]
append cursor_saved_attributes [punk::ansi::codetype::sgr_merge $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 [lindex $overlay_grapheme_control_stacks $gci]]
set replay_codes_overlay ""
#}
#like priv::render_to_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code
incr idx_over
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""] ;#remove below if nothing added
foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] {
lassign $gc type item
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 ""
}
}
#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
}
"{" {
puts stderr "renderline warning - CSI..<leftcurly> - 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...'<rightcurly> - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]"
}
default {
puts stderr "renderline warning - CSI..<rightcurly> - 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=<mode>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
}
}
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"
}
}
}
}
}
| {
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 <param> $ |
#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} {
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"
}
}
}
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"
}
}
}
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_to_unapplied $overlay_grapheme_control_list $gci
set instruction reset
break
}
D {
#\x84
#index (IND) ESC D
#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_to_unapplied $overlay_grapheme_control_list $gci
set instruction down_scrolling
#retain cursor_column
break
}
E {
#\x85
#review - is behaviour different to lf?
#todo - possibly(?) same logic as <lf> handling above. i.e return instruction depends on where column_cursor is at the time we get NEL
#leave implementation until logic for <lf> 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 [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_to_unapplied $overlay_grapheme_control_list $gci
set instruction up ;#need instruction for screen to 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"} {
#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
#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<x> code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]"
}
}
}
7DCS - 8DCS {
#match 'DCS P1 ; P2 ; P3' (without spaces)
# where Ps1,P2,P3 are all optional and P1,P2 are single digit and P3 can *technically* be any positive integer but is usually ignored (commonly set to zero)
# Our regexp isn't precise as we will validate number of params and values after matching - but we will assume P3 should be small (review for micrometres - could be 4 digits? more?)
# (limit to 10 chars to avoid insane values?)
#https://github.com/hackerb9/vt340test/blob/main/physicalsixels.md
# P1P2P3q - "Protocol Selector"
# P1 - Pixel Aspect Ratio (Vertical:Horizontal)
# P2 - background control
# P3 - horizontal grid size (default units decipoints 1/720 inch - but theoretically controlled by ANSI SSU sequence)
# P1P2P3 commonly omitted - with subsequent <DQ>P4;P5;P6;P7 "Raster Attributes (DECGRA)" being used for:
# Aspect Ratio (P4,P5)
set sixelstart [tcl::string::range $codenorm 4 13]
set sixelmatch [regexp -all -inline {^((?:[0-9]*;){0,2}(?:[0-9]*))q} $sixelstart]
if {[llength $sixelmatch] == 2} {
#sixel
#note sixel data can have newlines before ST
set sixelparams [lindex $sixelmatch 1]
set params [split $sixelparams {;}]
set badsixelparams 0
if {[llength $params] > 3} {
set badsixelparams 1
}
lassign $params P1 P2 P3
if {[string length $P1] > 1 || [string length $P2] > 1 || [string length $P3] > 3} {
set badsixelparams 1
}
if {$badsixelparams} {
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING looks like sixel, but bad params. sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
} else {
#todo - move to punk::sixel library
#P1 - Pixel Aspect Ratio
# round(10/P1):1 if 2<= P1 <= 9) 2:1 otherwise
# omitted 2:1 (default)
# 0,1 2:1
# 2 5:1
# 3,4 3:1
# 5,6 2:1
# 7,8,9 1:1
switch -- $P1 {
"" - 0 - 1 {
#omitted (default)
set sixel_pixel_aspect "2:1"
}
2 {
set sixel_pixel_aspect "5:1"
}
3 - 4 {
set sixel_pixel_aspect "3:1"
}
5 - 6 {
set sixel_pixel_aspect "2:1"
}
7 - 8 - 9 {
set sixel_pixel_aspect "1:1"
}
default {
set sixel_pixel_aspect "invalid"
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING looks like sixel, but unrecognised P1 (pixel aspect ratio). sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
}
}
#P2 - background colour
# 0,2 (default) pixel positions specified as 0 are set to current bg colour
# 1 pixel positions specified as 0 remain at current colour
switch -- $P2 {
"" - 0 - 2 {
set sixel_background "current_background"
}
1 {
set sixel_background "transparent"
}
default {
set sixel_background "invalid"
puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING looks like sixel, but unrecognised P2 (background control). sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
}
}
#P3 horizontal grid size - ignored on VT300 - commonly set to zero
# ECMA-48 SSU (ESC [ Ps <sp> I)
# 0 - CHARACTER
# 1 - MILLIMETRE
# 2 - COMPUTER DECIPOINT 0.03528mm 1/720 of 25.4mm)
# 3 - DECIDIDOT 0.03759mm (10/266mm)
# 4 - MIL 0.0254mm (1/1000 of 25.4mm)
# 5 - BASIC MEASURING UNIT (BMU) 0.02117mm (1/1200 of 25.4mm)
# 6 - MICROMETRE 0.001mm
# 7 - PIXEL - the smallest increment that can be specified in a device
# 8 - DECIPOINT - 0.03514mm (35/996mm)
set sixel_horizontal_grid $P3
set sixel_ssu "decipoint" ;#todo?
#todo - look for and parse DECGRA introduced by double quote
puts stderr "overtype::renderline SIXEL aspect: $sixel_pixel_aspect bg: $sixel_background hgrid: $sixel_horizontal_grid. sixelstart [ansistring VIEW -lf 1 -vt 1 -nul 1 $sixelstart]"
#todo
}
} else {
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_to_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 && $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/
#<OSC> 99 ; metadata ; payload <terminator>
puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
104 {
#reset colour palette
#we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt
puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
priv::render_to_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
}
#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]"
#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]"
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]
#use stack_eq for depth 1 comparison without generating string rep.
if {![stack_eq $cstack $prevstack]} {
#possible SGR attribute change.
if {[llength $prevstack]} {
if {![llength $cstack]} {
#why is cstack empty?
#a) no ansi in underlay and we are at a position 2 after an overlay insertion.
# (position 1 after overlay insertion should already have had a reset inserted)
#b) no ansi in overlay and we are at an overlay insertion point.
#--------------
#review
#todo? consider testing next-char's understack when applying each overlay char in the main loop.
#if empty or has no leading reset - we need to add a leading reset at that point.
#--------------
#--------
#following statement is FALSE - (historical info). Doesn't seem to apply.
#This reset is important e.g testfile fruit.ans - we get overhang on rhs without it.
#append sgrleader \033\[m
#--------
##test
#set view_prev ""
#foreach ps $prevstack {
# append view_prev [ansistring VIEW -lf 1 -vt 1 -nul 1 $ps]
#}
#puts stderr "col $i, ch: $ch - cstack empty vs prevstack $view_prev"
} else {
#without this we get extra redundant codes in some places.
#e.g a continuous string of underlay that originally had \x1b\[31m red text,
#but then when an overlay char is inserted near the start, the following underlay char (insertion index +1) codestack had a reset added.
#All subsequent underlay chars in the same run of plaintext don't have the reset and so appear 'different' but are actually part of the same run.
#check if actually different. ie if current stack actually changes anything from previous stack when merged together.
set prevmerge [punk::ansi::codetype::sgr_merge $prevstack]
set currmerge [punk::ansi::codetype::sgr_merge $cstack]
set together [punk::ansi::codetype::sgr_merge [list $prevmerge $currmerge]]
if {$together ne $prevmerge} {
#stacks are different enough that we need to output something
#if {{[punk::ansi::codetype::has_sgr_leading_reset $currmerge]}} {
#}
append sgrleader $currmerge
}
}
} else {
if {[llength $cstack]} {
append sgrleader [punk::ansi::codetype::sgr_merge $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 sgrleader [punk::ansi::codetype::sgr_merge $cstack]
append overflow_right $sgrleader
append overflow_right $ch
} else {
append overflow_right $gxleader
append overflow_right $sgrleader
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
#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
}
}
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 {
#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 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"} {
#map all nulls including at tail to space
set this_char " "
#review
} 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?
#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 [llength $understacks]
} else {
set tail_idx [llength $undercols]
}
if {$tail_idx == [llength $undercols]} {
#we got to the end of the original underlay
#- so we want the full stack at the end of the original underlay ie including trailing codes which are not associated with any grapheme in the underlay
#but would be in effect for any text after the underlay.
#---------------------
#REVIEW - determine if last col was overwritten by overlay?
#how best to determine if last underlay column was overwritten by overlay?
#we could track in the main loop whether each underlay column was overwritten by overlay
#This seems like the best mechanism, because the overlay ANSI can include movement codes, so the underlay can be overwritten in any order.
#We should consider that just because the last grapheme was overwritten, that doesn't necessarily mean we should disregard the trailing codes
#perhaps trailing underlay codes are never overwritten unless the overlay extends beyond the end of the underlay - in which case we can just check if overlay extends beyond end of underlay to determine whether to include trailing underlay codes in replay or not.
#if overlay extends beyond end of underlay - we use the overlay stack at the end of the underlay as the replay codes, which won't include any trailing underlay codes.
#---------------------
if {[lindex $undermap end] eq ""} {
#there were trailing codes in the underlay with no grapheme - we want to include those in the replay as they would affect any text after the underlay
#we need to backtrack from the end of the underlay to find the last grapheme with codes, and merge those codes with any trailing codes in the underlay with no grapheme
set tailcodes [list] ;#build in reverse order.
foreach {pt code} [lreverse $undermap] {
if {$pt ne ""} {
break
}
lappend tailcodes $code
}
set tailcodes [lreverse $tailcodes]
#set tailcodes [lindex $undermap end-1]
set laststack [lindex $understacks $tail_idx-1]
lappend laststack {*}$tailcodes
set replay_codes [punk::ansi::codetype::sgr_merge $laststack] ;#stack at end of underlay including trailing codes
} else {
#last part of underlay was plain text with no trailing codes - we can just use the stack at the last grapheme of the underlay
set replay_codes [punk::ansi::codetype::sgr_merge [lindex $understacks $tail_idx-1]] ;#stack at end of underlay
}
} elseif {$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
set replay_codes [punk::ansi::codetype::sgr_merge [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]} {
#JULZ
#The caller is responsible for adding a reset at the end of returned lines depending on how they want to use it - so we don't add one here.
#<deprecated>
#append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column
#</deprecated>
#we only want to append the replay codes if they are different to those already in effect at the end of the rendered line.
if {$overflow_idx == -1} {
set tail_idx [llength $understacks]
} else {
set tail_idx [llength $undercols]
}
set laststack [lindex $understacks $tail_idx-1]
set laststackmerge [punk::ansi::codetype::sgr_merge $laststack]
#test1
#if {$replay_codes ne $laststackmerge} {
# append outstring $replay_codes
#}
#test2
if {$replay_codes_underlay ne $laststackmerge} {
append outstring $replay_codes_underlay
}
#review
#close off any open gx?
#probably not, this is akin to adding a reset to close off open SGR codes, which we specifically don't do.
#caller will need to close off any open gx at the end of the line if they want to, and provide appropriate replay codes for the next line if they want to maintain gx state across lines.
#we just need to make sure we provide all necessary info in the result dictionary.
#todo - tests and examples.
#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
#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}]
}
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] {*}{
} instruction $instruction {*}{
} stringlen [string length $outstring] {*}{
} overflow_right_column $overflow_right_column {*}{
} overflow_right $overflow_right {*}{
} unapplied $unapplied {*}{
} unapplied_list $unapplied_list {*}{
} unapplied_ansisplit $unapplied_ansisplit {*}{
} insert_mode $insert_mode {*}{
} autowrap_mode $autowrap_mode {*}[
# crm_mode displays similar to ansistring VIEW - review
] 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
#}
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.
# }
#}
#-info values 2,3,4 for view modes
if {$opt_returnextra & 3} {
set viewop VIEWCODES
} elseif {$opt_returnextra & 4} {
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 $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} {
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
}
#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|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-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 <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-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::renderline_transparent {args} {
foreach {under over} [lrange $args end-1 end] break
set argsflags [lrange $args 0 end-2]
set defaults [tcl::dict::create {*}{
-transparent 1
-exposed1 " "
-exposed2 " "
}]
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 <int>? ?-transparent [0|1|<regexp>]? ?-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} {
#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]
}
set dostrip 0
#set width [punk::char::ansifreestring_width $ch]
set width [punk::ansi::printing_length $ch $dostrip]
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]
}
set dostrip 0
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}]]
set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::ansi::printing_length $v $dostrip}]]
} else {
set num_le 0
#set width [punk::char::ansifreestring_width $textblock]
set width [punk::ansi::printing_length $textblock $dostrip]
}
#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 <data>]] 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} {
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
if {!$code_endswith_m} {
#don't even cache.
return 0
}
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
}
proc render_to_unapplied {overlay_grapheme_control_list gci} {
upvar idx_over idx_over
#-----------------------------------------
#review - this is a lot of copies of the same thing.
# ultimately we want to reduce expensive things like redundant grapheme-splits
# perhaps unapplied_tagged of some sort e.g - {g <grapheme> g <grapheme> code <ansi> pt <text>} ??
upvar unapplied unapplied
upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split
upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...?
#-----------------------------------------
upvar overstacks overstacks
upvar overstacks_gx overstacks_gx
upvar overlay_grapheme_control_stacks og_stacks
#set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]]
set unapplied ""
set unapplied_list [list]
set unapplied_ansisplit [list ""]
#append unapplied [join [lindex $overstacks $idx_over] ""]
#append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]]
#set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]]
set sgr_merged [punk::ansi::codetype::sgr_merge [lindex $og_stacks $gci]]
if {$sgr_merged ne ""} {
lappend unapplied_list $sgr_merged
lappend unapplied_ansisplit $sgr_merged ""
}
switch -- [lindex $overstacks_gx $idx_over] {
"gx0_on" {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
}
"gx0_off" {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] {
lassign $gc type item
#types g other sgr gx0
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 ""
}
}
}
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
#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]]
set sgr_merged [punk::ansi::codetype::sgr_merge [lindex $og_stacks $gci]]
if {$sgr_merged ne ""} {
lappend unapplied_list $sgr_merged
lappend unapplied_ansisplit $sgr_merged ""
}
switch -- [lindex $overstacks_gx $idx_over] {
"gx0_on" {
lappend unapplied_list "\x1b(0"
lappend unapplied_ansisplit "\x1b(0" ""
}
"gx0_off" {
lappend unapplied_list "\x1b(B"
lappend unapplied_ansisplit "\x1b(B" ""
}
}
foreach gc [lrange $overlay_grapheme_control_list $gci end] {
lassign $gc type item
#types g other sgr gx0
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 ""
}
}
}
if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} {
set unapplied_ansisplit [list]
}
set unapplied [join $unapplied_list ""]
}
proc render_delchar {i} {
#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} {
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?
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 {
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[set o {}] $start $end {*}[lrepeat $num \u0000]] ;#or space?
#DECECM ???
set ustacks [lreplace $ustacks[set ustacks {}] $start $end {*}[lrepeat $num [list $replay]]]
set gxstacks [lreplace $gxstacks[set 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 "\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
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]
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
#check if next ustacks entry has a reset.
#It will need one if it doesn't already have one because our inserted char should not affect the pre-existing ansi state of the underlay.
#we have just replaced an entry into the ustacks at position i but we are still at the same position - so the next entry is still at position i+1
if {[llength $sgrstack] && $i+1 < [llength $ustacks]} {
set next_ustack [lindex $ustacks $i+1]
#could be a reset or just empty - either way we need to add a reset if it's not already there
#(empty if underlay had no ansi)
#temporarily emit something to stderr
if {![llength $next_ustack]} {
#puts -nonewline stderr " next_ustack (empty) at position [expr {$i+1}] after replacing position $i with '$c' and sgrstack '[join $sgrstack ""]'\n"
lset ustacks $i+1 [list "\x1b\[m"]
} else {
#review - next_ustack is a list - has_sgr_leadingreset will not work as expected if called on whole next_ustack as a list.
#As the stack will need merging anyway - we can just prepend a reset without checking.
#REVIEW.
#puts -nonewline stderr "check next_ustack '$next_ustack' for reset at position [expr {$i+1}] after replacing position $i with '$c' and sgrstack '[join $sgrstack ""]'\n"
#set next_ustack [linsert $next_ustack 0 [a+ reset]]
ledit next_ustack -1 -1 "\x1b\[m"
lset ustacks $i+1 $next_ustack
}
}
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]
#JMN insert via ledit
#ledit o $i $i-1 $c
ledit o $i -1 $c
} else {
lappend o $c
}
if {$i < [llength $ustacks]} {
#set ustacks [linsert $ustacks $i $sgrstack]
#set gxstacks [linsert $gxstacks $i $gx0stack]
#insert via ledit
#ledit ustacks $i $i-1 $sgrstack
ledit ustacks $i -1 $sgrstack
#ledit gxstacks $i $i-1 $gx0stack
ledit gxstacks $i -1 $gx0stack
} else {
lappend ustacks $sgrstack
lappend gxstacks $gx0stack
}
}
}
#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]
}
}
}
# -- --- --- --- --- --- --- --- --- --- ---
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 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]