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.
2668 lines
119 KiB
2668 lines
119 KiB
# -*- 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) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::console 0.1.1 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::console 0 0.1.1] |
|
#[copyright "2024"] |
|
#[titledesc {punk console}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {punk console}] [comment {-- Description at end of page heading --}] |
|
#[require punk::console] |
|
#[keywords module console terminal] |
|
#[description] |
|
#[para] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::console |
|
#[subsection Concepts] |
|
#[para] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::console |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require Thread ;#tsv required to sync is_raw |
|
package require punk::ansi |
|
package require punk::args |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6-}] |
|
#[item] [package {Thread}] |
|
#[item] [package {punk::ansi}] |
|
#[item] [package {punk::args}] |
|
|
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
|
|
|
|
#if {"windows" eq $::tcl_platform(platform)} { |
|
# #package require zzzload |
|
# #zzzload::pkg_require twapi |
|
#} |
|
|
|
#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt |
|
#https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::console { |
|
#*** !doctools |
|
#[subsection {Namespace punk::console}] |
|
#[para] |
|
|
|
#*** !doctools |
|
#[list_begin definitions] |
|
|
|
variable PUNKARGS |
|
|
|
variable tabwidth 8 ;#default only - will attempt to detect and set to that configured in terminal |
|
#Note that windows terminal cooked mode seems to use 8 for interactive use even if set differently |
|
#e.g typing tab characters may still be echoed 8-spaced while writing to stdout my obey the terminal's tab stops. |
|
variable has_twapi 0 |
|
variable previous_stty_state_stdin "" |
|
variable previous_stty_state_stdout "" |
|
variable previous_stty_state_stderr "" |
|
|
|
#variable is_raw 0 |
|
if {![tsv::exists console is_raw]} { |
|
tsv::set console is_raw 0 |
|
} |
|
|
|
variable input_chunks_waiting |
|
if {![info exists input_chunks_waiting(stdin)]} { |
|
set input_chunks_waiting(stdin) [list] |
|
} |
|
variable ansi_response_chunk ;#array keyed on callid |
|
variable ansi_response_wait ;#array keyed on callid |
|
array set ansi_response_wait {} |
|
variable ansi_response_queue [list];#list of callids |
|
variable ansi_response_queuedata ;#dict keyed on callid - with function params |
|
|
|
# -- |
|
variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. |
|
#-1 still evaluates to true - as the modern assumption for ansi availability is true |
|
#only false if ansi_available has been set 0 by test_can_ansi |
|
#support ansistrip for legacy windows terminals |
|
# -- |
|
|
|
variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset |
|
|
|
|
|
|
|
#punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace |
|
#directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. |
|
#punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence. |
|
#punk::console::local functions are used by punk::console commands when there is no ansi equivalent |
|
#ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console |
|
# punk::local commands may be more performant in some circumstances where console is directly attached, but it shouldn't be assumed. e.g ansi::titleset outperforms local::titleset on windows with twapi. |
|
|
|
namespace eval local { |
|
#non-ansi terminal/console control functions |
|
#e.g external utils system API's. |
|
namespace export * |
|
} |
|
|
|
if {"windows" eq $::tcl_platform(platform)} { |
|
#accept args for all dummy/load functions so we don't have to match/update argument signatures here |
|
|
|
proc enableAnsi {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableAnsi {*}$args |
|
} |
|
#review what raw mode means with regard to a specific channel vs terminal as a whole |
|
proc enableRaw {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableRaw {*}$args |
|
} |
|
proc disableRaw {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall disableRaw {*}$args |
|
} |
|
proc enableVirtualTerminal {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableVirtualTerminal {*}$args |
|
} |
|
proc disableVirtualTerminal {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall disableVirtualTerminal {*}$args |
|
} |
|
set funcs [list disableAnsi enableProcessedInput disableProcessedInput] |
|
foreach f $funcs { |
|
proc $f {args} [string map [list %f% $f] { |
|
set mybody [info body %f%] |
|
internal::define_windows_procs |
|
set newbody [info body %f%] |
|
if {$newbody ne $mybody} { |
|
tailcall %f% {*}$args |
|
} else { |
|
#error vs noop? |
|
puts stderr "Unable to set implementation for %f% - check twapi?" |
|
} |
|
}] |
|
} |
|
|
|
} else { |
|
proc enableAnsi {} { |
|
#todo? |
|
} |
|
proc disableAnsi {} { |
|
|
|
} |
|
|
|
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel? |
|
#on windows they can be set independently (but not with stty) - REVIEW |
|
|
|
#NOTE - the is_raw is only being set in current interp - but the channel is shared. |
|
#this is problematic with the repl thread being separate. - must be a tsv? REVIEW |
|
proc enableRaw {{channel stdin}} { |
|
#variable is_raw |
|
|
|
variable previous_stty_state_$channel |
|
set sttycmd [auto_execok stty] |
|
if {[set previous_stty_state_$channel] eq ""} { |
|
if {[catch {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} { |
|
set previous_stty_state_$channel "" |
|
} |
|
} |
|
|
|
exec {*}$sttycmd raw -echo <@$channel |
|
tsv::set console is_raw 1 |
|
return [dict create previous [set previous_stty_state_$channel]] |
|
} |
|
proc disableRaw {{channel stdin}} { |
|
#variable is_raw |
|
variable previous_stty_state_$channel |
|
set sttycmd [auto_execok stty] |
|
if {[set previous_stty_state_$channel] ne ""} { |
|
exec {*}$sttycmd [set previous_stty_state_$channel] |
|
set previous_stty_state_$channel "" |
|
tsv::set console is_raw 0 |
|
return restored |
|
} |
|
exec {*}$sttycmd -raw echo <@$channel |
|
tsv::set console is_raw 0 |
|
return done |
|
} |
|
proc enableVirtualTerminal {{channels {input output}}} { |
|
|
|
} |
|
proc disableVirtualTerminal {args} { |
|
|
|
} |
|
} |
|
|
|
#review - document and decide granularity required. should we enable/disable more than one at once? |
|
proc enable_mouse {} { |
|
puts -nonewline stdout \x1b\[?1000h |
|
puts -nonewline stdout \x1b\[?1003h |
|
puts -nonewline stdout \x1b\[?1015h |
|
puts -nonewline stdout \x1b\[?1006h |
|
flush stdout |
|
} |
|
proc disable_mouse {} { |
|
puts -nonewline stdout \x1b\[?1000l |
|
puts -nonewline stdout \x1b\[?1003l |
|
puts -nonewline stdout \x1b\[?1015l |
|
puts -nonewline stdout \x1b\[?1006l |
|
flush stdout |
|
} |
|
proc enable_bracketed_paste {} { |
|
puts -nonewline stdout \x1b\[?2004h |
|
} |
|
proc disable_bracketed_paste {} { |
|
puts -nonewline stdout \x1b\[?2004l |
|
} |
|
proc start_application_mode {} { |
|
#need loop to read events? |
|
puts -nonewline stdout \x1b\[?1049h ;#alt screen |
|
enable_mouse |
|
#puts -nonewline stdout \x1b\[?25l ;#hide cursor |
|
puts -nonewline stdout \x1b\[?1003h\n |
|
enable_bracketed_paste |
|
|
|
} |
|
#todo stop_application_mode {} {} |
|
|
|
proc mode {{raw_or_line query}} { |
|
#variable is_raw |
|
variable ansi_available |
|
set raw_or_line [string tolower $raw_or_line] |
|
if {$raw_or_line eq "query"} { |
|
if {[tsv::get console is_raw]} { |
|
return "raw" |
|
} else { |
|
return "line" |
|
} |
|
} elseif {$raw_or_line eq "raw"} { |
|
if {[catch { |
|
punk::console::enableRaw |
|
} errM]} { |
|
puts stderr "Warning punk::console::enableRaw failed - $errM" |
|
} |
|
if {[can_ansi]} { |
|
punk::console::enableVirtualTerminal both |
|
} |
|
} elseif {$raw_or_line eq "line"} { |
|
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) |
|
if {[catch { |
|
punk::console::disableRaw |
|
} errM]} { |
|
puts stderr "Warning punk::console::disableRaw failed - $errM" |
|
} |
|
if {[can_ansi]} { |
|
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc |
|
punk::console::enableVirtualTerminal output ;#display/use ansi codes |
|
} |
|
} else { |
|
error "punk::console::mode expected 'raw' or 'line' or default value 'query'" |
|
} |
|
} |
|
|
|
namespace eval internal { |
|
proc abort_if_loop {{failmsg ""}} { |
|
#puts "il1 [info level 1]" |
|
#puts "thisproc: [lindex [info level 0] 0]" |
|
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}] |
|
#puts "would_loop: $would_loop" |
|
if {$would_loop} { |
|
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}] |
|
if {$failmsg eq ""} { |
|
set errmsg "[namespace current] Failed to redefine procedure $procname" |
|
} else { |
|
set errmsg $failmsg |
|
} |
|
error $errmsg |
|
} |
|
} |
|
proc define_windows_procs {} { |
|
package require zzzload |
|
set loadstate [zzzload::pkg_require twapi] |
|
|
|
#loadstate could also be stuck on loading? - review - zzzload not very ripe |
|
#Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues. |
|
if {$loadstate ni [list failed]} { |
|
#possibly still 'loading' |
|
#review zzzload usage |
|
#puts stdout "=========== console loading twapi =============" |
|
set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait |
|
} |
|
|
|
if {$loadstate ni [list failed]} { |
|
package require twapi ;#should be fast once twapi dll loaded in zzzload thread |
|
set ::punk::console::has_twapi 1 |
|
|
|
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work. |
|
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't. |
|
#Find a compromise to organise things somewhat sensibly.. |
|
|
|
#this is really enableAnsi *processing* |
|
proc [namespace parent]::enableAnsi {} { |
|
#output handle modes |
|
#Enable virtual terminal processing (sometimes off in older windows terminals) |
|
#ENABLE_PROCESSED_OUTPUT = 0x0001 |
|
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002 |
|
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 |
|
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008 |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode_out [twapi::GetConsoleMode $h_out] |
|
set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi? |
|
|
|
twapi::SetConsoleMode $h_out $newmode_out |
|
|
|
#what does window_input have to do with it?? |
|
#input handle modes |
|
#ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal |
|
#ENABLE_LINE_INPUT 0x0002 |
|
#ENABLE_ECHO_INPUT 0x0004 |
|
#ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) |
|
#ENABLE_MOUSE_INPUT 0x0010 |
|
#ENABLE_INSERT_MODE 0X0020 |
|
#ENABLE_QUICK_EDIT_MODE 0x0040 |
|
#ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in | 8}] |
|
#set newmode_in [expr {$oldmode_in | 0x208}] |
|
|
|
twapi::SetConsoleMode $h_in $newmode_in |
|
|
|
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
proc [namespace parent]::disableAnsi {} { |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode_out [twapi::GetConsoleMode $h_out] |
|
set newmode_out [expr {$oldmode_out & ~4}] |
|
twapi::SetConsoleMode $h_out $newmode_out |
|
|
|
#??? review |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in & ~8}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
|
|
|
|
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
|
|
# |
|
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { |
|
set ins [list in input stdin] |
|
set outs [list out output stdout stderr] |
|
set known [concat $ins $outs both] |
|
set directions [list] |
|
foreach v $channels { |
|
if {$v in $ins} { |
|
lappend directions input |
|
} elseif {$v in $outs} { |
|
lappend directions output |
|
} elseif {$v eq "both"} { |
|
lappend directions input output |
|
} |
|
if {$v ni $known} { |
|
error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" |
|
} |
|
} |
|
set channels $directions ;#don't worry about dups. |
|
if {"both" in $channels} { |
|
lappend channels input output |
|
} |
|
set result [dict create] |
|
if {"output" in $channels} { |
|
#note setting stdout makes stderr have the same settings - ie there is really only one output to configure |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode [twapi::GetConsoleMode $h_out] |
|
set newmode [expr {$oldmode | 4}] |
|
twapi::SetConsoleMode $h_out $newmode |
|
dict set result output [list from $oldmode to $newmode] |
|
} |
|
|
|
if {"input" in $channels} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in | 0x200}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
dict set result input [list from $oldmode_in to $newmode_in] |
|
} |
|
|
|
return $result |
|
} |
|
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { |
|
set ins [list in input stdin] |
|
set outs [list out output stdout stderr] |
|
set known [concat $ins $outs both] |
|
set directions [list] |
|
foreach v $channels { |
|
if {$v in $ins} { |
|
lappend directions input |
|
} elseif {$v in $outs} { |
|
lappend directions output |
|
} elseif {$v eq "both"} { |
|
lappend directions input output |
|
} |
|
if {$v ni $known} { |
|
error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" |
|
} |
|
} |
|
set channels $directions ;#don't worry about dups. |
|
if {"both" in $channels} { |
|
lappend channels input output |
|
} |
|
set result [dict create] |
|
if {"output" in $channels} { |
|
#as above - configuring stdout does stderr too |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode [twapi::GetConsoleMode $h_out] |
|
set newmode [expr {$oldmode & ~4}] |
|
twapi::SetConsoleMode $h_out $newmode |
|
dict set result output [list from $oldmode to $newmode] |
|
} |
|
if {"input" in $channels} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in & ~0x200}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
dict set result input [list from $oldmode_in to $newmode_in] |
|
} |
|
|
|
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
return $result |
|
} |
|
|
|
proc [namespace parent]::enableProcessedInput {} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in | 1}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
return [list stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
proc [namespace parent]::disableProcessedInput {} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in & ~1}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
return [list stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
|
|
|
|
|
|
} else { |
|
|
|
puts stderr "punk::console falling back to stty because twapi load failed" |
|
proc [namespace parent]::enableAnsi {} { |
|
puts stderr "punk::console::enableAnsi todo" |
|
} |
|
proc [namespace parent]::disableAnsi {} { |
|
} |
|
#? |
|
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { |
|
} |
|
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { |
|
} |
|
proc [namespace parent]::enableProcessedInput {args} { |
|
|
|
} |
|
proc [namespace parent]::disableProcessedInput {args} { |
|
|
|
} |
|
|
|
} |
|
|
|
proc [namespace parent]::enableRaw {{channel stdin}} { |
|
#variable is_raw |
|
variable previous_stty_state_$channel |
|
|
|
if {[package provide twapi] ne ""} { |
|
set console_handle [twapi::get_console_handle stdin] |
|
#returns dictionary |
|
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0 |
|
set oldmode [twapi::get_console_input_mode] |
|
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0 |
|
# Turn off the echo and line-editing bits |
|
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] |
|
set newmode [twapi::get_console_input_mode] |
|
|
|
tsv::set console is_raw 1 |
|
#don't disable handler - it will detect is_raw |
|
### twapi::set_console_control_handler {} |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} elseif {[set sttycmd [auto_execok stty]] ne ""} { |
|
if {[set previous_stty_state_$channel] eq ""} { |
|
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] |
|
} |
|
|
|
exec {*}$sttycmd raw -echo <@$channel |
|
tsv::set console is_raw 1 |
|
#review - inconsistent return dict |
|
return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] |
|
} else { |
|
error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" |
|
} |
|
} |
|
|
|
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?) |
|
#could be we were missing a step in reopening stdin and console configuration? |
|
|
|
proc [namespace parent]::disableRaw {{channel stdin}} { |
|
#variable is_raw |
|
variable previous_stty_state_$channel |
|
|
|
if {[package provide twapi] ne ""} { |
|
set console_handle [twapi::get_console_handle stdin] |
|
set oldmode [twapi::get_console_input_mode] |
|
# Turn on the echo and line-editing bits |
|
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 |
|
set newmode [twapi::get_console_input_mode] |
|
tsv::set console is_raw 0 |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} elseif {[set sttycmd [auto_execok stty]] ne ""} { |
|
#stty can return info on windows - but doesn't seem to be able to set anything. |
|
#review - is returned info even valid? |
|
|
|
set sttycmd [auto_execok stty] |
|
if {[set previous_stty_state_$channel] ne ""} { |
|
exec {*}$sttycmd [set previous_stty_state_$channel] |
|
set previous_stty_state_$channel "" |
|
return restored |
|
} |
|
exec {*}$sttycmd -raw echo <@$channel |
|
tsv::set console is_raw 0 |
|
#do we really want to exec stty yet again to show final 'to' state? |
|
#probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. |
|
return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] |
|
} else { |
|
error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" |
|
} |
|
} |
|
|
|
|
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::internal::get_ansi_response_payload |
|
@cmd -name punk::console::internal::get_ansi_response_payload -help\ |
|
"Terminal query helper. |
|
Captures the significant portion (payload as defined by |
|
supplied capturingendregex capture groups) of the input |
|
channel's response to a query placed on the output channel. |
|
Usually this means a write to stdout with a response on |
|
stdin. |
|
This function uses a 'chan event' read handler function |
|
::punk::console::internal::ansi_response_handler_regex to |
|
read the input channel character by character to ensure it |
|
doesn't overconsume input. |
|
|
|
It can run cooperatively with the punk::repl stdin reader |
|
or other readers if done carefully. |
|
The mechanism to run while other readers are active involves |
|
disabling and re-enabling installed 'chan event' handlers |
|
and possibly using a shared namespace variable |
|
(::punk::console::input_chunks_waiting) to ensure all data |
|
gets to the right handler. (unread data on input prior to this |
|
function being called) |
|
Not fully documented. (source diving required -see punk::repl) |
|
" |
|
@opts |
|
-ignoreok -type boolean -default 0 -help\ |
|
"Experimental/debug |
|
ignore the regex match 'ok' response |
|
and keep going." |
|
-return -type string -default payload -choices {payload dict} -choicelabels { |
|
dict\ |
|
"dict with keys prefix,response,payload,all" |
|
} -help\ |
|
"Return format" |
|
|
|
-terminal -default {stdin stdout} -type list -help\ |
|
"terminal (currently list of in/out channels) (todo - object?)" |
|
-expected_ms -default 300 -type integer -help\ |
|
"Expected number of ms for response from terminal. |
|
100ms is usually plenty for a local terminal and a |
|
basic query such as cursor position. |
|
However on a busy machine a higher timeout may be |
|
prudent." |
|
@values -min 2 -max 2 |
|
query -type string -help\ |
|
"ANSI sequence such as \x1b\[?6n which |
|
should elicit a response by the terminal |
|
on stdin" |
|
capturingendregex -type string -help\ |
|
"capturingendregex should capture ANY prefix, whole escape match - and a subcapture |
|
of the data we're interested in; and match at end of string. |
|
ie {(.*)(ESC(info)end)$} |
|
e.g {(.*)(\x1bP44!~([:alnum:])\x1b\\)$} |
|
we expect 4 results from regexp -indices -inline (overallmatch, prefix, wholeescape,info)" |
|
}] |
|
#todo - check capturingendregex value supplied has appropriate captures and tail-anchor |
|
proc get_ansi_response_payload {args} { |
|
#we pay a few 10s of microseconds to use punk::args::parse (on the happy path) |
|
#seems reasonable for the flexibility in this case. |
|
set argd [punk::args::parse $args withid ::punk::console::internal::get_ansi_response_payload] |
|
lassign [dict values $argd] leaders opts values received |
|
|
|
set inoutchannels [dict get $opts -terminal] |
|
set expected [dict get $opts -expected_ms] |
|
set ignoreok [dict get $opts -ignoreok] |
|
set returntype [dict get $opts -return] |
|
set query [dict get $values query] |
|
set capturingendregex [dict get $values capturingendregex] |
|
|
|
lassign $inoutchannels input output |
|
|
|
#chunks from input that need to be handled by readers |
|
upvar ::punk::console::input_chunks_waiting input_chunks_waiting |
|
|
|
#we need to cooperate with other stdin/$input readers and put data here if we overconsume. |
|
#Main repl reader may be currently active - or may be inactive. |
|
#This call could come from within code called by the main reader - or from user code running while main read-loop is temporarily disabled |
|
#In other contexts there may not even be another input reader |
|
|
|
#REVIEW - what if there is existing data in input_chunks_waiting - is it for us? |
|
#This occurs for example with key held down on autorepeat and is normal |
|
#enable it here for debug/testing only |
|
#if {[info exists input_chunks_waiting($input)] && [llength $input_chunks_waiting($input)]} { |
|
# puts stderr "[punk::ansi::a+ cyan bold]get_ansi_response_payload called while input_chunks_waiting($input) contained data: [punk::ansi::a][ansistring VIEW $input_chunks_waiting($input)]" |
|
#} |
|
|
|
if {!$::punk::console::ansi_available} { |
|
return "" |
|
} |
|
# -- --- |
|
#set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context |
|
#clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] |
|
#Either is suitable here, where subsequent calls will be relatively far apart in time |
|
#speed of call insignificant compared to function |
|
set callid [clock clicks] |
|
# -- --- |
|
# |
|
|
|
upvar ::punk::console::ansi_response_chunk accumulator |
|
upvar ::punk::console::ansi_response_wait waitvar |
|
upvar ::punk::console::ansi_response_queue queue |
|
upvar ::punk::console::ansi_response_queuedata queuedata |
|
upvar ::punk::console::ansi_response_tslaunch tslaunch |
|
upvar ::punk::console::ansi_response_tsclock tsclock |
|
upvar ::punk::console::ansi_response_timeoutid timeoutid |
|
set accumulator($callid) "" |
|
set waitvar($callid) "" |
|
|
|
lappend queue $callid |
|
if {[llength $queue] > 1} { |
|
#while {[lindex $queue 0] ne $callid} {} |
|
set queuedata($callid) $args |
|
set runningid [lindex $queue 0] |
|
while {$runningid ne $callid} { |
|
#puts stderr "." |
|
vwait ::punk::console::ansi_response_wait |
|
set runningid [lindex $queue 0] |
|
if {$runningid ne $callid} { |
|
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) |
|
update ;#REVIEW - probably a bad idea |
|
after 10 |
|
set runningid [lindex $queue 0] ;#jn test |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
#todo - use a linked array and an accumulatorid and waitvar id? When can there be more than one terminal query in-flight? |
|
|
|
set existing_handler [chan event $input readable] ;#review! |
|
set this_handler ::punk::console::internal::ansi_response_handler_regex |
|
if {[lindex $existing_handler 0] eq $this_handler} { |
|
puts stderr "[punk::ansi::a+ red]Warning for callid $callid get_ansi_response_payload called while existing ansi response handler in place[a]: $this_handler" |
|
puts stderr "queue state: $queue" |
|
flush stderr |
|
|
|
if {[lindex $queue 0] ne $callid} { |
|
error "get_ansi_response_payload - re-entrancy unrecoverable" |
|
} |
|
} |
|
chan event $input readable {} |
|
|
|
# - 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? |
|
|
|
|
|
set previous_input_state [chan configure $input] |
|
#chan configure $input -blocking 0 |
|
|
|
#todo - make timeout configurable? |
|
set waitvarname "::punk::console::ansi_response_wait($callid)" |
|
|
|
|
|
#todo - test and save rawstate so we don't disableRaw if console was already raw |
|
if {![tsv::get console is_raw]} { |
|
set was_raw 0 |
|
punk::console::enableRaw |
|
#after 0 [list chan event $input readable [list $this_handler $input $callid $capturingendregex]] |
|
incr expected 50 ;#review |
|
set timeoutid($callid) [after $expected [list set $waitvarname timedout]] |
|
#puts stdout "sending console request [ansistring VIEW $query]" |
|
} else { |
|
set was_raw 1 |
|
set timeoutid($callid) [after $expected [list set $waitvarname timedout]] |
|
} |
|
#write before console enableRaw vs after?? |
|
#There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it |
|
puts -nonewline $output $query;flush $output |
|
chan configure $input -blocking 0 |
|
|
|
set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on |
|
set tsclock($callid) $tslaunch($callid) |
|
#after 0 |
|
#------------------ |
|
#trying alternatives to get faster read and maintain reliability..REVIEW |
|
#we should care more about performance in raw mode - as ultimately that's the one we prefer for full features |
|
#------------------ |
|
# 1) faster - races? |
|
$this_handler $input $callid $capturingendregex |
|
$this_handler $input $callid $capturingendregex |
|
if {$ignoreok || $waitvar($callid) ne "ok"} { |
|
chan event $input readable [list $this_handler $input $callid $capturingendregex] |
|
} |
|
# 2) more reliable? |
|
#chan event $input readable [list $this_handler $input $callid $capturingendregex] |
|
#------------------ |
|
|
|
|
|
#response from terminal |
|
#e.g for cursor position \033\[46;1R |
|
|
|
#after 0 [list $this_handler $input $callid $capturingendregex] |
|
set remaining $expected |
|
if {$waitvar($callid) eq ""} { |
|
set lastvwait [clock millis] |
|
vwait ::punk::console::ansi_response_wait($callid) |
|
#puts stderr ">>>> end vwait1 $waitvar($callid)<<<<" |
|
while {[string match extend-* $waitvar($callid)] || ($ignoreok && $waitvar($callid) eq "ok")} { |
|
if {[string match extend-* $waitvar($callid)]} { |
|
set extension [lindex [split $waitvar($callid) -] 1] |
|
if {$extension eq ""} { |
|
puts "blank extension $waitvar($callid)" |
|
puts "->[set $waitvar($callid)]<-" |
|
} |
|
puts stderr "get_ansi_response_payload Extending timeout by $extension for callid:$callid" |
|
after cancel $timeoutid($callid) |
|
set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] |
|
set last_elapsed [expr {[clock millis] - $lastvwait}] |
|
set remaining [expr {$remaining - $last_elapsed}] |
|
if {$remaining < 0} {set remaining 0} |
|
set newtime [expr {$remaining + $extension}] |
|
set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] |
|
set lastvwait [clock millis] |
|
vwait ::punk::console::ansi_response_wait($callid) |
|
} else { |
|
#ignoreok - reapply the handler that disabled itself due to 'ok' |
|
chan event $input readable [list $this_handler $input $callid $capturingendregex] |
|
set lastvwait [clock millis] |
|
vwait ::punk::console::ansi_response_wait($callid) |
|
} |
|
} |
|
} |
|
#response handler automatically removes it's own chan event |
|
chan event $input readable {} ;#explicit remove anyway - review |
|
|
|
if {$waitvar($callid) ne "timedout"} { |
|
after cancel $timeoutid($callid) |
|
} else { |
|
puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) in get_ansi_response_payload. callid $callid Ansi request was:'[ansistring VIEW -lf 1 -vt 1 $query]'" |
|
} |
|
|
|
if {$was_raw == 0} { |
|
punk::console::disableRaw |
|
} |
|
|
|
#restore $input state |
|
#it *might* be ok to restore entire state on an input channel |
|
#(it's not always on all channels - e.g stdout has -winsize which is read-only) |
|
#Safest to only restore what we think we've modified. |
|
chan configure $input -blocking [dict get $previous_input_state -blocking] |
|
|
|
|
|
|
|
set input_read [set accumulator($callid)] |
|
|
|
if {$input_read ne ""} { |
|
set got_match [regexp -indices $capturingendregex $input_read _match_indices prefix_indices response_indices payload_indices] |
|
if {$got_match} { |
|
set responsedata [string range $input_read {*}$response_indices] |
|
set payload [string range $input_read {*}$payload_indices] |
|
set prefixdata [string range $input_read {*}$prefix_indices] |
|
if {!$ignoreok && $prefixdata ne ""} { |
|
#puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" |
|
lappend input_chunks_waiting($input) $prefixdata |
|
} |
|
} else { |
|
#timedout - or eof? |
|
if {!$ignoreok} { |
|
puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" |
|
lappend input_chunks_waiting($input) $input_read |
|
set payload "" |
|
} else { |
|
set responsedata "" |
|
set payload "" |
|
set prefixdata "" |
|
} |
|
} |
|
} else { |
|
#timedout or eof? and nothing read |
|
set responsedata "" |
|
set prefixdata "" |
|
set payload "" |
|
} |
|
|
|
# ------------------------------------------------------------------------------------- |
|
# Other input readers |
|
# ------------------------------------------------------------------------------------- |
|
#is there a way to know if existing_handler is input_chunks_waiting aware? |
|
if {[string length $existing_handler] && [lindex $existing_handler 0] ne $this_handler} { |
|
#puts "get_ansi_response_payload reinstalling ------>$existing_handler<------" |
|
chan event $input readable $existing_handler |
|
#this_handler may have consumed all pending input on $input - so there may be no trigger for the readable chan event for existing_handler |
|
if {[llength $input_chunks_waiting($input)]} { |
|
#This is experimental If a handler is aware of input_chunks_waiting - there should be no need to schedule a trigger |
|
#If it isn't, but the handler can accept an existing chunk of data as a 'waiting' argument - we could trigger and pass it the waiting chunks - but there's no way to know its API. |
|
#we could look at info args - but that's not likely to tell us much in a robust way. |
|
#we could create a reflected channel for stdin? That is potentially an overreach..? |
|
#triggering it manually... as it was already listening - this should generally do no harm as it was the active reader anyway, but won't help with the missing data if it's input_chunks_waiting-unaware. |
|
set handler_args [info args [lindex $existing_handler 0]] |
|
if {[lindex $handler_args end] eq "waiting"} { |
|
#Looks like the existing handler is setup for punk repl cooperation. |
|
|
|
puts stdout "\n\n[punk::ansi::a+ yellow bold]-->punk::console::get_ansi_response_payload callid $callid triggering existing handler\n $existing_handler while over-read data is in punk::console::input_chunks_waiting($input) instead of channel[punk::ansi::a]" |
|
puts stdout "[punk::ansi::a+ yellow bold]-->waiting: [ansistring VIEW -lf 1 -vt 1 $input_chunks_waiting($input)][punk::ansi::a]" |
|
flush stdout |
|
|
|
#concat and supply to existing handler in single text block - review |
|
#Note will only |
|
set waitingdata [join $input_chunks_waiting($input) ""] |
|
set input_chunks_waiting($input) [list] |
|
#after idle [list after 0 [list {*}$existing_handler $waitingdata]] |
|
after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review |
|
unset waitingdata |
|
} else { |
|
#! todo? for now, emit a clue as to what's happening. |
|
puts stderr "[punk::ansi::a+ yellow bold]-->punk::console::get_ansi_response_payload cannot trigger existing handler $existing_handler while over-read data is in punk::console::input_chunks_waiting($input) instead of channel [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
if {[eof $input]} { |
|
puts stdout "restarting repl" |
|
repl::reopen_stdin |
|
} |
|
} |
|
} |
|
} |
|
#Note - we still may be in_repl_handler here (which disables its own reader while executing commandlines) |
|
#The input_chunks_waiting may really belong to the existing_handler we found - but if it doesn't consume them they will end up being read by the repl_handler when it eventually re-enables. |
|
#todo - some better structure than just a list of waiting chunks indexed by input channel, so repl/other handlers can determine the context in which these waiting chunks were generated? |
|
} elseif {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
#if {[llength $input_chunks_waiting($input)]} { |
|
#don't trigger the repl handler manually - we will inevitably get things out of order - as it knows when to enable/disable itself based on whether chunks are waiting. |
|
#triggering it by putting it on the eventloop will potentially result in re-entrancy |
|
#The cooperating reader must be designed to consume waiting chunks and only reschedule it's channel read handler once all waiting chunks have been consumed. |
|
#puts stderr "[punk::ansi::a+ green bold]--> repl_handler has chunks to consume [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" |
|
#} |
|
if {[eof $input]} { |
|
#test |
|
puts stdout "get_ansi_response_payload experimental - restarting repl" |
|
repl::reopen stdin |
|
} |
|
} |
|
# ------------------------------------------------------------------------------------- |
|
|
|
|
|
|
|
unset -nocomplain accumulator($callid) |
|
unset -nocomplain waitvar($callid) |
|
unset -nocomplain timeoutid($callid) |
|
unset -nocomplain tsclock($callid) |
|
unset -nocomplain tslaunch($callid) |
|
dict unset queuedata $callid |
|
|
|
#lpop queue 0 |
|
ledit queue 0 0 |
|
if {[llength $queue] > 0} { |
|
set next_callid [lindex $queue 0] |
|
set waitvar($callid) go_ahead |
|
#set nextdata [set queuedata($next_callid)] |
|
} |
|
|
|
|
|
|
|
#set punk::console::chunk "" |
|
if {$returntype eq "dict"} { |
|
return [dict create\ |
|
prefix $prefixdata\ |
|
payload $payload\ |
|
response $responsedata\ |
|
all $input_read\ |
|
] |
|
} else { |
|
return $payload |
|
} |
|
} |
|
|
|
|
|
#review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) |
|
#review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) |
|
#review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results |
|
#review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? |
|
#e.g what happens to mouse-events while user code is executing? |
|
#we may still need this handler if such a loop doesn't exist. |
|
proc ansi_response_handler_regex {chan callid endregex} { |
|
upvar ::punk::console::ansi_response_chunk chunks |
|
upvar ::punk::console::ansi_response_wait waits |
|
upvar ::punk::console::ansi_response_tslaunch tslaunch ;#initial time in millis was set when chan event was created |
|
upvar ::punk::console::ansi_response_tsclock tsclock |
|
|
|
#endregex should explicitly have a trailing $ |
|
set status [catch {read $chan 1} bytes] |
|
if { $status != 0 } { |
|
# Error on the channel |
|
chan event $chan readable {} |
|
puts "ansi_response_handler_regex error reading $chan: $bytes" |
|
set waits($callid) [list error error_read status $status bytes $bytes] |
|
} elseif {$bytes ne ""} { |
|
#puts stderr . ;flush stderr |
|
# Successfully read the channel |
|
#puts "got: [string length $bytes]bytes" |
|
set sofar [append chunks($callid) $bytes] |
|
#puts stderr [ansistring VIEW $chunks($callid)] |
|
#review - what is min length of any ansiresponse? |
|
#we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z |
|
#endregex is capturing - but as we are only testing the match here |
|
#it should perform the same as if it were non-capturing |
|
if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { |
|
#puts stderr "matched - setting ansi_response_wait($callid) ok" |
|
chan event $chan readable {} |
|
set waits($callid) ok |
|
} else { |
|
# 30ms 16ms? |
|
set tsnow [clock millis] |
|
set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] |
|
set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] |
|
if {[string length $sofar] % 10 == 0 || $last_elapsed > 16} { |
|
if {$total_elapsed > 3000} { |
|
#REVIEW |
|
#too long since initial read handler launched.. |
|
#is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? |
|
#For now we'll stop extending the timeout. |
|
after cancel $::punk::console::ansi_response_timeoutid($callid) |
|
set waits($callid) [list error error_ansi_response_handler_regex_too_long_reading] |
|
} else { |
|
if {$last_elapsed > 0} { |
|
after cancel $::punk::console::ansi_response_timeoutid($callid) |
|
set waits($callid) extend-[expr {min(16,$last_elapsed)}] |
|
} |
|
} |
|
} |
|
set tsclock(callid) [clock millis] |
|
} |
|
} elseif {[catch {eof $chan}] || [eof $chan]} { |
|
catch {chan event $chan readable {}} |
|
# End of file on the channel |
|
#review |
|
puts stderr "ansi_response_handler_regex end of file on channel $chan" |
|
set waits($callid) eof |
|
} elseif {![catch {chan blocked $chan}] && [chan blocked $chan]} { |
|
# Read blocked is normal. (chan -blocking = 0 but reading only 1 char) |
|
# Caller should be using timeout on the wait variable |
|
#set waits($callid) continue |
|
set tsclock($callid) [clock millis] |
|
} else { |
|
chan event $chan readable {} |
|
# Something else |
|
puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but not chan blocked or EOF" |
|
set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof |
|
} |
|
} |
|
} ;#end namespace eval internal |
|
|
|
variable colour_disabled 0 |
|
#todo - move to punk::config |
|
# https://no-color.org |
|
if {[info exists ::env(NO_COLOR)]} { |
|
if {$::env(NO_COLOR) ne ""} { |
|
set colour_disabled 1 |
|
} |
|
} |
|
|
|
#a and a+ functions are not very useful when emitting directly to console |
|
#e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first |
|
|
|
|
|
#punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ |
|
lappend PUNKARGS_aliases {::punk::console::code_a+ ::punk::ansi::a+} |
|
proc code_a+ {args} { |
|
variable ansi_wanted |
|
if {$ansi_wanted <= 0} { |
|
return |
|
} |
|
#a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here |
|
#tailcall punk::ansi::a+ {*}$args |
|
::punk::ansi::a+ {*}$args |
|
} |
|
lappend PUNKARGS_aliases {::punk::console::code_a ::punk::ansi::a} |
|
proc code_a {args} { |
|
variable ansi_wanted |
|
if {$ansi_wanted <= 0} { |
|
return |
|
} |
|
#tailcall punk::ansi::a {*}$args |
|
::punk::ansi::a {*}$args |
|
} |
|
lappend PUNKARGS_aliases {::punk::console::code_a? ::punk::ansi::a?} |
|
proc code_a? {args} { |
|
variable ansi_wanted |
|
if {$ansi_wanted <= 0} { |
|
return [punk::ansi::ansistripraw [::punk::ansi::a? {*}$args]] |
|
} else { |
|
tailcall ::punk::ansi::a? {*}$args |
|
} |
|
} |
|
#proc a? {args} { |
|
# #stdout |
|
# variable ansi_wanted |
|
# if {$ansi_wanted <= 0} { |
|
# puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]] |
|
# } else { |
|
# tailcall ansi::a? {*}$args |
|
# } |
|
#} |
|
|
|
#REVIEW! this needs reworking. |
|
#It needs to be clarified as to what ansi off is supposed to do. |
|
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames? |
|
#It will stop underlines/bold/reverse as well as SGR colours |
|
#what about ansi movement codes etc? |
|
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms |
|
proc ansi {{onoff {}}} { |
|
variable ansi_wanted |
|
if {[string length $onoff]} { |
|
set onoff [string tolower $onoff] |
|
switch -- $onoff { |
|
1 - |
|
on - |
|
true - |
|
yes { |
|
set ansi_wanted 1 |
|
} |
|
0 - |
|
off - |
|
false - |
|
no { |
|
set ansi_wanted 0 |
|
punk::ansi::sgr_cache -action clear |
|
} |
|
default { |
|
set ansi_wanted 2 |
|
} |
|
default { |
|
error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" |
|
} |
|
} |
|
} |
|
catch {punk::repl::reset_prompt} |
|
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off" |
|
return [expr {$ansi_wanted}] |
|
} |
|
|
|
#colour |
|
# Turning colour off will stop SGR colour codes from being generated unless 'forcecolour' is added to the argument list for the punk::ans::a functions |
|
proc colour {{on {}}} { |
|
variable colour_disabled |
|
if {$on ne ""} { |
|
if {![string is boolean -strict $on]} { |
|
error "punk::console::colour expected a boolean e.g 0|1|on|off|true|false|yes|no" |
|
} |
|
#an experiment with complete disabling vs test of state for each call |
|
if {$on} { |
|
if {$colour_disabled} { |
|
#change of state |
|
punk::ansi::sgr_cache -action clear |
|
catch {punk::repl::reset_prompt} |
|
set colour_disabled 0 |
|
} |
|
} else { |
|
#we don't disable a/a+ entirely - they must still emit underlines/bold/reverse |
|
if {!$colour_disabled} { |
|
#change of state |
|
punk::ansi::sgr_cache -action clear |
|
catch {punk::repl::reset_prompt} |
|
set colour_disabled 1 |
|
} |
|
} |
|
} |
|
return [expr {!$colour_disabled}] |
|
} |
|
|
|
#test - find a better place to set terminal type |
|
variable is_vt52 0 |
|
proc vt52 {{onoff {}}} { |
|
#todo - return to colour state beforehand?. support 0-15 vt52 colours? |
|
#we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes |
|
variable is_vt52 |
|
if {$onoff eq ""} { |
|
return $is_vt52 |
|
} |
|
if {![string is boolean -strict $onoff]} { |
|
error "vt52 setting must be a boolean - or empty to query" |
|
} |
|
if {$is_vt52} { |
|
if {!$onoff} { |
|
puts -nonewline "\x1b<" |
|
set is_vt52 0 |
|
colour on |
|
} |
|
} else { |
|
if {$onoff} { |
|
unset_mode DECANM |
|
set is_vt52 1 |
|
colour off |
|
} else { |
|
puts -nonewline "\x1b<" |
|
#emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ |
|
} |
|
} |
|
return $is_vt52 |
|
} |
|
|
|
namespace eval local { |
|
proc set_codepage_output {cpname} { |
|
#todo |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
twapi::set_console_output_codepage $cpname |
|
} else { |
|
error "set_codepage_output unimplemented on $::tcl_platform(platform)" |
|
} |
|
} |
|
proc set_codepage_input {cpname} { |
|
#todo |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
twapi::set_console_input_codepage $cpname |
|
} else { |
|
error "set_codepage_input unimplemented on $::tcl_platform(platform)" |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::local::echo |
|
@cmd -name punk::console::local::echo -help\ |
|
"Use stty on unix, or twapi on windows to set terminal |
|
local input echo on/off - experimental" |
|
@values -min 0 -max 1 |
|
onoff -type boolean -default "" -help\ |
|
"Omit or pass empty string to query current echo state." |
|
}] |
|
proc echo {args} { |
|
set argd [punk::args::parse $args withid ::punk::console::local::echo] |
|
set onoff [dict get $argd values onoff] |
|
|
|
set is_windows [string equal "windows" $::tcl_platform(platform)] |
|
if {$onoff eq ""} { |
|
#query |
|
if {$is_windows} { |
|
package require twapi |
|
set inputstate [twapi::get_console_input_mode] |
|
return [dict get $inputstate -echoinput] |
|
} else { |
|
#counterintuitively - the human format (-a) seems more consistent across platforms than the machine readable (-g) formats |
|
#for now, quick and dirty look for echo in the list seems to work on wsl & freebsd at least. |
|
set tstate [exec stty -a] |
|
if {[lsearch $tstate echo] > 0} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
} else { |
|
if {![string is boolean -strict $onoff]} { |
|
error "::punk::console::local::echo requires boolean argument to set on or off" |
|
} |
|
if {$is_windows} { |
|
set onoff [expr {true && $onoff}] ;#ensure true,yes etc are converted to 1|0 |
|
set conh [twapi::get_console_handle stdin] |
|
twapi::modify_console_input_mode $conh -echoinput $onoff |
|
|
|
return $onoff |
|
} else { |
|
if {$onoff} { |
|
{*}[auto_execok stty] echo |
|
return 1 |
|
} else { |
|
{*}[auto_execok stty] -echo |
|
return 0 |
|
} |
|
} |
|
} |
|
} |
|
} |
|
namespace import local::set_codepage_output |
|
namespace import local::set_codepage_input |
|
|
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::show_input_response |
|
@cmd -name punk::console::show_input_response -help\ |
|
"Debug command for console queries using ANSI" |
|
@opts |
|
-terminal -default {stdin stdout} -type list -help\ |
|
"terminal (currently list of in/out channels) (todo - object?)" |
|
-expected_ms -type integer -default 500 -help\ |
|
"Number of ms to wait for response" |
|
@values -min 1 -max 1 |
|
request -type string -help\ |
|
{ANSI sequence such as \x1b\[?6n which |
|
should elicit a response by the terminal |
|
on stdin} |
|
}] |
|
proc show_input_response {args} { |
|
set argd [punk::args::parse $args withid ::punk::console::show_input_response] |
|
lassign [dict values $argd] leaders opts values received |
|
set request [dict get $values request] |
|
set inoutchannels [dict get $opts -terminal] |
|
set expected [dict get $opts -expected_ms] |
|
|
|
set capturingregex {(((.*)))$} ;#capture entire response same as response-payload |
|
set ts_start [clock millis] |
|
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] |
|
set ts_end [clock millis] |
|
puts stderr $response |
|
set out "" |
|
dict for {k v} $response { |
|
append out "$k [ansistring VIEW $v]" \n |
|
} |
|
append out "totalms [expr {$ts_end - $ts_start}]" |
|
return $out |
|
} |
|
|
|
# -- --- --- --- --- --- --- |
|
#get_ansi_response functions |
|
#review - can these functions sensibly be used on channels not attached to the local console? |
|
#ie can we default to {stdin stdout} but allow other channel pairs? |
|
# -- --- --- --- --- --- --- |
|
proc get_cursor_pos {{inoutchannels {stdin stdout}}} { |
|
if {$::punk::console::is_vt52} { |
|
error "vt52 can't perform get_cursor_pos" |
|
} |
|
#response from terminal |
|
#e.g \033\[46;1R |
|
set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload |
|
|
|
set request "\033\[6n" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
#some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ |
|
#todo - what? |
|
#often terminals that fail will just put the raw request code on stdin - we could detect that and then |
|
#try the other? |
|
|
|
return $payload |
|
} |
|
proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { |
|
#e.g \x1b\[P44!~E797\x1b\\ |
|
#re e.g {(.*)(\x1b\[P44!~([[:alnum:]])\x1b\[\\)$} |
|
set capturingregex [string map [list %id% $id] {(.*)(\x1bP%id%!~([[:alnum:]]+)\x1b\\)$}] |
|
set request "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
proc get_device_status {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[([0-9]+)n)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[5n" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
|
|
variable last_da1_result "" |
|
#TODO - 22? 28? 32? |
|
#1 132 columns |
|
#2 Printer port extension |
|
#4 Sixel extension |
|
#6 Selective erase |
|
#7 DRCS |
|
#8 UDK |
|
#9 NRCS |
|
#12 SCS extension |
|
#15 Technical character set |
|
#18 Windowing capability |
|
#21 Horizontal scrolling |
|
#23 Greek extension |
|
#24 Turkish extension |
|
#42 ISO Latin 2 character set |
|
#44 PCTerm |
|
#45 Soft key map |
|
#46 ASCII emulation |
|
|
|
#https://vt100.net/docs/vt510-rm/DA1.html |
|
# |
|
proc get_device_attributes {{inoutchannels {stdin stdout}}} { |
|
#Note the vt52 rough equivalen \x1bZ - commonly supported but probably best considered obsolete as it collides with ECMA 48 SCI Single Character Introducer |
|
#DA1 |
|
variable last_da1_result |
|
#first element in result is the terminal's architectural class 61,62,63,64.. ? |
|
#for vt100 we get things like: "ESC\[?1;0c" |
|
#for vt102 "ESC\[?6c" |
|
|
|
#set capturingregex {(.*)(\x1b\[\?6[0-9][;]*([;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload |
|
set capturingregex {(.*)(\x1b\[\?([0-9]*[;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[c" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
set last_da1_result $payload |
|
return $payload |
|
} |
|
#https://vt100.net/docs/vt510-rm/DA2.html |
|
proc get_device_attributes_secondary {{inoutchannels {stdin stdout}}} { |
|
#DA2 |
|
set capturingregex {(.*)(\x1b\[\>([0-9]*[;][0-9]*[;][0-1]c))$} ;#must capture prefix,entire-response,response-payload |
|
#expect CSI > X;10|20;0|1c - docs suggest X should be something like 61. In practice we see 0 or 1 (windows) REVIEW |
|
set request "\x1b\[>c" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
proc get_device_attributes_tertiary {{inoutchannels {stdin stdout}}} { |
|
#DA3 |
|
set capturingregex {(.*)(\x1bP!\|([0-9]{8})\x1b\\)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[=c" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
proc get_terminal_id {{inoutchannels {stdin stdout}}} { |
|
#DA3 - alias |
|
get_device_attributes_tertiary $inoutchannels |
|
} |
|
|
|
proc get_tabstops {{inoutchannels {stdin stdout}}} { |
|
#DECTABSR \x1b\[2\$w |
|
#response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) |
|
#set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} |
|
#set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} |
|
set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} |
|
set request "\x1b\[2\$w" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
set tabstops [split $payload "/"] |
|
return $tabstops |
|
} |
|
|
|
#a simple estimation of tab-width under assumption console is set with even spacing. |
|
#It's known this isn't always the case - but things like textutil::untabify2 take only a single value |
|
#on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower |
|
#we will use test_char_width as a fallback |
|
proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { |
|
set tslist [get_tabstops $inoutchannels] |
|
if {![llength $tslist]} { |
|
#either terminal failed to report - or none set. |
|
set testw [test_char_width \t] |
|
if {[string is integer -strict $testw]} { |
|
return $testw |
|
} |
|
#We don't support none - default to 8 |
|
return 8 |
|
} |
|
#we generally expect to see a tabstop at column 1 - but it may not be set. |
|
if {[lindex $tslist 0] eq "1"} { |
|
if {[llength $tslist] == 1} { |
|
set testw [test_char_width \t] |
|
if {[string is integer -strict $testw]} { |
|
return $testw |
|
} |
|
return 8 |
|
} else { |
|
set next [lindex $tslist 1] |
|
return [expr {$next - 1}] |
|
} |
|
} else { |
|
#simplistic guess at width - review - do we need to consider leftmost tabstops as more likely to be non-representative and look further into the list? |
|
if {[llength $tslist] == 1} { |
|
return [lindex $tslist 0] |
|
} else { |
|
return [expr {[lindex $tslist 1] - [lindex $tslist 0]}] |
|
} |
|
} |
|
} |
|
#default to 8 just because it seems to be most common default in terminals |
|
proc set_tabstop_width {{w 8}} { |
|
set tsize [get_size] |
|
set width [dict get $tsize columns] |
|
set mod [expr {$width % $w}] |
|
set max [expr {$width - $mod}] |
|
set tstops "" |
|
set c 1 |
|
while {$c <= $max} { |
|
append tstops [string repeat " " $w][punk::ansi::set_tabstop] |
|
incr c $w |
|
} |
|
set punk::console::tabwidth $w ;#we also attempt to read terminal's tabstops and set tabwidth to the apparent spacing of first non-1 value in tabstops list. |
|
catch {textutil::tabify::untabify2 "" $w} ;#textutil tabify can end up uninitialised and raise errors like "can't read Spaces(<n>).." after a tabstop change This call seems to keep tabify happy - review. |
|
puts -nonewline "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstops" |
|
} |
|
|
|
|
|
proc get_cursor_pos_list {{inoutchannels {stdin stdout}}} { |
|
return [split [get_cursor_pos $inoutchannels] ";"] |
|
} |
|
|
|
#todo - work out how to query terminal and set cell size in pixels |
|
#for now use the windows default |
|
variable cell_size |
|
set cell_size "" |
|
set cell_size_fallback 10x20 |
|
|
|
#todo - change -inoutchannels to -terminalobject with prebuilt default |
|
|
|
punk::args::define { |
|
@id -id ::punk::console::cell_size |
|
-inoutchannels -default {stdin stdout} -type list |
|
@values -min 0 -max 1 |
|
newsize -default "" -help\ |
|
"character cell pixel dimensions WxH |
|
or omit to query cell size." |
|
} |
|
proc cell_size {args} { |
|
set argd [punk::args::get_by_id ::punk::console::cell_size $args] |
|
set inoutchannels [dict get $argd opts -inoutchannels] |
|
set newsize [dict get $argd values newsize] |
|
|
|
variable cell_size |
|
if {$newsize eq ""} { |
|
#query existing setting |
|
if {$cell_size eq ""} { |
|
#not set - try to query terminal's overall dimensions |
|
set pixeldict [punk::console::get_xterm_pixels $inoutchannels] |
|
lassign $pixeldict _w sw _h sh |
|
if {[string is integer -strict $sw] && [string is integer -strict $sh]} { |
|
lassign [punk::console::get_size] _cols columns _rows rows |
|
#review - is returned size in pixels always a multiple of rows and cols? |
|
set w [expr {$sw / $columns}] |
|
set h [expr {$sh / $rows}] |
|
set cell_size ${w}x${h} |
|
return $cell_size |
|
} else { |
|
set cell_size $::punk::console::cell_size_fallback |
|
puts stderr "punk::console::cell_size unable to query terminal for pixel data - using default $cell_size" |
|
return $cell_size |
|
} |
|
} |
|
return $cell_size |
|
} |
|
#newsize supplied - try to set |
|
lassign [split [string tolower $newsize] x] w h |
|
if {![string is integer -strict $w] || ![string is integer -strict $h] || $w < 1 || $h < 1} { |
|
error "punk::sixel::cell_size error - expected format WxH where W and H are positive integers - got '$newsize'" |
|
} |
|
set cell_size ${w}x${h} |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::test_is_vt52 |
|
@cmd -name punk::console::test_is_vt52 -help\ |
|
"in development.. broken" |
|
-inoutchannels -default {stdin stdout} -type list |
|
@values -min 0 -max 0 |
|
} |
|
|
|
#only works in raw mode for windows terminal - (esc in output stripped?) why? |
|
# works in line mode for alacrity and wezterm |
|
proc test_is_vt52 {args} { |
|
set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] |
|
set inoutchannels [dict get $argd opts -inoutchannels] |
|
#ESC / K VT52 without printer |
|
#ESC / M VT52 with printer |
|
#ESC / Z VT52 emulator?? review |
|
|
|
#TODO |
|
set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload |
|
#set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1bZ" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
#puts -->$payload<-- |
|
return [expr {$payload in {Z K M}}] |
|
} |
|
|
|
#todo - determine cursor on/off state before the call to restore properly. |
|
proc get_size {{inoutchannels {stdin stdout}}} { |
|
lassign $inoutchannels in out |
|
#we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 |
|
#chan eof is faster whether chan exists or not than |
|
if {[catch {chan eof $out} is_eof]} { |
|
error "punk::console::get_size output channel $out seems to be closed ([info level 1])" |
|
} else { |
|
if {$is_eof} { |
|
error "punk::console::get_size eof on output channel $out ([info level 1])" |
|
} |
|
} |
|
#we don't need to care about the input channel if chan configure on the output can give us the info. |
|
#short circuit ansi cursor movement method if chan configure supports the -winsize value |
|
set outconf [chan configure $out] |
|
if {[dict exists $outconf -winsize]} { |
|
#this mechanism is much faster than ansi cursor movements |
|
#REVIEW check if any x-platform anomalies with this method? |
|
#can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least |
|
lassign [dict get $outconf -winsize] cols lines |
|
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
|
return [list columns $cols rows $lines] |
|
} |
|
#continue on to ansi mechanism if we didn't get 2 ints |
|
} |
|
|
|
if {[catch {chan eof $in} is_eof]} { |
|
error "punk::console::get_size input channel $in seems to be closed ([info level 1])" |
|
} else { |
|
if {$is_eof} { |
|
error "punk::console::get_size eof on input channel $in ([info level 1])" |
|
} |
|
} |
|
|
|
#keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. |
|
#no vt52 equiv? may as well strip all vt52 from here? |
|
lassign [get_cursor_pos_list $inoutchannels] start_row start_col |
|
variable is_vt52 |
|
if {!$is_vt52} { |
|
set movefunc "punk::ansi::move" |
|
set func_coff "punk::ansi::cursor_off" |
|
set func_con "punk::ansi::cursor_on" |
|
} else { |
|
set movefunc "punk::ansi::vt52move" |
|
set func_coff "punk::ansi::cursor_off_vt52" |
|
set func_con "punk::ansi::cursor_on_vt52" |
|
} |
|
if {[catch { |
|
#some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. |
|
#This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. |
|
|
|
puts -nonewline $out [$func_coff][$movefunc 2000 2000] |
|
lassign [get_cursor_pos_list $inoutchannels] lines cols |
|
puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout |
|
set result [list columns $cols rows $lines] |
|
} errM]} { |
|
puts -nonewline $out [$movefunc $start_row $start_col] |
|
puts -nonewline $out [$func_con] |
|
error "$errM" |
|
} else { |
|
return $result |
|
} |
|
} |
|
|
|
#faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore |
|
proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { |
|
lassign $inoutchannels in out |
|
#we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly |
|
set outconf [chan configure $out] |
|
if {[dict exists $outconf -winsize]} { |
|
lassign [dict get $outconf -winsize] cols lines |
|
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
|
return [list columns $cols rows $lines] |
|
} |
|
} |
|
|
|
if {[catch { |
|
#some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. |
|
#This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. |
|
puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] |
|
lassign [get_cursor_pos_list $inoutchannels] lines cols |
|
puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out |
|
set result [list columns $cols rows $lines] |
|
} errM]} { |
|
puts -nonewline $out [punk::ansi::cursor_restore_dec] |
|
puts -nonewline $out [punk::ansi::cursor_on] |
|
error "$errM" |
|
} else { |
|
return $result |
|
} |
|
} |
|
proc get_dimensions {{inoutchannels {stdin stdout}}} { |
|
lassign [get_size $inoutchannels] _c cols _l lines |
|
return "${cols}x${lines}" |
|
} |
|
#the (xterm?) CSI 18t query is supported by *some* terminals |
|
proc get_xterm_size {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[18t" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
lassign [split $payload {;}] rows cols |
|
return [list columns $cols rows $rows] |
|
} |
|
proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[14t" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
lassign [split $payload {;}] height width |
|
return [list width $width height $height] |
|
} |
|
|
|
|
|
proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[?7\$p" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
#Terminals generally default to LNM being reset (off) ie enter key sends a lone <cr> |
|
#Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) |
|
#I presume from this that almost nobody is using LNM 1 (which sends both <cr> and <lf>) |
|
proc get_mode_LNM {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[\?20;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[?20\$p" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
#DECRPM responses e.g: |
|
# \x1b\[?7\;1\$y |
|
# \x1b\[?7\;2\$y |
|
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) |
|
proc get_mode {num_or_name {inoutchannels {stdin stdout}}} { |
|
if {[string is integer -strict $num_or_name]} { |
|
set m $num_or_name |
|
} else { |
|
upvar ::punk::ansi::decmode_names decmode_names |
|
if {[dict exists $decmode_names $num_or_name]} { |
|
set m [dict get $decmode_names $num_or_name] |
|
} else { |
|
error "punk::console::get_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" |
|
} |
|
} |
|
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[?$m\$p" |
|
set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
proc set_mode {num_or_name {inoutchannels {stdin stdout}}} { |
|
if {[string is integer -strict $num_or_name]} { |
|
set m $num_or_name |
|
} else { |
|
upvar ::punk::ansi::decmode_names decmode_names |
|
if {[dict exists $decmode_names $num_or_name]} { |
|
set m [dict get $decmode_names $num_or_name] |
|
} else { |
|
error "punk::console::set_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" |
|
} |
|
} |
|
puts -nonewline "\x1b\[?${m}h" |
|
} |
|
proc unset_mode {num_or_name {inoutchannels {stdin stdout}}} { |
|
if {[string is integer -strict $num_or_name]} { |
|
set m $num_or_name |
|
} else { |
|
upvar ::punk::ansi::decmode_names decmode_names |
|
if {[dict exists $decmode_names $num_or_name]} { |
|
set m [dict get $decmode_names $num_or_name] |
|
} else { |
|
error "punk::console::unset_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" |
|
} |
|
} |
|
puts -nonewline "\x1b\[?${m}l" |
|
} |
|
|
|
|
|
#terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. |
|
#todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. |
|
#todo - determine if these anomalies are independent of font |
|
#punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. |
|
#review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) |
|
proc test_char_width {char_or_string {emit 0}} { |
|
#return 1 |
|
#JMN |
|
#puts stderr "cwtest" |
|
variable ansi_available |
|
if {!$ansi_available} { |
|
puts stderr "No ansi - cannot test char_width of '$char_or_string' returning [string length $char_or_string]" |
|
return [string length $char_or_string] |
|
} |
|
|
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 |
|
} |
|
set response "" |
|
if {[catch { |
|
set response [punk::console::get_cursor_pos] |
|
} errM]} { |
|
puts stderr "Cannot test_char_width for '[punk::ansi::ansistring VIEW $char_or_string]' - may be no console? Error message from get_cursor_pos: $errM" |
|
return |
|
} |
|
lassign [split $response ";"] _row1 col1 |
|
if {![string length $response] || ![string is integer -strict $col1]} { |
|
puts stderr "test_char_width Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" |
|
flush stderr |
|
return |
|
} |
|
|
|
#On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error |
|
#e.g contains surrogate pair |
|
if {[catch { |
|
puts -nonewline stdout $char_or_string |
|
} errM]} { |
|
puts stderr "test_char_width couldn't emit this string - \nerror: $errM" |
|
} |
|
|
|
set response [punk::console::get_cursor_pos] |
|
lassign [split $response ";"] _row2 col2 |
|
if {![string is integer -strict $col2]} { |
|
puts stderr "test_char_width could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" |
|
flush stderr |
|
return |
|
} |
|
|
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G |
|
} |
|
flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. |
|
return [expr {$col2 - $col1}] |
|
} |
|
|
|
#get reported cursor position after emitting teststring. |
|
#The row is more likely to be a lie than the column |
|
#With wrapping on we should be able to test if the terminal has an inconsistency between reported width and when it actually wraps. |
|
#(but as line wrapping generally occurs based on width - we probably won't see this - just 'apparently' early wrapping due to printing mismatch with width) |
|
#unfortunately if terminal reports something like \u200B as width 1, but doesn't print it - we can't tell. (vs reporting 1 wide and printing replacement char/space) |
|
#When cursor is already at bottom of screen, scrolling will occur so rowoffset will be zero |
|
#we either need to move cursor up before test - or use alt screen ( or scroll_up then scroll_down?) |
|
#for now we will use alt screen to reduce scrolling effects - REVIEW |
|
proc test_string_cursor {teststring {emit 0}} { |
|
variable ansi_available |
|
if {!$ansi_available} { |
|
puts stderr "No ansi - cannot test char_width of '$teststring' returning [string length $test_string]" |
|
return [string length $teststring] |
|
} |
|
punk::console::enable_alt_screen |
|
punk::console::move 0 0 |
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 |
|
} |
|
set response "" |
|
if {[catch { |
|
set response [punk::console::get_cursor_pos] |
|
} errM]} { |
|
puts stderr "Cannot test_string_cursor for '[punk::ansi::ansistring VIEW $teststring]' - may be no console? Error message from get_cursor_pos: $errM" |
|
return |
|
} |
|
lassign [split $response ";"] row1 col1 |
|
if {![string length $response] || ![string is integer -strict $col1] || ![string is integer -strict $row1]} { |
|
puts stderr "test_string_cursor Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" |
|
flush stderr |
|
return |
|
} |
|
|
|
puts -nonewline stdout $teststring |
|
flush stdout |
|
set response [punk::console::get_cursor_pos] |
|
lassign [split $response ";"] row2 col2 |
|
if {![string is integer -strict $col2] || ![string is integer -strict $row2]} { |
|
puts stderr "test_string_cursor could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" |
|
flush stderr |
|
return |
|
} |
|
|
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G |
|
} |
|
flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. |
|
punk::console::disable_alt_screen |
|
return [list rowoffset [expr {$col2 - $col1}] columnoffset [expr {$row2 - $row1}]] |
|
} |
|
|
|
#todo! - improve ideally we want to use VT sequences to determine - and make a separate utility for testing via systemcalls/os api |
|
proc test_can_ansi {} { |
|
#don't set ansi_avaliable here - we want to be able to change things, retest etc. |
|
if {"windows" eq "$::tcl_platform(platform)"} { |
|
if {[package provide twapi] ne ""} { |
|
set h_out [twapi::get_console_handle stdout] |
|
set existing_mode [twapi::GetConsoleMode $h_out] |
|
if {[expr {$existing_mode & 4}]} { |
|
#virtual terminal processing happens to be enabled - so it's supported |
|
return 1 |
|
} |
|
#output mode |
|
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 |
|
|
|
#try temporarily setting it - if we get an error - ansi not supported |
|
if {[catch { |
|
twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] |
|
} errM]} { |
|
return 0 |
|
} |
|
#restore |
|
twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] |
|
return 1 |
|
} else { |
|
#todo - try a cursorpos query and read stdin to see if we got a response? |
|
puts stderr "Unable to verify terminal ansi support - assuming modern default of true" |
|
puts stderr "to force disable, use command: ansi off" |
|
return 1 |
|
} |
|
} else { |
|
return 1 |
|
} |
|
} |
|
|
|
#review |
|
proc can_ansi {} { |
|
variable ansi_available |
|
if {!$ansi_available} { |
|
return 0 |
|
} |
|
#ansi_available defaults to -1 (unknown) |
|
if {$ansi_available == -1} { |
|
set ansi_available [test_can_ansi] |
|
return $ansi_available |
|
} |
|
return 1 |
|
} |
|
|
|
|
|
variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested |
|
#todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) |
|
proc grapheme_cluster_support {} { |
|
variable grapheme_cluster_support |
|
if {[dict size $grapheme_cluster_support]} { |
|
return $grapheme_cluster_support |
|
} |
|
|
|
if {[info exists ::env(TERM_PROGRAM)]} { |
|
#terminals known to support grapheme clusters, but unable to respond to decmode request 2027 |
|
#wezterm (on windows as at 2024-12 decmode 2027 doesn't work) |
|
#REVIEW - what if terminal is remote wezterm? can/will this env variable |
|
# iterm and apple terminal also set TERM_PROGRAM |
|
if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { |
|
set is_available 1 |
|
return [dict create available 1 mode set] |
|
} |
|
} |
|
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) |
|
set state [get_mode grapheme_clusters] ;#decmode 2027 extension |
|
set is_available 0 |
|
switch -- $state { |
|
0 { |
|
set m unsupported ;# the dec query is unsupported - but it's possible the terminal still has grapheme support |
|
} |
|
1 { |
|
set m set |
|
set is_available 1 |
|
} |
|
2 { |
|
set m unset |
|
} |
|
3 { |
|
set m permanently_set |
|
set is_available 1 |
|
} |
|
4 { |
|
set m permanently_unset |
|
} |
|
default { |
|
set m "BAD_RESPONSE" |
|
} |
|
} |
|
return [dict create available $is_available mode $m] |
|
} |
|
|
|
|
|
#review - the concept of using local mechanisms at all (ie apis) vs ansi is not necessarily something we want/need to support. |
|
#For the system to be really useful if needs to operate in conditions where the terminal is remote |
|
#This seems to be why windows console is deprecating various non-ansi api methods for interacting with the console. |
|
namespace eval local { |
|
proc titleset {windowtitle} { |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
if {![catch {twapi::set_console_title $windowtitle} result]} { |
|
return $windowtitle |
|
} else { |
|
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset" |
|
} |
|
} else { |
|
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset" |
|
} |
|
} |
|
proc titleget {} { |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
if {![catch {twapi::get_console_title} result]} { |
|
return $result |
|
} else { |
|
error "punk::console::local::titleset failed to set title - ensure twapi is available" |
|
} |
|
} else { |
|
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title |
|
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc) |
|
error "punk::console::local::titleget has no local mechanism to get the window title on this platform." |
|
} |
|
} |
|
} |
|
|
|
|
|
proc infocmp {} { |
|
set cmd1 [auto_execok infocmp] |
|
if {[string length $cmd1]} { |
|
puts stderr "" |
|
return [exec {*}$cmd1] |
|
} else { |
|
puts stderr "infocmp doesn't seem to be present" |
|
if {$::tcl_platform(platform) eq "FreeBSD"} { |
|
puts stderr "For FreeBSD - install ncurses to get infocmp and related binaries and also install terminfo-db" |
|
} |
|
set tcmd [auto_execok tput] |
|
if {[string length $tcmd]} { |
|
puts stderr "tput seems to be available. Try something like: tput -S - (freebsd)" |
|
} |
|
#todo - what? can tput query all caps? OS differences? |
|
} |
|
} |
|
|
|
|
|
#todo - compare speed with get_cursor_pos - work out why the big difference |
|
proc test_cursor_pos {} { |
|
if {![tsv::get console is_raw]} { |
|
set was_raw 0 |
|
enableRaw |
|
} else { |
|
set was_raw 1 |
|
} |
|
puts -nonewline stdout \033\[6n ;flush stdout |
|
chan configure stdin -blocking 0 |
|
set info [read stdin 20] ;# |
|
after 1 |
|
if {[string first "R" $info] <=0} { |
|
append info [read stdin 20] |
|
} |
|
if {!$was_raw} { |
|
disableRaw |
|
} |
|
set data [string range [string trim $info] 2 end-1] |
|
return [split $data ";"] |
|
} |
|
|
|
|
|
#channel? |
|
namespace eval ansi { |
|
variable PUNKARGS |
|
#ansi escape sequence based terminal/console control functions |
|
namespace export * |
|
|
|
#proc a {args} { |
|
# puts -nonewline [::punk::ansi::a {*}$args] |
|
#} |
|
#proc a+ {args} { |
|
# puts -nonewline [::punk::ansi::a+ {*}$args] |
|
#} |
|
#proc a? {args} { |
|
# puts -nonewline stdout [::punk::ansi::a? {*}$args] |
|
#} |
|
proc clear {} { |
|
puts -nonewline stdout [punk::ansi::clear] |
|
} |
|
proc clear_above {} { |
|
puts -nonewline stdout [punk::ansi::clear_above] |
|
} |
|
proc clear_below {} { |
|
puts -nonewline stdout [punk::ansi::clear_below] |
|
} |
|
proc clear_all {} { |
|
puts -nonewline stdout [punk::ansi::clear_all] |
|
} |
|
proc reset {} { |
|
puts -nonewline stdout [punk::ansi::reset] |
|
} |
|
proc cursor_on {} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
puts -nonewline stdout [punk::ansi::cursor_on] |
|
} else { |
|
puts -nonewline stdout [punk::ansi::cursor_on_vt52] |
|
} |
|
} |
|
proc cursor_off {} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
puts -nonewline stdout [punk::ansi::cursor_off] |
|
} else { |
|
puts -nonewline stdout [punk::ansi::cursor_off_vt52] |
|
} |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move |
|
@cmd -name punk::console::move -help\ |
|
{Return an ANSI or vt52 sequence to move cursor to row,col |
|
(aka: cursor home) |
|
|
|
The sequence emitted will depend on the mode of the |
|
terminal as stored in the consolehandle. |
|
Directly setting the mode via raw escape sequences: |
|
e.g unset_mode DECANM for vt52 |
|
or puts \x1b< to return to ANSI |
|
will not necessarily update the application of |
|
the change in terminal state. Major state changes |
|
such as this should be done via provided functions |
|
that keep the REPL state in sync with the underlying |
|
terminal state. |
|
|
|
For ANSI the sequence is of the form: |
|
ESC[<row>;<col>H |
|
(CSI row ; col H) |
|
This sequence will generally not be understood by |
|
terminals that are in vt52 mode. |
|
|
|
For VT52 the sequence is of the form: |
|
ESCY<rowchar><colchar> |
|
This sequence will generally not be understood by |
|
terminals that are not in vt52 mode even if higher |
|
modes are supported. |
|
|
|
} |
|
@values -min 2 -max 2 |
|
row -type integer -help\ |
|
"row number - starting at 1" |
|
col -type integer -help\ |
|
"column number - starting at 1" |
|
}] |
|
proc move {row col} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
return [punk::ansi::move $row $col] |
|
} else { |
|
return [punk::ansi::vt52move $row $col] |
|
} |
|
} |
|
proc move_forward {n} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
puts -nonewline stdout [punk::ansi::move_forward $n] |
|
} else { |
|
puts -nonewline stdout [punk::ansi::vt52move_forward $n] |
|
} |
|
} |
|
proc move_back {n} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
puts -nonewline stdout [punk::ansi::move_back $n] |
|
} else { |
|
puts -nonewline stdout [punk::ansi::vt52move_back $n] |
|
} |
|
} |
|
proc move_up {n} { |
|
puts -nonewline stdout [punk::ansi::move_up $n] |
|
} |
|
proc move_down {n} { |
|
puts -nonewline stdout [punk::ansi::move_down $n] |
|
} |
|
proc move_column {col} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
puts -nonewline stdout [punk::ansi::move_column $col] |
|
} else { |
|
puts -nonewline stdout [punk::ansi::vt52move_column $col] |
|
} |
|
} |
|
proc move_row {row} { |
|
puts -nonewline stdout [punk::ansi::move_row $row] |
|
} |
|
proc move_emit {row col data args} { |
|
upvar ::punk::console::is_v52 is_vt52 |
|
if {!$is_vt52} { |
|
puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] |
|
} else { |
|
puts -nonewline stdout [punk::ansi::v52move_emit $row $col $data {*}$args] |
|
} |
|
} |
|
proc move_emit_return {row col data args} { |
|
#todo detect if in raw mode or not? |
|
set is_in_raw 0 |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
|
|
set commands "" |
|
append commands [punk::ansi::move_emit $row $col $data {*}$args] |
|
foreach {row col data} $args { |
|
append commands [punk::ansi::move_emit $row $col $data {*}$args] |
|
} |
|
if {!$is_in_raw} { |
|
incr orig_row -1 |
|
} |
|
append commands [punk::ansi::move $orig_row $orig_col] |
|
puts -nonewline stdout $commands |
|
return "" |
|
} |
|
proc move_emitblock_return {row col textblock} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
|
|
set commands "" |
|
foreach ln [split $textblock \n] { |
|
append commands [punk::ansi::move_emit $row $col $ln] |
|
incr row |
|
} |
|
append commands [punk::ansi::move $orig_row $orig_col] |
|
puts -nonewline $commands |
|
return |
|
} |
|
#we can be (slightly?) faster and more efficient if we use the consoles cursor_save_dec command - but each savecursor overrides any previous one. |
|
#leave cursor_off/cursor_on to caller who can wrap more efficiently.. |
|
proc cursorsave_move_emit_return {row col data args} { |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
#JMN |
|
set commands "" |
|
if {!$is_vt52} { |
|
append commands [punk::ansi::cursor_save_dec] |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
foreach {row col data} $args { |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
} |
|
append commands [punk::ansi::cursor_restore_dec] |
|
} else { |
|
append commands [punk::ansi::cursor_save_vt52] |
|
append commands [punk::ansi::vt52move_emit $row $col $data] |
|
foreach {row col data} $args { |
|
append commands [punk::ansi::vt52move_emit $row $col $data] |
|
} |
|
append commands [punk::ansi::cursor_restore_vt52] |
|
} |
|
puts -nonewline stdout $commands; flush stdout |
|
} |
|
proc cursorsave_move_emitblock_return {row col textblock} { |
|
set commands "" |
|
upvar ::punk::console::is_vt52 is_vt52 |
|
if {!$is_vt52} { |
|
append commands [punk::ansi::cursor_save_dec] |
|
foreach ln [split $textblock \n] { |
|
append commands [punk::ansi::move_emit $row $col $ln] |
|
incr row |
|
} |
|
append commands [punk::ansi::cursor_restore_dec] |
|
} else { |
|
append commands [punk::ansi::cursor_save_vt52] |
|
foreach ln [split $textblock \n] { |
|
append commands [punk::ansi::vt52move_emit $row $col $ln] |
|
incr row |
|
} |
|
append commands [punk::ansi::cursor_restore_vt52] |
|
} |
|
puts -nonewline stdout $commands;flush stdout |
|
return |
|
} |
|
proc move_call_return {row col script} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
move $row $col |
|
uplevel 1 $script |
|
move $orig_row $orig_col |
|
} |
|
proc scroll_up {n} { |
|
puts -nonewline stdout [punk::ansi::scroll_up $n] |
|
} |
|
proc scroll_down {n} { |
|
puts -nonewline stdout [punk::ansi::scroll_down $n] |
|
} |
|
proc enable_alt_screen {} { |
|
puts -nonewline stdout [punk::ansi::enable_alt_screen] |
|
} |
|
proc disable_alt_screen {} { |
|
puts -nonewline stdout [punk::ansi::disable_alt_screen] |
|
} |
|
|
|
#review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress. |
|
#caller should build as much as possible using the punk::ansi versions to avoid extra puts calls |
|
proc cursor_save {} { |
|
#*** !doctools |
|
#[call [fun cursor_save]] |
|
puts -nonewline stdout \x1b\[s |
|
} |
|
proc cursor_restore {} { |
|
#*** !doctools |
|
#[call [fun cursor_restore]] |
|
puts -nonewline stdout \x1b\[u |
|
} |
|
#DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? |
|
proc cursor_save_dec {} { |
|
#*** !doctools |
|
#[call [fun cursor_save_dec]] |
|
puts -nonewline \x1b7 |
|
} |
|
proc cursor_restore_dec {} { |
|
#*** !doctools |
|
#[call [fun cursor_restore_dec]] |
|
puts -nonewline \x1b8 |
|
} |
|
|
|
proc insert_spaces {count} { |
|
puts -nonewline stdout \x1b\[${count}@ |
|
} |
|
proc delete_characters {count} { |
|
puts -nonewline \x1b\[${count}P |
|
} |
|
proc erase_characters {count} { |
|
puts -nonewline \x1b\[${count}X |
|
} |
|
proc insert_lines {count} { |
|
puts -nonewline \x1b\[${count}L |
|
} |
|
proc delete_lines {count} { |
|
puts -nonewline \x1b\[${count}M |
|
} |
|
proc titleset {windowtitle} { |
|
puts -nonewline stdout [punk::ansi::titleset $windowtitle] |
|
} |
|
proc test_decaln {} { |
|
puts -nonewline stdout [punk::ansi::test_decaln] |
|
} |
|
} |
|
namespace import ::punk::console::ansi::* |
|
catch {rename titleset ""} |
|
#namespace import ansi::titleset |
|
proc titleset {windowtitle} { |
|
variable ansi_wanted |
|
if { $ansi_wanted <= 0} { |
|
punk::console::local::titleset $windowtitle |
|
} else { |
|
ansi::titleset $windowtitle |
|
} |
|
} |
|
#no known pure-ansi solution |
|
proc titleget {} { |
|
return [local::titleget] |
|
} |
|
|
|
foreach ansicmd [list ::punk::console::ansi::move] { |
|
set ctail [namespace tail $ansicmd] |
|
set arglist [info args $ansicmd] |
|
set argcall "" |
|
if {[llength $arglist]} { |
|
foreach a [lrange $arglist 0 end-1] { |
|
append argcall "\$$a " |
|
} |
|
if {[lindex $arglist end] eq "args"} { |
|
append argcall {{*}$args} |
|
} else { |
|
append argcall "\$[lindex $arglist end]" |
|
} |
|
} |
|
catch {rename $ctail ""} |
|
proc $ctail $arglist [string map [list %ansicmd% $ansicmd %argcall% $argcall] { |
|
puts -nonewline [%ansicmd% %argcall%] |
|
}] |
|
} |
|
|
|
|
|
|
|
#experimental |
|
proc rhs_prompt {col text} { |
|
package require textblock |
|
lassign [textblock::size $text] _w tw _h th |
|
if {$th > 1} { |
|
#move up first.. need to know current line? |
|
} |
|
#set blanks [string repeat " " [expr {$col + $tw}]] |
|
#puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text |
|
#puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] |
|
cursor_save_dec |
|
#move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text |
|
#puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text |
|
puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text |
|
cursor_restore |
|
} |
|
|
|
#this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations? |
|
# ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries |
|
proc pick {row col} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
set test "" |
|
#set test [a green Yellow] |
|
move_emit $row $col $test\0337 |
|
puts -nonewline \0338\033\[${orig_row}\;${orig_col}H |
|
} |
|
proc pick_emit {row col data} { |
|
set test "" |
|
#set test [a green Purple] |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
move_emit $row $col $test\0337 |
|
puts -nonewline \0338\033\[${orig_row}\;${orig_col}H$data |
|
} |
|
|
|
# -- --- --- --- --- --- |
|
namespace eval clock { |
|
|
|
#map chars of chars "0" to "?"" ie 0x30 to x3f |
|
variable fontmap1 { |
|
7C CE DE F6 E6 C6 7C 00 |
|
30 70 30 30 30 30 FC 00 |
|
78 CC 0C 38 60 CC FC 00 |
|
78 CC 0C 38 0C CC 78 00 |
|
1C 3C 6C CC FE 0C 1E 00 |
|
FC C0 F8 0C 0C CC 78 00 |
|
38 60 C0 F8 CC CC 78 00 |
|
FC CC 0C 18 30 30 30 00 |
|
78 CC CC 78 CC CC 78 00 |
|
78 CC CC 7C 0C 18 70 00 |
|
00 18 18 00 00 18 18 00 |
|
00 18 18 00 00 18 18 30 |
|
18 30 60 C0 60 30 18 00 |
|
00 00 7E 00 7E 00 00 00 |
|
60 30 18 0C 18 30 60 00 |
|
3C 66 0C 18 18 00 18 00 |
|
} |
|
#libungif extras |
|
append fontmap1 { |
|
7c 82 9a aa aa 9e 7c 00 |
|
38 6c c6 c6 fe c6 c6 00 |
|
fc c6 c6 fc c6 c6 fc 00 |
|
} |
|
|
|
#https://github.com/Distrotech/libungif/blob/master/lib/gif_font.c |
|
variable fontmap { |
|
} |
|
#ascii row 0x00 to 0x1F control chars |
|
#(cp437 glyphs) |
|
append fontmap { |
|
00 00 00 00 00 00 00 00 |
|
3c 42 a5 81 bd 42 3c 00 |
|
3c 7e db ff c3 7e 3c 00 |
|
00 ee fe fe 7c 38 10 00 |
|
10 38 7c fe 7c 38 10 00 |
|
00 3c 18 ff ff 08 18 00 |
|
10 38 7c fe fe 10 38 00 |
|
00 00 18 3c 18 00 00 00 |
|
ff ff e7 c3 e7 ff ff ff |
|
00 3c 42 81 81 42 3c 00 |
|
ff c3 bd 7e 7e bd c3 ff |
|
1f 07 0d 7c c6 c6 7c 00 |
|
00 7e c3 c3 7e 18 7e 18 |
|
04 06 07 04 04 fc f8 00 |
|
0c 0a 0d 0b f9 f9 1f 1f |
|
00 92 7c 44 c6 7c 92 00 |
|
00 00 60 78 7e 78 60 00 |
|
00 00 06 1e 7e 1e 06 00 |
|
18 7e 18 18 18 18 7e 18 |
|
66 66 66 66 66 00 66 00 |
|
ff b6 76 36 36 36 36 00 |
|
7e c1 dc 22 22 1f 83 7e |
|
00 00 00 7e 7e 00 00 00 |
|
18 7e 18 18 7e 18 00 ff |
|
18 7e 18 18 18 18 18 00 |
|
18 18 18 18 18 7e 18 00 |
|
00 04 06 ff 06 04 00 00 |
|
00 20 60 ff 60 20 00 00 |
|
00 00 00 c0 c0 c0 ff 00 |
|
00 24 66 ff 66 24 00 00 |
|
00 00 10 38 7c fe 00 00 |
|
00 00 00 fe 7c 38 10 00 |
|
} |
|
#chars SP to "/" row 0x20 to 0x2f |
|
append fontmap { |
|
00 00 00 00 00 00 00 00 |
|
30 30 30 30 30 00 30 00 |
|
66 66 00 00 00 00 00 00 |
|
6c 6c fe 6c fe 6c 6c 00 |
|
10 7c d2 7c 86 7c 10 00 |
|
f0 96 fc 18 3e 72 de 00 |
|
30 48 30 78 ce cc 78 00 |
|
0c 0c 18 00 00 00 00 00 |
|
10 60 c0 c0 c0 60 10 00 |
|
10 0c 06 06 06 0c 10 00 |
|
00 54 38 fe 38 54 00 00 |
|
00 18 18 7e 18 18 00 00 |
|
00 00 00 00 00 00 18 70 |
|
00 00 00 7e 00 00 00 00 |
|
00 00 00 00 00 00 18 00 |
|
02 06 0c 18 30 60 c0 00 |
|
} |
|
#chars "0" to "?"" row 0x30 to 0x3f |
|
append fontmap { |
|
7c c6 c6 c6 c6 c6 7c 00 |
|
18 38 78 18 18 18 3c 00 |
|
7c c6 06 0c 30 60 fe 00 |
|
7c c6 06 3c 06 c6 7c 00 |
|
0e 1e 36 66 fe 06 06 00 |
|
fe c0 c0 fc 06 06 fc 00 |
|
7c c6 c0 fc c6 c6 7c 00 |
|
fe 06 0c 18 30 60 60 00 |
|
7c c6 c6 7c c6 c6 7c 00 |
|
7c c6 c6 7e 06 c6 7c 00 |
|
00 30 00 00 00 30 00 00 |
|
00 30 00 00 00 30 20 00 |
|
00 1c 30 60 30 1c 00 00 |
|
00 00 7e 00 7e 00 00 00 |
|
00 70 18 0c 18 70 00 00 |
|
7c c6 0c 18 30 00 30 00 |
|
} |
|
#chars "@" to "O" row 0x40 to 0x4f |
|
append fontmap { |
|
7c 82 9a aa aa 9e 7c 00 |
|
38 6c c6 c6 fe c6 c6 00 |
|
fc c6 c6 fc c6 c6 fc 00 |
|
7c c6 c6 c0 c0 c6 7c 00 |
|
f8 cc c6 c6 c6 cc f8 00 |
|
fe c0 c0 fc c0 c0 fe 00 |
|
fe c0 c0 fc c0 c0 c0 00 |
|
7c c6 c0 ce c6 c6 7e 00 |
|
c6 c6 c6 fe c6 c6 c6 00 |
|
78 30 30 30 30 30 78 00 |
|
1e 06 06 06 c6 c6 7c 00 |
|
c6 cc d8 f0 d8 cc c6 00 |
|
c0 c0 c0 c0 c0 c0 fe 00 |
|
c6 ee fe d6 c6 c6 c6 00 |
|
c6 e6 f6 de ce c6 c6 00 |
|
7c c6 c6 c6 c6 c6 7c 00 |
|
} |
|
#chars "P" to "_" row 0x50 to 0x5f |
|
append fontmap { |
|
fc c6 c6 fc c0 c0 c0 00 |
|
7c c6 c6 c6 c6 c6 7c 06 |
|
fc c6 c6 fc c6 c6 c6 00 |
|
78 cc 60 30 18 cc 78 00 |
|
fc 30 30 30 30 30 30 00 |
|
c6 c6 c6 c6 c6 c6 7c 00 |
|
c6 c6 c6 c6 c6 6c 38 00 |
|
c6 c6 c6 d6 fe ee c6 00 |
|
c6 c6 6c 38 6c c6 c6 00 |
|
c3 c3 66 3c 18 18 18 00 |
|
fe 0c 18 30 60 c0 fe 00 |
|
3c 30 30 30 30 30 3c 00 |
|
c0 60 30 18 0c 06 03 00 |
|
3c 0c 0c 0c 0c 0c 3c 00 |
|
00 38 6c c6 00 00 00 00 |
|
00 00 00 00 00 00 00 ff |
|
} |
|
#chars "`" to "o" row 0x60 to 0x6f |
|
append fontmap { |
|
30 30 18 00 00 00 00 00 |
|
00 00 7c 06 7e c6 7e 00 |
|
c0 c0 fc c6 c6 e6 dc 00 |
|
00 00 7c c6 c0 c0 7e 00 |
|
06 06 7e c6 c6 ce 76 00 |
|
00 00 7c c6 fe c0 7e 00 |
|
1e 30 7c 30 30 30 30 00 |
|
00 00 7e c6 ce 76 06 7c |
|
c0 c0 fc c6 c6 c6 c6 00 |
|
18 00 38 18 18 18 3c 00 |
|
18 00 38 18 18 18 18 f0 |
|
c0 c0 cc d8 f0 d8 cc 00 |
|
38 18 18 18 18 18 3c 00 |
|
00 00 cc fe d6 c6 c6 00 |
|
00 00 fc c6 c6 c6 c6 00 |
|
00 00 7c c6 c6 c6 7c 00 |
|
} |
|
#chars "p" to DEL row 0x70 to 0x7f |
|
append fontmap { |
|
00 00 fc c6 c6 e6 dc c0 |
|
00 00 7e c6 c6 ce 76 06 |
|
00 00 6e 70 60 60 60 00 |
|
00 00 7c c0 7c 06 fc 00 |
|
30 30 7c 30 30 30 1c 00 |
|
00 00 c6 c6 c6 c6 7e 00 |
|
00 00 c6 c6 c6 6c 38 00 |
|
00 00 c6 c6 d6 fe 6c 00 |
|
00 00 c6 6c 38 6c c6 00 |
|
00 00 c6 c6 ce 76 06 7c |
|
00 00 fc 18 30 60 fc 00 |
|
0e 18 18 70 18 18 0e 00 |
|
18 18 18 00 18 18 18 00 |
|
e0 30 30 1c 30 30 e0 00 |
|
00 00 70 9a 0e 00 00 00 |
|
00 00 18 3c 66 ff 00 00 |
|
} |
|
|
|
proc bigstr {str row col} { |
|
variable fontmap |
|
#curses attr off reverse |
|
#a noreverse |
|
set reverse 0 |
|
set output "" |
|
set charno 0 |
|
foreach char [split $str {}] { |
|
binary scan $char c f |
|
set index [expr {$f * 8}] |
|
for {set line 0} {$line < 8} {incr line} { |
|
set bitline 0x[lindex $fontmap [expr {$index + $line}]] |
|
binary scan [binary format c $bitline] B8 charline |
|
set cix 0 |
|
foreach c [split $charline {}] { |
|
if {$c} { |
|
append output [punk::ansi::move_emit [expr {$row + $line}] [expr {$col + $charno * 8 + $cix}] "[a+ reverse] [a+ noreverse]"] |
|
#curses attr on reverse |
|
#curses move [expr $row + $line] [expr $col + $charno * 8 + $cix] |
|
#curses puts " " |
|
} |
|
incr cix |
|
} |
|
} |
|
incr charno |
|
} |
|
return $output |
|
} |
|
proc get_time {} { |
|
overtype::left -width 70 "" [bigstr [clock format [clock seconds] -format %H:%M:%S] 1 1] |
|
} |
|
|
|
|
|
proc display1 {} { |
|
#punk::console::clear |
|
punk::console::move_call_return 20 20 {punk::console::clear_above} |
|
flush stdout |
|
punk::console::move_call_return 0 0 {puts stdout [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5]} |
|
after 2000 {punk::console::clock::display} |
|
} |
|
proc display {} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
punk::console::move 20 20 |
|
punk::console::clear_above |
|
punk::console::move 0 0 |
|
puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] |
|
|
|
punk::console::move $orig_row $orig_col |
|
#after 2000 {punk::console::clock::display} |
|
} |
|
|
|
proc displaystr {str} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
punk::console::move 20 20 |
|
punk::console::clear_above |
|
punk::console::move 0 0 |
|
puts -nonewline [bigstr $str 10 5] |
|
|
|
punk::console::move $orig_row $orig_col |
|
} |
|
|
|
|
|
} |
|
|
|
proc test {} { |
|
set high_unicode_length [string length \U00010000] |
|
set can_high_unicode 0 |
|
set can_regex_high_unicode 0 |
|
set can_terminal_report_dingbat_width 0 |
|
set can_terminal_report_diacritic_width 0 |
|
if {$high_unicode_length != 1} { |
|
puts stderr "punk::console WARNING: no modern unicode support in this Tcl version. High unicode values not properly supported. (string length \\U00010000 : $high_unicode_length should be 1)" |
|
} else { |
|
set can_high_unicode 1 |
|
set can_regex_high_unicode [string equal [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] |
|
if {!$can_regex_high_unicode} { |
|
puts stderr "punk::console warning: TCL version cannot perform braced regex of high unicode" |
|
} |
|
} |
|
set dingbat_heavy_plus_width [punk::console::test_char_width \U2795] ;#review - may be font dependent. We chose a wide dingbat as a glyph that is hopefully commonly renderable - and should display 2 wide. |
|
#This will give a false report that terminal can't report width if the glyph (or replacement glyph) is actually being rendered 1 wide. |
|
#we can't distinguish without user interaction? |
|
if {$dingbat_heavy_plus_width == 2} { |
|
set can_terminal_report_dingbat_width 1 |
|
} else { |
|
puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." |
|
} |
|
set diacritic_width [punk::console::test_char_width a\u0300] |
|
if {$diacritic_width == 1} { |
|
set can_terminal_report_diacritic_width 1 |
|
} else { |
|
puts stderr "punk::console warning: terminal unable to report diacritic width properly." |
|
} |
|
|
|
if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { |
|
set result [list result ok] |
|
} else { |
|
set result [list result error] |
|
} |
|
return $result |
|
} |
|
#run the test and allow warnings to be emitted to stderr on package load. User should know the terminal and/or Tcl version are not optimal for unicode character work |
|
#set testresult [test1] |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::console ---}] |
|
} |
|
|
|
namespace eval punk::console::check { |
|
variable has_bug_legacysymbolwidth -1 ;#undetermined |
|
proc has_bug_legacysymbolwidth {} { |
|
#some terminals (on windows as at 2024) miscount width of these single-width blocks internally |
|
#resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) |
|
#This was fixed in windows-terminal based systems (2021) but persists in others. |
|
#https://github.com/microsoft/terminal/issues/11694 |
|
variable has_bug_legacysymbolwidth |
|
if {!$has_bug_legacysymbolwidth} { |
|
return 0 |
|
} |
|
if {$has_bug_legacysymbolwidth == -1} { |
|
#run the test using ansi movement |
|
#we only test a specific character from the known problematic set |
|
set w [punk::console::test_char_width \U1fb7d] |
|
if {$w == 1} { |
|
set has_bug_legacysymbolwidth 0 |
|
} else { |
|
#can return 2 on legacy window consoles for example |
|
set has_bug_legacysymbolwidth 1 |
|
} |
|
return $has_bug_legacysymbolwidth |
|
} |
|
return 1 |
|
} |
|
variable has_bug_zwsp -1 ;#undetermined |
|
proc has_bug_zwsp {} { |
|
#Note that some terminals behave differently regarding a leading zwsp vs one that is inline between other chars. |
|
#we are only testing the inline behaviour here. |
|
variable has_bug_zwsp |
|
if {!$has_bug_zwsp} { |
|
return 0 |
|
} |
|
if {$has_bug_zwsp == -1} { |
|
set w [punk::console::test_char_width X\u200bY] |
|
} |
|
if {$w == 2} { |
|
return 0 |
|
} else { |
|
#may return 3 - but this gives no indication of whether terminal hides it or not. |
|
return 1 |
|
} |
|
return 1 |
|
} |
|
|
|
} |
|
|
|
|
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::console ::punk::console::internal ::punk::console::local ::punk::console::ansi |
|
} |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::console [namespace eval punk::console { |
|
variable version |
|
set version 0.1.1 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end]
|
|
|