Browse Source

more telnet,scriptwrap fixes

master
Julian Noble 8 months ago
parent
commit
4f4498e9a4
  1. 21
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  2. 33
      src/bootsupport/modules/punk/console-0.1.1.tm
  3. 48
      src/bootsupport/modules/punk/lib-0.1.1.tm
  4. 2
      src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  5. 23
      src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm
  6. 73
      src/modules/punk/basictelnet-999999.0a1.0.tm
  7. 4
      src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm
  8. 17
      src/modules/textblock-999999.0a1.0.tm
  9. 70
      src/vendormodules/overtype-1.6.0.tm

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

@ -473,25 +473,6 @@ namespace eval punk::ansi {
$obj destroy $obj destroy
return $result 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 {} { proc example {} {
#todo - review dependency on punk::repo ? #todo - review dependency on punk::repo ?
package require textblock package require textblock
@ -2355,7 +2336,7 @@ namespace eval punk::ansi::ta {
# -- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- ---
namespace eval punk::ansi::class { namespace eval punk::ansi::class {
#assertions specifically for punk::ansi::class namespace #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 namespace import ::punk::assertion::assert
punk::assertion::active 1 punk::assertion::active 1
} }

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

@ -551,7 +551,20 @@ namespace eval punk::console {
fileevent $input readable {} fileevent $input readable {}
set input_state [fconfigure $input] 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 #todo - test and save rawstate so we don't disableRaw if console was already raw
if {!$::punk::console::is_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) #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 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 #first shot without using filevent, call the stdin reader directly - maybe it's there already
#It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions #This can be significantly faster than setting up a fileevent (2024 e.g 1.5ms vs 65ms)
#(presumably race conditions as to when data hits console?) $this_handler $input $callid $capturingendregex
#review - experiment changing this and calling functions to stderr and see if it works if {$waitvar($callid) ne "ok"} {
#review - Are there disadvantages to using stdout vs stderr? fileevent $input readable [list $this_handler $input $callid $capturingendregex]
}
#puts stdout "sending console request [ansistring VIEW $query]"
puts -nonewline $output $query;flush $output
#JMN
#response from terminal #response from terminal
#e.g for cursor position \033\[46;1R #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 ""} { if {[set waitvar($callid)] eq ""} {
vwait ::punk::console::ansi_response_wait($callid) vwait ::punk::console::ansi_response_wait($callid)

48
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]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. #[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} { proc hex2dec {args} {
#*** !doctools #*** !doctools
#[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]]

2
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] set fossil_prog [auto_execok fossil]
if {![string length $fossil_prog]} { if {![string length $fossil_prog]} {
puts stderr "The fossil program was not found. A fossil executable is required to use most deck features." puts stderr "The fossil program was not found. A fossil executable is required to use most deck features."

23
src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm

@ -919,14 +919,27 @@ namespace eval punk::mix::commandset::scriptwrap {
} else { } else {
set templatename $opt_template 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 template_base_dict [punk::mix::base::lib::get_template_basefolders]
set tpldirs [list] set tpldirs [list]
dict for {tdir tsourceinfo} $template_base_dict { dict for {tdir tsourceinfo} $template_base_dict {
set vendor [dict get $tsourceinfo vendor]
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { if {[file exists $tdir/utility/scriptappwrappers/$templatename]} {
lappend tpldirs $tdir lappend tpldirs $tdir
} elseif {[file exists $tdir/utility/scriptappwrappers/${templatename_fileroot}[file extension $templatename]]} {
lappend tpldirs $tdir
} }
} }
@ -942,9 +955,13 @@ namespace eval punk::mix::commandset::scriptwrap {
#last pkg with templates cap which was loaded has highest precedence #last pkg with templates cap which was loaded has highest precedence
set wrapper_template "" set wrapper_template ""
foreach tdir [lreverse $tpldirs] { foreach tdir [lreverse $tpldirs] {
set ftest [file join $tdir utility scriptappwrappers $templatename] set ftest1 [file join $tdir utility scriptappwrappers $templatename]
if {[file exists $ftest]} { set ftest2 [file join $tdir utility scriptappwrappers $templatename_fileroot[file extension $templatename]]
set wrapper_template $ftest if {[file exists $ftest1]} {
set wrapper_template $ftest1
break
} elseif {[file exists $ftest2]} {
set wrapper_template $ftest2
break break
} }
} }

73
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 #define our positive responses here for those that we will do
variable respond_will_do variable respond_will_do
set respond_will_do [list] 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 1 ;#echo
lappend respond_will_do 3 ;#suppress go-ahead 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?) 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 #passively enabled client features - requests for our own behaviours we will respond positively
variable respond_do_will variable respond_do_will
set respond_do_will [list] 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 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 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 lappend respond_do_will 24 ;#terminal-type
@ -333,11 +333,13 @@ namespace eval punk::basictelnet {
incr writing_debug_frame incr writing_debug_frame
#set existing_handler [fileevent stdin readable] #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 80
set w [textblock::width $infoframe] set infoframe [textblock::frame -width $w -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug$RST" $info]
set spacepatch [textblock::block $w 4 " "] #set w [textblock::width $infoframe]
puts -nonewline [punk::ansi::cursor_off] 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 #use non cursorsave version - slower - but less likely to interfere with cursor operations in data
set existing_input_handler [fileevent $inputchannel readable] ;#stdin 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\n$infoframe
punk::console::move_emitblock_return 6 90 $spacepatch punk::console::move_emitblock_return 6 90 $spacepatch
punk::console::move_emitblock_return 10 90 $infoframe 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 flush stdout
} errM]} { } errM]} {
puts stderr "debug_frame error: $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. #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. #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 data $fromserver_unprocessed
set fromserver_unprocessed "" set fromserver_unprocessed ""
append data [read $sock $chunksize] 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 #mini debug buffer for each fromServer call - render using add_debug each loop
set debug_info "" set debug_info ""
append debug_info "------raw data [string length $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 #append debug_info [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom utf-8 $data]] \n
set
append debug_info "------------------------------------------" \n append debug_info "------------------------------------------" \n
while {[string length $data]} { if {[string length $data]} {
#puts "1----------------------------------" #puts "1----------------------------------"
#puts [ansistring VIEW -lf 1 -vt 1 $data] #puts [ansistring VIEW -lf 1 -vt 1 $data]
@ -558,7 +562,8 @@ namespace eval punk::basictelnet {
if {$post_IAC_byte < "\xef"} { if {$post_IAC_byte < "\xef"} {
#?? #??
#write \xf0$post_IAC_byte ;#from wiki code. purpose not understood. #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"} { } elseif {$post_IAC_byte == "\xff"} {
#write \xf0 ;#?? This came from wiki code - intention unclear.. latin small letter Eth #write \xf0 ;#?? This came from wiki code - intention unclear.. latin small letter Eth
#RFC indicates double up of \xff is treated as literal #RFC indicates double up of \xff is treated as literal
@ -630,8 +635,24 @@ namespace eval punk::basictelnet {
set plen [string length $prefix] set plen [string length $prefix]
set tail [string range $data $plen end] set tail [string range $data $plen end]
puts -nonewline stdout "[encoding convertfrom utf-8 $prefix]" set ansisplits [list]
if {[string length $tail]} {
set fromserver_unprocessed $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 flush stdout
set data "" set data ""
@ -639,6 +660,34 @@ namespace eval punk::basictelnet {
punk::basictelnet::add_debug $debug_info stdin $sock punk::basictelnet::add_debug $debug_info stdin $sock
set debug_info "" 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]] #after idle [list fileevent $sock readable [list [namespace current]::fromServer $sock]]
if {[string length $fromserver_unprocessed]} { if {[string length $fromserver_unprocessed]} {
#review - by throwing to another loop without waiting for readable event - we could spin on same data...? #review - by throwing to another loop without waiting for readable event - we could spin on same data...?

4
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] set vendor [dict get $tsourceinfo vendor]
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { if {[file exists $tdir/utility/scriptappwrappers/$templatename]} {
lappend tpldirs $tdir 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 lappend tpldirs $tdir
} }
} }
@ -956,7 +956,7 @@ namespace eval punk::mix::commandset::scriptwrap {
set wrapper_template "" set wrapper_template ""
foreach tdir [lreverse $tpldirs] { foreach tdir [lreverse $tpldirs] {
set ftest1 [file join $tdir utility scriptappwrappers $templatename] 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]} { if {[file exists $ftest1]} {
set wrapper_template $ftest1 set wrapper_template $ftest1
break break

17
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 chars [concat [punk::range 1 9] A B C D E F]
set charsubset [lrange $chars 0 $size-1] set charsubset [lrange $chars 0 $size-1]
set c [::join $charsubset \n]
set RST [a] set RST [a]
if {"rainbow" in $colour} { if {"rainbow" in $colour} {
#column first - colour change each column
set c [::join $charsubset \n]
set clist [list] set clist [list]
for {set i 0} {$i <$size} {incr i} { for {set i 0} {$i <$size} {incr i} {
set colour2 [string map [list rainbow [lindex $rainbow_list $i]] $colour] set colour2 [string map [list rainbow [lindex $rainbow_list $i]] $colour]
set ansi [a+ {*}$colour2] set ansi [a+ {*}$colour2]
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST lappend clist ${ansicode}$c$RST
} }
return [textblock::join {*}$clist]
} else { } 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 ""} { 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 interp alias {} testblock {} textblock::testblock

70
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 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 #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 #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"} { if {$grapheme eq "\x1b"} {
set gvis [ansistring VIEW $grapheme] set gvis [ansistring VIEW $grapheme]
set grapheme $gvis set grapheme $gvis
@ -1604,7 +1605,14 @@ proc overtype::renderline {args} {
switch -- $leadernorm { switch -- $leadernorm {
7CSI - 8CSI { 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]} { if {[punk::ansi::codetype::is_sgr_reset $code]} {
set u_codestack [list "\x1b\[m"] set u_codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
@ -2239,18 +2247,24 @@ proc overtype::renderline {args} {
set c1 [string index $code 0] 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 re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)}
set leadernorm [string range [string map [list\ set leadernorm [string range [string map [list\
\x1b\[< 1006\
\x1b\[ 7CSI\ \x1b\[ 7CSI\
\x9b 8CSI\ \x9b 8CSI\
\x1b\] 7OSC\ \x1b\] 7OSC\
\x9d 8OSC\ \x9d 8OSC\
\x1b 7ESC\ \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 #we leave the tail of the code unmapped for now
switch -- $leadernorm { 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 { 7CSI - 7OSC {
set codenorm [string cat $leadernorm [string range $code 2 end]] 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. #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 { switch -- $leadernorm {
1006 {
#TODO
#
switch -- [string index $codenorm end] {
M {
puts stderr "mousedown $codenorm"
}
m {
puts stderr "mouseup $codenorm"
}
}
}
{7CSI} - {8CSI} { {7CSI} - {8CSI} {
set param [string range $codenorm 4 end-1] set param [string range $codenorm 4 end-1]
#puts stdout "--> CSI [string index $leadernorm 0] bit param:$param" #puts stdout "--> CSI [string index $leadernorm 0] bit param:$param"
@ -2484,6 +2511,13 @@ proc overtype::renderline {args} {
break 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 { r {
#$re_decstbm #$re_decstbm
#https://www.vt100.net/docs/vt510-rm/DECSTBM.html #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? #is actually addgrapheme?
proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} {
upvar outcols o upvar outcols o

Loading…
Cancel
Save