From 4f4498e9a431a77b024f9c1dd59de92e95e081c5 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 30 Mar 2024 00:18:55 +1100 Subject: [PATCH] more telnet,scriptwrap fixes --- src/bootsupport/modules/punk/ansi-0.1.1.tm | 21 +----- src/bootsupport/modules/punk/console-0.1.1.tm | 33 ++++---- src/bootsupport/modules/punk/lib-0.1.1.tm | 48 ++++++++++++ .../punk/mix/commandset/project-0.1.0.tm | 2 + .../punk/mix/commandset/scriptwrap-0.1.0.tm | 29 +++++-- src/modules/punk/basictelnet-999999.0a1.0.tm | 75 +++++++++++++++---- .../mix/commandset/scriptwrap-999999.0a1.0.tm | 4 +- src/modules/textblock-999999.0a1.0.tm | 17 +++-- src/vendormodules/overtype-1.6.0.tm | 70 ++++++++++++++++- 9 files changed, 236 insertions(+), 63 deletions(-) diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 3d15a301..137dca29 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -473,25 +473,6 @@ namespace eval punk::ansi { $obj destroy return $result } - proc is_utf8_char {char} { - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - } $char - } - proc get_utf8 {text} { - regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) - \A ( - [\x00-\x7F] | # Single-byte chars (ASCII range) - [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) - [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) - [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) - ) + - } $text completeChars - return $completeChars - } proc example {} { #todo - review dependency on punk::repo ? package require textblock @@ -2355,7 +2336,7 @@ namespace eval punk::ansi::ta { # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::ansi::class { #assertions specifically for punk::ansi::class namespace - if {![llength [info commands ::punk::assertion::assert]]} { + if {![llength [info commands ::punk::ansi::class::assert]]} { namespace import ::punk::assertion::assert punk::assertion::active 1 } diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 058d67ee..af8129b2 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -551,7 +551,20 @@ namespace eval punk::console { fileevent $input readable {} set input_state [fconfigure $input] + #todo - make timeout configurable? + set waitvarname "::punk::console::ansi_response_wait($callid)" + #500ms is generally plenty for a terminal to respond.. but not in some cases. e.g event loop busy with stdin keypress?? review + set timeoutid($callid) [after 2000 [list set $waitvarname timedout]] + #JMN + # - stderr vs stdout + #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions + #(presumably race conditions as to when data hits console?) + #review - experiment changing this and calling functions to stderr and see if it works + #review - Are there disadvantages to using stdout vs stderr? + + #puts stdout "sending console request [ansistring VIEW $query]" + puts -nonewline $output $query;flush $output #todo - test and save rawstate so we don't disableRaw if console was already raw if {!$::punk::console::is_raw} { @@ -564,25 +577,19 @@ namespace eval punk::console { # #in handler - its used for a boolean match (capturing aspect not used) set clock($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on - fileevent $input readable [list $this_handler $input $callid $capturingendregex] - # - stderr vs stdout - #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions - #(presumably race conditions as to when data hits console?) - #review - experiment changing this and calling functions to stderr and see if it works - #review - Are there disadvantages to using stdout vs stderr? - - #puts stdout "sending console request [ansistring VIEW $query]" - puts -nonewline $output $query;flush $output + #first shot without using filevent, call the stdin reader directly - maybe it's there already + #This can be significantly faster than setting up a fileevent (2024 e.g 1.5ms vs 65ms) + $this_handler $input $callid $capturingendregex + if {$waitvar($callid) ne "ok"} { + fileevent $input readable [list $this_handler $input $callid $capturingendregex] + } + #JMN #response from terminal #e.g for cursor position \033\[46;1R - #todo - make timeout configurable? - set waitvarname "::punk::console::ansi_response_wait($callid)" - #500ms is generally plenty for a terminal to respond.. but not in some cases. e.g event loop busy with stdin keypress?? review - set timeoutid($callid) [after 2000 [list set $waitvarname timedout]] if {[set waitvar($callid)] eq ""} { vwait ::punk::console::ansi_response_wait($callid) diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index 616acef6..f9c4c1c4 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -302,6 +302,54 @@ namespace eval punk::lib { #[para]see [uri https://wiki.tcl-lang.org/page/K] #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } proc hex2dec {args} { #*** !doctools #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 1ebb6b4f..58aa079a 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -168,6 +168,8 @@ namespace eval punk::mix::commandset::project { # -- --- --- --- --- --- --- --- --- --- --- --- --- + #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache + # set fossil_prog [auto_execok fossil] if {![string length $fossil_prog]} { puts stderr "The fossil program was not found. A fossil executable is required to use most deck features." diff --git a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index 08f6aa07..2ae511a9 100644 --- a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -919,15 +919,28 @@ namespace eval punk::mix::commandset::scriptwrap { } else { set templatename $opt_template } + set templatename_root [file rootname [file tail $templatename]] + + #determine name of file on disk based on whether templatename is prefixed with vendor. + set templatename_vendor "" + set templatename_fileroot $templatename_root + if {[llength [split $templatename_root .]] > 1} { + set tparts [split $templatename_root .] + set templatename_vendor [lindex $tparts 0] + set templatename_fileroot [join [lrange $tparts 1 end] .] + } - + #assertion: templatename_fileroot is the base of the filname without the vendor and first dot set template_base_dict [punk::mix::base::lib::get_template_basefolders] set tpldirs [list] dict for {tdir tsourceinfo} $template_base_dict { - if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { + set vendor [dict get $tsourceinfo vendor] + if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { + lappend tpldirs $tdir + } elseif {[file exists $tdir/utility/scriptappwrappers/${templatename_fileroot}[file extension $templatename]]} { lappend tpldirs $tdir - } + } } if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { @@ -942,9 +955,13 @@ namespace eval punk::mix::commandset::scriptwrap { #last pkg with templates cap which was loaded has highest precedence set wrapper_template "" foreach tdir [lreverse $tpldirs] { - set ftest [file join $tdir utility scriptappwrappers $templatename] - if {[file exists $ftest]} { - set wrapper_template $ftest + set ftest1 [file join $tdir utility scriptappwrappers $templatename] + set ftest2 [file join $tdir utility scriptappwrappers $templatename_fileroot[file extension $templatename]] + if {[file exists $ftest1]} { + set wrapper_template $ftest1 + break + } elseif {[file exists $ftest2]} { + set wrapper_template $ftest2 break } } diff --git a/src/modules/punk/basictelnet-999999.0a1.0.tm b/src/modules/punk/basictelnet-999999.0a1.0.tm index 0093f7ae..2f9d40a5 100644 --- a/src/modules/punk/basictelnet-999999.0a1.0.tm +++ b/src/modules/punk/basictelnet-999999.0a1.0.tm @@ -239,7 +239,7 @@ namespace eval punk::basictelnet { #define our positive responses here for those that we will do variable respond_will_do set respond_will_do [list] - lappend respond_will_do 0 ;#binary + #lappend respond_will_do 0 ;#binary lappend respond_will_do 1 ;#echo lappend respond_will_do 3 ;#suppress go-ahead lappend respond_will_do 5 ;#status - by agreeing to this we should be able to read unsolicited "IAC SB STATUS IS ... IAC SE" reports and compare to our perception of state. (and do something if mismatches?) @@ -248,7 +248,7 @@ namespace eval punk::basictelnet { #passively enabled client features - requests for our own behaviours we will respond positively variable respond_do_will set respond_do_will [list] - lappend respond_do_will 0 ;#binary + #lappend respond_do_will 0 ;#binary lappend respond_do_will 3 ;#Suppress go-ahead lappend respond_do_will 5 ;#status - by agreeing to this - we need to handle the subnegotiation "IAC SB STATUS SEND IAC SE" and respond with "IAC SB STATUS IS ... IAC SE" lappend respond_do_will 24 ;#terminal-type @@ -333,11 +333,13 @@ namespace eval punk::basictelnet { incr writing_debug_frame #set existing_handler [fileevent stdin readable] + set RST "\x1b\[m" - set infoframe [textblock::frame -width 80 -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug[a]" $info] - set w [textblock::width $infoframe] - set spacepatch [textblock::block $w 4 " "] - puts -nonewline [punk::ansi::cursor_off] + set w 80 + set infoframe [textblock::frame -width $w -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug$RST" $info] + #set w [textblock::width $infoframe] + set spacepatch [textblock::block $w 4 "$RST "] + #puts -nonewline [punk::ansi::cursor_off] #use non cursorsave version - slower - but less likely to interfere with cursor operations in data set existing_input_handler [fileevent $inputchannel readable] ;#stdin @@ -352,7 +354,7 @@ namespace eval punk::basictelnet { #punk::console::move_emitblock_return 6 90 $spacepatch\n$infoframe punk::console::move_emitblock_return 6 90 $spacepatch punk::console::move_emitblock_return 10 90 $infoframe - puts -nonewline stdout [punk::ansi::cursor_on] + #puts -nonewline stdout [punk::ansi::cursor_on] ;#Enabling cursor should take account of whether it was enabled before - we don't have that info currently! review flush stdout } errM]} { puts stderr "debug_frame error: $errM" @@ -492,6 +494,7 @@ namespace eval punk::basictelnet { #as a byte oriented supposedly ascii-by-default protocol - we shouldn't expect to get utf-8 without having negotiated it - but it looks suspiciously like this is the sort of thing that happens (2024) review? Examples? mapscii.me 1984.ws? Test. #randomly chosen chunk boundaries - whether due to size or a combination of network speed and event scheduling can mean we get some utf8 characters split too. + set last_unprocessed $fromserver_unprocessed set data $fromserver_unprocessed set fromserver_unprocessed "" append data [read $sock $chunksize] @@ -529,11 +532,12 @@ namespace eval punk::basictelnet { #mini debug buffer for each fromServer call - render using add_debug each loop set debug_info "" - append debug_info "------raw data [string length $data]------" \n - append debug_info [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom utf-8 $data]] \n + append debug_info "------raw data [string length $data]---prev unprocessed:[string length $last_unprocessed]---" \n + #append debug_info [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom utf-8 $data]] \n + set append debug_info "------------------------------------------" \n - while {[string length $data]} { + if {[string length $data]} { #puts "1----------------------------------" #puts [ansistring VIEW -lf 1 -vt 1 $data] @@ -558,7 +562,8 @@ namespace eval punk::basictelnet { if {$post_IAC_byte < "\xef"} { #?? #write \xf0$post_IAC_byte ;#from wiki code. purpose not understood. - set data [string range $data $idx end] + puts stderr "unexpected - byte less than EF following IAC" + set data [string range $data $idx-1 end] } elseif {$post_IAC_byte == "\xff"} { #write \xf0 ;#?? This came from wiki code - intention unclear.. latin small letter Eth #RFC indicates double up of \xff is treated as literal @@ -630,8 +635,24 @@ namespace eval punk::basictelnet { set plen [string length $prefix] set tail [string range $data $plen end] - puts -nonewline stdout "[encoding convertfrom utf-8 $prefix]" - set fromserver_unprocessed $tail + set ansisplits [list] + if {[string length $tail]} { + set fromserver_unprocessed $tail + puts -nonewline stdout "[encoding convertfrom utf-8 $prefix]" + } else { + set fromserver_unprocessed "" + #look for incomplete ansi sequences + #REVIEW - encoding ? + set ansisplits [punk::ansi::ta::split_codes_single $prefix] + set last_pt [lindex $ansisplits end] ;#last part is supposed to be plaintext - if it looks like it contains a partial ansi - throw it to fromserver_unprocessed for next fromServer call + if {[string first "\x1b" $last_pt] >= 0} { + set complete [join [lrange $ansisplits 0 end-1] ""] + puts -nonewline stdout "[encoding convertfrom utf-8 $complete]" + set fromserver_unprocessed $last_pt + } else { + puts -nonewline stdout "[encoding convertfrom utf-8 $prefix]" + } + } flush stdout set data "" @@ -639,6 +660,34 @@ namespace eval punk::basictelnet { punk::basictelnet::add_debug $debug_info stdin $sock set debug_info "" + #add_debug has potentially written to another part of the screen with different SGR colour/background etc + #ie - by interrupting the telnet data with our own output, we lose SGR context when returning to normal output. + variable debug + if {$debug} { + if {![llength $ansisplits]} { + set ansisplits [punk::ansi::ta::split_codes_single $prefix] + } + #we haven't been tracking the ansicode stack - for now we'll just replay the last set of SGR codes received in this chunk - may not always work! + #the effect we generally get by not doing these replays are unstyled characters in the output - presumably whenever we have jumped to debug output + #todo - consider impact of full tracking of ansi SGR stack on stream.. (only when in debug?) + set sgrstack [list] + foreach {pt ansicode} $ansisplits { + if {$ansicode ne ""} { + if {[punk::ansi::codetype::is_sgr $ansicode]} { + lappend sgrstack $ansicode + } + } + } + if {[llength $sgrstack]} { + #replay the SGR stack (only goes back within current chunk - often all that's needed - but not ideal) + puts -nonewline stdout [punk::ansi::codetype::sgr_merge_list {*}$sgrstack] + flush stdout + } + } + + + + #after idle [list fileevent $sock readable [list [namespace current]::fromServer $sock]] if {[string length $fromserver_unprocessed]} { #review - by throwing to another loop without waiting for readable event - we could spin on same data...? diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index 7c27f95e..463939cd 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -938,7 +938,7 @@ namespace eval punk::mix::commandset::scriptwrap { set vendor [dict get $tsourceinfo vendor] if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { lappend tpldirs $tdir - } elseif {[file exists $tdir/utility/scriptappwrappers/$templatename_fileroot.[file extension $templatename]]} { + } elseif {[file exists $tdir/utility/scriptappwrappers/${templatename_fileroot}[file extension $templatename]]} { lappend tpldirs $tdir } } @@ -956,7 +956,7 @@ namespace eval punk::mix::commandset::scriptwrap { set wrapper_template "" foreach tdir [lreverse $tpldirs] { set ftest1 [file join $tdir utility scriptappwrappers $templatename] - set ftest2 [file join $tdir utility scriptappwrappers $templatename_fileroot.[file extension $templatename]] + set ftest2 [file join $tdir utility scriptappwrappers $templatename_fileroot[file extension $templatename]] if {[file exists $ftest1]} { set wrapper_template $ftest1 break diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index ae8d4ea9..492000d1 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -97,25 +97,32 @@ namespace eval textblock { set chars [concat [punk::range 1 9] A B C D E F] set charsubset [lrange $chars 0 $size-1] - set c [::join $charsubset \n] set RST [a] if {"rainbow" in $colour} { + #column first - colour change each column + set c [::join $charsubset \n] set clist [list] for {set i 0} {$i <$size} {incr i} { set colour2 [string map [list rainbow [lindex $rainbow_list $i]] $colour] set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } + return [textblock::join {*}$clist] } else { - set cc $c + #row first - + set rows [list] + foreach ch $charsubset { + lappend rows [string repeat $ch $size] + } + set block [::join $rows \n] if {$colour ne ""} { - set cc [a+ {*}$colour]$c$RST + set block [a+ {*}$colour]$block$RST } - set clist [lrepeat $size $cc] + return $block } - textblock::join {*}$clist } interp alias {} testblock {} textblock::testblock diff --git a/src/vendormodules/overtype-1.6.0.tm b/src/vendormodules/overtype-1.6.0.tm index 877b398b..f5bdf82b 100644 --- a/src/vendormodules/overtype-1.6.0.tm +++ b/src/vendormodules/overtype-1.6.0.tm @@ -1564,7 +1564,8 @@ proc overtype::renderline {args} { #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 - if {[$width == 0]} { + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { if {$grapheme eq "\x1b"} { set gvis [ansistring VIEW $grapheme] set grapheme $gvis @@ -1604,7 +1605,14 @@ proc overtype::renderline {args} { switch -- $leadernorm { 7CSI - 8CSI { - if {[string index $code end] eq "m"} { + #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 {[string index $c1c2 0] eq "\x1b"} { + set maybemouse [string index $code 2] + } + + if {$maybemouse ne "<" && [string index $code end] eq "m"} { if {[punk::ansi::codetype::is_sgr_reset $code]} { set u_codestack [list "\x1b\[m"] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { @@ -2239,18 +2247,24 @@ proc overtype::renderline {args} { set c1 [string index $code 0] - set c1c2 [string range $code 0 1] + set c1c2c3 [string range $code 0 2] #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} set leadernorm [string range [string map [list\ + \x1b\[< 1006\ \x1b\[ 7CSI\ \x9b 8CSI\ \x1b\] 7OSC\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars #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 [string cat $leadernorm [string range $code 3 end]] + } 7CSI - 7OSC { set codenorm [string cat $leadernorm [string range $code 2 end]] } @@ -2268,6 +2282,19 @@ proc overtype::renderline {args} { #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 -- [string index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } {7CSI} - {8CSI} { set param [string range $codenorm 4 end-1] #puts stdout "--> CSI [string index $leadernorm 0] bit param:$param" @@ -2484,6 +2511,13 @@ proc overtype::renderline {args} { break } + X { + puts stderr "X - $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. + } r { #$re_decstbm #https://www.vt100.net/docs/vt510-rm/DECSTBM.html @@ -3161,6 +3195,34 @@ namespace eval overtype::priv { } } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. + if {![string is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } #is actually addgrapheme? proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { upvar outcols o