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.
6210 lines
295 KiB
6210 lines
295 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.6.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::console 0 0.6.0] |
|
#[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- |
|
|
|
#---------------------------------------------------- |
|
#Although we need to be in an environment with Thread available to use punk::console, |
|
# we don't want to require Thread as a hard dependency in the interp we're running in. |
|
# We should be able to provide wrappers such that thread features we need can be used via aliases into the current interp. |
|
#TODO. |
|
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] |
|
|
|
|
|
|
|
#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 |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set has_twapi [expr {! [catch {package require twapi}]}] |
|
} |
|
|
|
|
|
variable previous_stty_state_stdin "" |
|
variable previous_stty_state_stdout "" |
|
variable previous_stty_state_stderr "" |
|
|
|
#variable is_raw 0 |
|
if {![tsv::exists punk_console is_raw]} { |
|
tsv::set punk_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 perform 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 * |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
#non-colour SGR codes |
|
set I "\x1b\[3m" ;# [a+ italic] |
|
set NI "\x1b\[23m" ;# [a+ noitalic] |
|
set B "\x1b\[1m" ;# [a+ bold] |
|
set N "\x1b\[22m" ;# [a+ normal] |
|
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
|
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
|
interp alias "" ::overtype::example "" ::punk::args::helpers::example |
|
} |
|
|
|
#Shared option-definition fragment for the emit-side console functions. |
|
#Not a command - referenced from PUNKARGS definitions via: |
|
# ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
punk::args::define { |
|
@id -id ::punk::console::argdoc::console_emit_opts |
|
@cmd -name punk::console::argdoc::console_emit_opts -help\ |
|
"Definition fragment (not a command). |
|
Provides the -console option documentation for the emit-side console functions." |
|
@opts |
|
-console -type list -default {stdin stdout} -help\ |
|
"Console specification: a 2-element {in out} channel list, an anchored |
|
opunk::console instance name, or an ::opunk::Console object value. |
|
Emitted output is written to the resolved console's output channel." |
|
} |
|
#As above, with neutral wording for the query/set functions (mode queries, DECRQSS, |
|
#cursor style etc) whose -console governs both the query emission and the response read. |
|
punk::args::define { |
|
@id -id ::punk::console::argdoc::console_opts |
|
@cmd -name punk::console::argdoc::console_opts -help\ |
|
"Definition fragment (not a command). |
|
Provides the -console option documentation for the console query/set functions." |
|
@opts |
|
-console -type list -default {stdin stdout} -help\ |
|
"Console specification: a 2-element {in out} channel list, an anchored |
|
opunk::console instance name, or an ::opunk::Console object value." |
|
} |
|
|
|
|
|
|
|
|
|
#review - document and decide granularity required. should we enable/disable more than one at once? |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::enable_mouse |
|
@cmd -name punk::console::enable_mouse -summary "Emit sequences enabling terminal mouse reporting." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc enable_mouse {args} { |
|
#see PUNKARGS id ::punk::console::enable_mouse |
|
set out [internal::opt_console_out $args] |
|
puts -nonewline $out \x1b\[?1000h\x1b\[?1003h\x1b\[?1015h\x1b\[?1006h |
|
flush $out |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::disable_mouse |
|
@cmd -name punk::console::disable_mouse -summary "Emit sequences disabling terminal mouse reporting." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc disable_mouse {args} { |
|
#see PUNKARGS id ::punk::console::disable_mouse |
|
set out [internal::opt_console_out $args] |
|
puts -nonewline $out \x1b\[?1000l\x1b\[?1003l\x1b\[?1015l\x1b\[?1006l |
|
flush $out |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::enable_mouse_sgr |
|
@cmd -name punk::console::enable_mouse_sgr -summary "Emit sequences enabling SGR-encoded mouse reporting." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc enable_mouse_sgr {args} { |
|
#see PUNKARGS id ::punk::console::enable_mouse_sgr |
|
set out [internal::opt_console_out $args] |
|
puts -nonewline $out \x1b\[?1000h\x1b\[?1003h\x1b\[?1016h |
|
flush $out |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::disable_mouse_sgr |
|
@cmd -name punk::console::disable_mouse_sgr -summary "Emit sequences disabling SGR-encoded mouse reporting." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc disable_mouse_sgr {args} { |
|
#see PUNKARGS id ::punk::console::disable_mouse_sgr |
|
set out [internal::opt_console_out $args] |
|
puts -nonewline $out \x1b\[?1000l\x1b\[?1003l\x1b\[?1016l |
|
flush $out |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::enable_bracketed_paste |
|
@cmd -name punk::console::enable_bracketed_paste -summary "Emit sequence enabling bracketed paste mode." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc enable_bracketed_paste {args} { |
|
#see PUNKARGS id ::punk::console::enable_bracketed_paste |
|
puts -nonewline [internal::opt_console_out $args] \x1b\[?2004h |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::disable_bracketed_paste |
|
@cmd -name punk::console::disable_bracketed_paste -summary "Emit sequence disabling bracketed paste mode." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc disable_bracketed_paste {args} { |
|
#see PUNKARGS id ::punk::console::disable_bracketed_paste |
|
puts -nonewline [internal::opt_console_out $args] \x1b\[?2004l |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::start_application_mode |
|
@cmd -name punk::console::start_application_mode -summary "Emit sequences entering alt-screen application mode with mouse and bracketed paste." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc start_application_mode {args} { |
|
#see PUNKARGS id ::punk::console::start_application_mode |
|
#need loop to read events? |
|
set out [internal::opt_console_out $args] |
|
puts -nonewline $out \x1b\[?1049h ;#alt screen |
|
enable_mouse {*}$args |
|
#puts -nonewline $out \x1b\[?25l ;#hide cursor |
|
puts -nonewline $out \x1b\[?1003h\n |
|
enable_bracketed_paste {*}$args |
|
} |
|
#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 punk_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 { |
|
|
|
#The emit-side console functions accept an optional trailing '-console <consolespec>' |
|
#pair, parsed manually for performance (their PUNKARGS definitions are documentation-only). |
|
#opt_console_out_var/opt_console_channels_var strip that pair from the caller's args |
|
#variable if present, returning the resolved output channel or canonical {in out} pair. |
|
#(safe for tails that otherwise hold row/col/data triples - a well-formed triple never has |
|
#the literal '-console' in its 2nd-last position) |
|
#The non-var forms additionally require that nothing else remains in the tail. |
|
punk::args::define { |
|
@id -id ::punk::console::internal::opt_console_out_var |
|
@cmd -name punk::console::internal::opt_console_out_var -summary\ |
|
"Strip a trailing '-console <consolespec>' pair from the named args variable, returning the resolved output channel."\ |
|
-help\ |
|
"The variable named by argsvar in the caller's frame is modified in place (the |
|
-console pair is removed if present; other content such as row/col/data triples |
|
is left alone). Returns stdout when no -console pair is present." |
|
@leaders |
|
argsvar -type string -help\ |
|
"Name of an args-tail list variable in the caller's frame." |
|
@values -min 0 -max 0 |
|
} |
|
proc opt_console_out_var {argsvar} { |
|
#see PUNKARGS id ::punk::console::internal::opt_console_out_var |
|
upvar 1 $argsvar tail |
|
if {[llength $tail] >= 2 && [lindex $tail end-1] eq "-console"} { |
|
set out [dict get [punk::console::console_spec_resolve [lindex $tail end]] out] |
|
set tail [lrange $tail 0 end-2] |
|
return $out |
|
} |
|
return stdout |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::opt_console_channels_var |
|
@cmd -name punk::console::internal::opt_console_channels_var -summary\ |
|
"Strip a trailing '-console <consolespec>' pair from the named args variable, returning the canonical {in out} channel pair."\ |
|
-help\ |
|
"The variable named by argsvar in the caller's frame is modified in place (the |
|
-console pair is removed if present; other content such as row/col/data triples |
|
is left alone). Returns {stdin stdout} when no -console pair is present." |
|
@leaders |
|
argsvar -type string -help\ |
|
"Name of an args-tail list variable in the caller's frame." |
|
@values -min 0 -max 0 |
|
} |
|
proc opt_console_channels_var {argsvar} { |
|
#see PUNKARGS id ::punk::console::internal::opt_console_channels_var |
|
upvar 1 $argsvar tail |
|
if {[llength $tail] >= 2 && [lindex $tail end-1] eq "-console"} { |
|
set cinfo [punk::console::console_spec_resolve [lindex $tail end]] |
|
set tail [lrange $tail 0 end-2] |
|
return [list [dict get $cinfo in] [dict get $cinfo out]] |
|
} |
|
return {stdin stdout} |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::opt_console_out |
|
@cmd -name punk::console::internal::opt_console_out -summary\ |
|
"Resolve an emit-function args-tail (empty or exactly '-console <consolespec>') to an output channel."\ |
|
-help\ |
|
"Errors if the tail contains anything other than a single optional -console pair. |
|
Returns stdout for an empty tail." |
|
@leaders |
|
argstail -type list -help\ |
|
"The args-tail value: {} or {-console <consolespec>}." |
|
@values -min 0 -max 0 |
|
} |
|
proc opt_console_out {argstail} { |
|
#see PUNKARGS id ::punk::console::internal::opt_console_out |
|
set out [opt_console_out_var argstail] |
|
if {[llength $argstail]} { |
|
error "expected optional trailing '-console <consolespec>' - got '$argstail'" |
|
} |
|
return $out |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::opt_console_channels |
|
@cmd -name punk::console::internal::opt_console_channels -summary\ |
|
"Resolve an emit-function args-tail (empty or exactly '-console <consolespec>') to a canonical {in out} channel pair."\ |
|
-help\ |
|
"Errors if the tail contains anything other than a single optional -console pair. |
|
Returns {stdin stdout} for an empty tail." |
|
@leaders |
|
argstail -type list -help\ |
|
"The args-tail value: {} or {-console <consolespec>}." |
|
@values -min 0 -max 0 |
|
} |
|
proc opt_console_channels {argstail} { |
|
#see PUNKARGS id ::punk::console::internal::opt_console_channels |
|
set channels [opt_console_channels_var argstail] |
|
if {[llength $argstail]} { |
|
error "expected optional trailing '-console <consolespec>' - got '$argstail'" |
|
} |
|
return $channels |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::hybrid_console_spec |
|
@cmd -name punk::console::internal::hybrid_console_spec -summary\ |
|
"Resolve a get_size-style hybrid args-tail (?consolespec? or -console <consolespec>) to the console specification."\ |
|
-help\ |
|
"Used by the query functions that accept the legacy trailing positional |
|
console specification as well as the -console option form. Returns the |
|
spec unresolved (callers pass it downstream or resolve as needed); |
|
{stdin stdout} for an empty tail." |
|
@leaders |
|
argstail -type list |
|
procname -type string -help\ |
|
"caller name for error messages" |
|
@values -min 0 -max 0 |
|
} |
|
proc hybrid_console_spec {argstail procname} { |
|
#see PUNKARGS id ::punk::console::internal::hybrid_console_spec |
|
switch -exact -- [llength $argstail] { |
|
0 { |
|
return {stdin stdout} |
|
} |
|
1 { |
|
return [lindex $argstail 0] ;#legacy positional - accepts any console spec form |
|
} |
|
2 { |
|
if {[lindex $argstail 0] eq "-console"} { |
|
return [lindex $argstail 1] |
|
} |
|
} |
|
} |
|
error "$procname: expected ?consolespec? or -console <consolespec> - got '$argstail'" |
|
} |
|
|
|
proc abort_if_loop {{failmsg ""}} { |
|
#obsolete |
|
#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 {} { |
|
|
|
|
|
|
|
|
|
} |
|
|
|
|
|
#we have punk::args as a requirement at the top of this module |
|
#so we can use punk::args::define instead of lappend PUNKARGS |
|
#we do this here because this can be called before the PUNKARGS definitions have been processed. |
|
punk::args::define { |
|
@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" |
|
|
|
-console -default {stdin stdout} -type list -help\ |
|
"Console specification: a 2-element {in out} channel list, an anchored |
|
opunk::console instance name, or an ::opunk::Console object value. |
|
An object with settled can_respond 0 causes an immediate error |
|
rather than emitting a query that cannot be answered." |
|
-passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels { |
|
none |
|
{ ANSI sent without any passthrough wrapping. |
|
A terminal multiplexer such as tmux,screen,zellij may |
|
not pass the request through to the underlying terminal(s) |
|
This is the recommended/normal value for the option.} |
|
tmux |
|
{ Wrap ANSI sequence with tmux passthrough sequence. |
|
\x1bPtmux\;<originalsequence_with_escapes_doubled>\x1b\\ |
|
Note that a tmux session could be connected to multiple |
|
terminals (perhaps of different types) - in which case multiple |
|
responses may be received in a non-deterministic order. |
|
Passthrough should generally be avoided except for debug/test |
|
purposes. |
|
} |
|
auto |
|
{ Use existence of ::env(TMUX) to detect tmux and |
|
send tmux passthrough sequence. |
|
Not recommended except for debug/test purposes. |
|
} |
|
} |
|
#todo - allow setting this default from a global config variable. |
|
-expected_ms -default 500 -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. |
|
Some terminals may require a longer timeout." |
|
@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 -cache 1 withid ::punk::console::internal::get_ansi_response_payload] |
|
lassign [dict values $argd] leaders opts values received |
|
|
|
set inoutchannels [dict get $opts -console] |
|
set expected [dict get $opts -expected_ms] |
|
set ignoreok [dict get $opts -ignoreok] |
|
set returntype [dict get $opts -return] |
|
set passthrough [dict get $opts -passthrough] |
|
set query [dict get $values query] |
|
set capturingendregex [dict get $values capturingendregex] |
|
|
|
#-console accepts a channel pair, an anchored opunk::console instance name, or an |
|
#::opunk::Console object value - resolve to the canonical channel pair (and object if any) |
|
set consolespec $inoutchannels |
|
set cinfo [punk::console::console_spec_resolve $inoutchannels] |
|
set inoutchannels [list [dict get $cinfo in] [dict get $cinfo out]] |
|
lassign $inoutchannels input output |
|
set governing_obj [dict get $cinfo object] |
|
if {$governing_obj ne ""} { |
|
set governing_cr [::opunk::Console::get.o_can_respond $governing_obj] |
|
if {$governing_cr == -1 && !$::punk::console::can_respond_settling} { |
|
#first-use active settling so unsettled ambiguous consoles pay one probe rather |
|
#than a fresh timeout per query. Persistable specs only (anchored instance name, |
|
#or the auto-attached default instance) - the latch prevents recursion when the |
|
#settle probe itself passes through here. |
|
if {[llength $consolespec] == 1 || ([info exists ::opunk::console::instances::default] && $governing_obj eq [set ::opunk::console::instances::default])} { |
|
set governing_cr [punk::console::settle_can_respond $consolespec] |
|
} |
|
} |
|
if {$governing_cr == 0} { |
|
error "punk::console::get_ansi_response_payload console object for '$input' '$output' is settled as unable to respond (can_respond=0) - refusing to emit query" |
|
} |
|
} |
|
|
|
#A closed or eof input channel can never deliver a terminal response - fail fast rather than |
|
#emitting the query and waiting for a reply that cannot arrive (e.g piped/redirected stdin that |
|
#has already been consumed). Deliberately only tests certainty of failure (with a probe read for |
|
#deferred pipe eof) - a pipe that is still open could be mintty without winpty presenting a |
|
#terminal's stdin as a pipe (see is_input_console_or_tty) |
|
if {[::punk::console::input_at_eof $input]} { |
|
error "punk::console::get_ansi_response_payload input channel '$input' is closed or at eof - cannot receive terminal response" |
|
} |
|
|
|
#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 - possibly 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)" |
|
|
|
|
|
#Only cycle raw mode when the input channel is actually a console/tty. |
|
#enableRaw/disableRaw operate on the REAL process console (twapi/stty) regardless of the |
|
#channel arg - cycling it for a query on unrelated channels (e.g pipe-pair probes from |
|
#settle_can_respond) flips the user's console mode as a side effect, and repeated cycles |
|
#have been observed to deadlock under stacked/captured channel environments (runtests runx). |
|
#For mintty-without-winpty (terminal presenting pipes) the twapi raw cycle was already a |
|
#no-op via its get_console_handle early-return, so nothing is lost by skipping. |
|
set input_is_console_or_tty [expr {[dict exists $previous_input_state -inputmode] || [dict exists $previous_input_state -mode]}] |
|
if {![tsv::get punk_console is_raw]} { |
|
set was_raw 0 |
|
if {$input_is_console_or_tty} { |
|
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 |
|
|
|
switch -- $passthrough { |
|
auto { |
|
if {[info exists ::env(TMUX)]} { |
|
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" |
|
} |
|
} |
|
tmux { |
|
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\" |
|
} |
|
} |
|
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? |
|
#first read will read 3 bytes JJJJ |
|
$this_handler $input $callid $capturingendregex |
|
#JJJJ |
|
#$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 && $input_is_console_or_tty} { |
|
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 $input is at eof here, we deliberately take no action - a failed query returns |
|
#empty/timeout to the caller and the active reader will discover the eof through its |
|
#normal read path (repl::start ends with done='eof <chan>' and the application layer |
|
#e.g app-punkshell PUNK_PIPE_EOF policy decides between exit and console reopen). |
|
#Restarting the repl from inside this low-level query primitive caused re-entrancy |
|
#and bypassed that policy. |
|
} |
|
} |
|
#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 $input is at eof here, we deliberately take no action (previously an erroneous repl |
|
#restart was attempted from this branch). A failed query returns empty/timeout to the caller; |
|
#the repl reader discovers the eof through its normal read path and the application layer |
|
#(e.g app-punkshell PUNK_PIPE_EOF policy) owns the exit-vs-console-reopen decision. |
|
} |
|
# ------------------------------------------------------------------------------------- |
|
|
|
|
|
|
|
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 $ |
|
if {[string length $chunks($callid)] == 0} { |
|
set status [catch {read $chan 3} bytes] |
|
} else { |
|
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_idalias ::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 |
|
#string generation has no console context - reads the default console's vt52 fact (legacy variable) |
|
variable is_vt52 |
|
if {$is_vt52} { |
|
return |
|
} else { |
|
::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 |
|
} |
|
} |
|
|
|
#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 |
|
#colour off is more specific - it only stops SGR colour codes from being generated - but underlines/bold/reverse will still be generated. |
|
#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]} { |
|
if {$onoff eq "default"} { |
|
set ansi_wanted 2 |
|
catch {punk::repl::reset_prompt} |
|
return |
|
} |
|
if {![string is boolean -strict $onoff]} { |
|
error "punk::console::ansi expected a boolean e.g 0|1|on|off|true|false|yes|no" |
|
} |
|
if {$onoff} { |
|
set ansi_wanted 1 |
|
} else { |
|
set ansi_wanted 0 |
|
punk::ansi::sgr_cache -action clear |
|
} |
|
catch {punk::repl::reset_prompt} |
|
} |
|
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off (except bold/underline/reverse which are controlled by 'ansi' command)" |
|
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 |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::vt52 |
|
@cmd -name punk::console::vt52 -summary "Query or set vt52 terminal mode." |
|
@leaders |
|
onoff -type boolean -optional 1 -help\ |
|
"Omit to query the current vt52 state. |
|
The vt52 state is a per-console fact (see console_fact_get); the process-default |
|
console's state is mirrored in the legacy ::punk::console::is_vt52 variable." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc vt52 {args} { |
|
#see PUNKARGS id ::punk::console::vt52 |
|
#todo - return to colour state beforehand?. support 0-15 vt52 colours? (ATARI and some emulators - not original vt52) |
|
#we shouldn't have to turn off colour to enter vt52 - we should make punk::console emit correct codes |
|
set onoff "" |
|
if {[llength $args] % 2 == 1} { |
|
set onoff [lindex $args 0] |
|
set args [lrange $args 1 end] |
|
} |
|
set inout [internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
set is_vt52 [console_fact_get $inout 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 $out "\x1b<" |
|
console_fact_set $inout is_vt52 0 |
|
colour on ;#colour state is process-global (gates string generation) - review |
|
} |
|
} else { |
|
if {$onoff} { |
|
dec_unset_mode -console $inout DECANM |
|
console_fact_set $inout is_vt52 1 |
|
colour off ;#colour state is process-global (gates string generation) - review |
|
} else { |
|
puts -nonewline $out "\x1b<" |
|
#emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ |
|
} |
|
} |
|
return [console_fact_get $inout 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 -cache 1 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 |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
-expected_ms -type integer -default 500 -help\ |
|
"Number of ms to wait for response" |
|
|
|
# -mincap 3 -maxcap 3 validates that regex has exactly 3 capturing groups. |
|
-capture -type regex -default {(((.*)))$} -mincap 3 -maxcap 3 -help\ |
|
"Regex to capture response with. |
|
- must have 3 capturing groups to capture prefix, payload and entire response. |
|
The regex is applied repeatedly to the input until a match is found or timeout occurs. |
|
|
|
The default regex captures the entire response without differentiating prefix or payload |
|
- this is useful for debugging and for queries where we don't know what the response will look like. |
|
" |
|
@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 -console] |
|
set passthrough [dict get $opts -passthrough] |
|
set expected [dict get $opts -expected_ms] |
|
#set capturingregex {(((.*)))$} ;#capture entire response same as response-payload |
|
set capturingregex [dict get $opts -capture] |
|
|
|
set ts_start [clock millis] |
|
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -console $inoutchannels -passthrough $passthrough $request $capturingregex] |
|
set ts_end [clock millis] |
|
|
|
set outchan [lindex $inoutchannels 1] |
|
set out "" |
|
|
|
#for the default capturing regexp; prefix,payload,response and all will be the same because our capturingregex is not specific to the query. |
|
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 |
|
#These accept the get_size-style hybrid tail: an optional legacy positional console |
|
#specification, or -console <consolespec> (see internal::hybrid_console_spec). |
|
# -- --- --- --- --- --- --- |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_cursor_pos |
|
@cmd -name punk::console::get_cursor_pos -summary\ |
|
"Query cursor position (CSI 6n) - returns the raw 'row;col' payload."\ |
|
-help\ |
|
"NOTE: argument parsing is manual for performance - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_cursor_pos {args} { |
|
#see PUNKARGS id ::punk::console::get_cursor_pos |
|
set inoutchannels [internal::hybrid_console_spec $args get_cursor_pos] |
|
if {[console_fact_get $inoutchannels 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 |
|
|
|
#This is all 'tput u7' does (emits CSI 6n on stdout) |
|
set request "\033\[6n" |
|
set payload [punk::console::internal::get_ansi_response_payload -console $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 |
|
} |
|
|
|
|
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_checksum_rect |
|
@cmd -name punk::console::get_checksum_rect -summary\ |
|
"Query rectangular area checksum (DECRQCRA)."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@leaders |
|
id -type integer -help "request id (echoed in the response)" |
|
page -type integer |
|
t -type integer -help "top row" |
|
l -type integer -help "left column" |
|
b -type integer -help "bottom row" |
|
r -type integer -help "right column" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_checksum_rect {id page t l b r args} { |
|
#see PUNKARGS id ::punk::console::get_checksum_rect |
|
set inoutchannels [internal::hybrid_console_spec $args get_checksum_rect] |
|
#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 -console $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_device_status |
|
@cmd -name punk::console::get_device_status -summary\ |
|
"Query device status (DSR 5n) - a 0 payload indicates OK."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_device_status {args} { |
|
#see PUNKARGS id ::punk::console::get_device_status |
|
set inoutchannels [internal::hybrid_console_spec $args get_device_status] |
|
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 -console $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 |
|
# |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_device_attributes |
|
@cmd -name punk::console::get_device_attributes -summary\ |
|
"Query primary device attributes (DA1) - the payload is recorded as the console's last_da1_result fact."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_device_attributes {args} { |
|
#see PUNKARGS id ::punk::console::get_device_attributes |
|
set inoutchannels [internal::hybrid_console_spec $args get_device_attributes] |
|
#Note the vt52 rough equivalen \x1bZ - commonly supported but probably best considered obsolete as it collides with ECMA 48 SCI Single Character Introducer |
|
#DA1 |
|
#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 -console $inoutchannels $request $capturingregex] |
|
console_fact_set $inoutchannels last_da1_result $payload |
|
return $payload |
|
} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_device_attributes_secondary |
|
@cmd -name punk::console::get_device_attributes_secondary\ |
|
-summary\ |
|
{Query terminal for secondary device attributes}\ |
|
-help\ |
|
{Query terminal secondary device attributes by sending to the console |
|
the sequence: |
|
ESC [ > c |
|
|
|
The terminal should respond with a sequence like: |
|
ESC [ > 61;1;0c |
|
Where the |
|
first parameter is the terminal's architectural class, and the |
|
second parameter is often a version indicator, and the |
|
third parameters is 0 or 1 to indicate (indicates std keyboard vs pc keyboard) |
|
The keyboard paramter is largely obsolete and most modern virtual terminals just report 0 here |
|
- but physical terminals may use it. |
|
|
|
This is not cached, as a terminal's device emulation mode may change during a session, and some |
|
terminals may reflect that in their reported secondary device attributes. |
|
|
|
See also: |
|
- punk::console::classify_device_attributes_secondary |
|
- punk::console::class_info |
|
|
|
- punk::console::get_device_attributes |
|
- punk::console::get_device_attributes_tertiary |
|
- punk::console::ansi_modes |
|
- punk::console::dec_modes |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
} |
|
#see : https://vt100.net/docs/vt510-rm/DA2.html |
|
#see also: https://github.com/mintty/utils/blob/master/terminal |
|
proc get_device_attributes_secondary {args} { |
|
#parse without punk::args::parse for performance and so it can be used prior to punk::args being available |
|
#(sometimes gets called before this package has fully loaded and registered its argspecs) |
|
#---------------------------------------- |
|
set defaults [dict create {*}{ |
|
-console {stdin stdout} |
|
}] |
|
set opts [dict merge $defaults $args] |
|
for {set i 0} {$i < [llength $args]} {incr i} { |
|
set a [lindex $args $i] |
|
if {[string match -* $a]} { |
|
set fullopt [tcl::prefix::match -error "" [dict keys $defaults] $a] |
|
if {[dict exists $defaults $fullopt]} { |
|
set value [lindex $args [expr {$i + 1}]] |
|
dict set opts $fullopt $value |
|
incr i |
|
} else { |
|
error "Unknown option '$a'" |
|
} |
|
} else { |
|
error "Unexpected argument '$a'" |
|
} |
|
} |
|
#---------------------------------------- |
|
set inoutchannels [dict get $opts -console] |
|
#DA2 |
|
set capturingregex {(.*)(\x1b\[\>([0-9]*[;][0-9]*[;][0-1])c)$} ;#must capture prefix,entire-response,response-payload |
|
#expect eg 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 -console $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::classify_device_attributes_secondary |
|
@cmd -name punk::console::classify_device_attributes_secondary\ |
|
-summary\ |
|
{Parse and classify the response payload from get_device_attributes_secondary into a dict}\ |
|
-help\ |
|
{Parse and classify the response payload from get_device_attributes_secondary into a dict with keys: |
|
- class |
|
- version |
|
- keyboard |
|
- notes |
|
- raw |
|
|
|
The class is a human friendly indicator of the terminal's architectural class |
|
e.g vt100, vt240,vt510 etc |
|
The version is often a software version indicator for modern virtual terminals |
|
but may be a firmware version for physical terminals. |
|
The keyboard value will be std (0) for most modern virtual terminals, but may be pc (1) for some physical terminals. |
|
The notes field may contain any additional information or context about the terminal's capabilities or quirks that |
|
can be inferred from the class, version, and keyboard values. |
|
The raw field is a list of the raw values for class, version and keyboard respectively. |
|
|
|
If a friendly name is not known for any of the values, the string "unknown" is used instead of the value. |
|
For some known combinations of class and version, the class may be overridden with a more specific name, |
|
and notes may be added to provide additional context. |
|
|
|
The response from get_device_attributes_secondary is expected to be in the format: |
|
class;version;keyboard |
|
Where: |
|
- class is the terminal's architectural class (e.g. 61, 62, 63, 64) |
|
- version is often a version indicator (e.g. 1, 2, 10, 20) |
|
- keyboard is 0 or 1 to indicate (indicates std keyboard vs pc keyboard) |
|
The keyboard parameter is largely obsolete and most modern virtual terminals just report 0 here, but physical terminals may use it. |
|
|
|
see also: |
|
- punk::console::get_device_attributes_secondary |
|
- punk::console::class_info |
|
} |
|
@values -min 1 -max 1 |
|
attributestring -type string -help\ |
|
{The response payload from get_device_attributes_secondary to parse and classify, |
|
expected in the format class;version;keyboard e.g 61;1;0 |
|
(will also accept raw response with leading ESC[> and trailing c if present, but these are not required)} |
|
}] |
|
} |
|
proc classify_device_attributes_secondary {attributestring} { |
|
#regexp vs string match - both need to escape square brackets. |
|
# string match "\x1b\\\[>*c" |
|
# regexp {^\x1b\[>.*c$} |
|
if {[string match "\x1b\\\[>*c" $attributestring]} { |
|
#strip leading ESC[> and trailing c if present |
|
set attributestring [string range $attributestring 3 end-1] |
|
} |
|
set parts [split $attributestring ";"] |
|
if {[llength $parts] != 3} { |
|
error "Unexpected response format - expected 3 semicolon-separated values for class;version;keyboard. got: '$attributestring'" |
|
} |
|
set class [lindex $parts 0] |
|
set version [lindex $parts 1] |
|
set keyboard [lindex $parts 2] |
|
set notes "" |
|
|
|
|
|
#info for class_name is based on the way mintty operates. |
|
switch -- $class { |
|
0 { |
|
set class_name "VT100" |
|
switch -- $version { |
|
10 { |
|
set class_name "winconsole" |
|
#we don't report 'windows' as this is confusing given that the version is reported as 10 - but this has nothing to do with the windows os version. |
|
set notes "windows reporting vt100 (other terminals such as putty connected to windows openssh (windows-pty) sshd, or mintty using winpty may also report this)" |
|
} |
|
95 { |
|
set class_name "tmux" |
|
set notes "tmux reporting VT100" |
|
} |
|
115 { |
|
set class_name "KDE-konsole" |
|
set notes "KDE-konsole reporting VT100" |
|
} |
|
136 { |
|
set class_name "PuTTY" |
|
set notes "PuTTY reporting VT100" |
|
} |
|
304 { |
|
set class_name "VT125" |
|
} |
|
} |
|
|
|
|
|
} |
|
1 { |
|
set class_name "VT200" |
|
switch -- $version { |
|
2 { |
|
set class_name "openwin-xterm" |
|
set notes "openwin xterm reporting vt200" |
|
} |
|
96 { |
|
set class_name "mlterm" |
|
set notes "mlterm reporting vt200" |
|
} |
|
304 { |
|
set class_name "VT241/VT382" |
|
} |
|
1115 { |
|
set class_name "gnome-terminal" |
|
set notes "gnome-terminal reporting vt200" |
|
} |
|
default { |
|
if {$version > 2000} { |
|
set class_name "gnome-terminal" |
|
set notes "gnome-terminal reporting vt200 (version > 2000)" |
|
} |
|
} |
|
} |
|
} |
|
2 {set class_name "VT240"} |
|
24 {set class_name "VT320"} |
|
28 {set class_name "DECterm"} |
|
18 {set class_name "VT330"} |
|
19 {set class_name "VT340"} |
|
41 {set class_name "VT420"} |
|
61 {set class_name "VT510"} |
|
64 {set class_name "VT520"} |
|
65 {set class_name "VT525"} |
|
67 {set class_name "cygwin"} |
|
77 {set class_name "mintty"} |
|
82 {set class_name "rxvt"} |
|
83 {set class_name "screen"} |
|
84 { |
|
set class_name "tmux" |
|
set version 200 |
|
} |
|
85 {set class_name "rxvt-unicode"} |
|
|
|
default {set class_name "unknown"} |
|
} |
|
|
|
#return version as-is. |
|
|
|
#map keyboard value to friendly name |
|
switch -- $keyboard { |
|
0 {set keyboard_name "std"} |
|
1 {set keyboard_name "pc"} |
|
default {set keyboard_name "unknown"} |
|
} |
|
|
|
return [dict create {*}{ |
|
} class $class_name {*}{ |
|
} version $version {*}{ |
|
} keyboard $keyboard_name {*}{ |
|
} notes $notes {*}{ |
|
} raw $parts {*}{ |
|
} |
|
] |
|
} |
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::class_info |
|
@cmd -name punk::console::class_info\ |
|
-summary\ |
|
{Query terminal secondary device attributes, parse and classify}\ |
|
-help\ |
|
{Query terminal secondary device attributes by sending to the console |
|
the sequence: |
|
ESC [ > c |
|
and then pass the payload through classify_device_attributes_secondary to |
|
return a dict of information about the terminal. |
|
|
|
The results are parsed into a dict with keys: |
|
- class |
|
- version |
|
- keyboard |
|
- notes |
|
- raw |
|
|
|
See also: |
|
- punk::console::get_device_attributes_secondary |
|
- punk::console::classify_device_attributes_secondary |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
} |
|
proc class_info {args} { |
|
#set argd [punk::args::parse $args withid ::punk::console::class_info] |
|
#lassign [dict values $argd] leaders opts values received |
|
#---------------------------------------- |
|
set defaults [dict create {*}{ |
|
-console {stdin stdout} |
|
}] |
|
set opts [dict merge $defaults $args] |
|
for {set i 0} {$i < [llength $args]} {incr i} { |
|
set a [lindex $args $i] |
|
if {[string match -* $a]} { |
|
set fullopt [tcl::prefix::match -error "" [dict keys $defaults] $a] |
|
if {[dict exists $defaults $fullopt]} { |
|
set value [lindex $args [expr {$i + 1}]] |
|
dict set opts $fullopt $value |
|
incr i |
|
} else { |
|
error "Unknown option '$a'" |
|
} |
|
} else { |
|
error "Unexpected argument '$a'" |
|
} |
|
} |
|
#---------------------------------------- |
|
set inoutchannels [dict get $opts -console] |
|
|
|
set da2_response [get_device_attributes_secondary -console $inoutchannels] |
|
set parsed [classify_device_attributes_secondary $da2_response] |
|
return $parsed |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_device_attributes_tertiary |
|
@cmd -name punk::console::get_device_attributes_tertiary -summary\ |
|
"Query tertiary device attributes (DA3) - terminal unit id."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_device_attributes_tertiary {args} { |
|
#see PUNKARGS id ::punk::console::get_device_attributes_tertiary |
|
set inoutchannels [internal::hybrid_console_spec $args get_device_attributes_tertiary] |
|
#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 -console $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_terminal_id |
|
@cmd -name punk::console::get_terminal_id -summary\ |
|
"Alias for get_device_attributes_tertiary (DA3)."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_terminal_id {args} { |
|
#see PUNKARGS id ::punk::console::get_terminal_id |
|
#DA3 - alias |
|
get_device_attributes_tertiary {*}$args |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_tabstops |
|
@cmd -name punk::console::get_tabstops -summary\ |
|
"Query tabstop columns (DECTABSR) - returns the list of tabstop column numbers."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_tabstops {args} { |
|
#see PUNKARGS id ::punk::console::get_tabstops |
|
set inoutchannels [internal::hybrid_console_spec $args get_tabstops] |
|
#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 -console $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 |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_tabstop_apparent_width |
|
@cmd -name punk::console::get_tabstop_apparent_width -summary\ |
|
"Determine apparent tabstop spacing (DECTABSR, falling back to test_char_width, then 8)."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_tabstop_apparent_width {args} { |
|
#see PUNKARGS id ::punk::console::get_tabstop_apparent_width |
|
set inoutchannels [internal::hybrid_console_spec $args get_tabstop_apparent_width] |
|
set tslist [get_tabstops $inoutchannels] |
|
if {![llength $tslist]} { |
|
#either terminal failed to report - or none set. |
|
set testw [test_char_width \t -console $inoutchannels] |
|
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 -console $inoutchannels] |
|
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 |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::set_tabstop_width |
|
@cmd -name punk::console::set_tabstop_width -summary "Emit sequences setting evenly spaced terminal tabstops." |
|
@leaders |
|
w -type integer -default 8 -optional 1 -help\ |
|
"Tabstop spacing in character cells. |
|
The tabwidth record is a per-console fact (see console_fact_get); the process-default |
|
console's record is mirrored in the legacy ::punk::console::tabwidth variable." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc set_tabstop_width {args} { |
|
#see PUNKARGS id ::punk::console::set_tabstop_width |
|
set w 8 |
|
if {[llength $args] % 2 == 1} { |
|
set w [lindex $args 0] |
|
set args [lrange $args 1 end] |
|
} |
|
set inout [internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
set tsize [get_size $inout] |
|
set width [dict get $tsize columns] |
|
set mod [expr {$width % $w}] |
|
set max [expr {$width - $mod}] |
|
set tstop_ansi "" |
|
set c 1 |
|
while {$c <= $max} { |
|
append tstop_ansi [string repeat " " $w][punk::ansi::set_tabstop] |
|
incr c $w |
|
} |
|
console_fact_set $inout 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 $out "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstop_ansi" |
|
} |
|
|
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_cursor_pos_list |
|
@cmd -name punk::console::get_cursor_pos_list -summary\ |
|
"Query cursor position (CSI 6n) - returns {row col}."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_cursor_pos_list {args} { |
|
#see PUNKARGS id ::punk::console::get_cursor_pos_list |
|
return [split [get_cursor_pos {*}$args] ";"] |
|
} |
|
|
|
#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 |
|
|
|
punk::args::define { |
|
@id -id ::punk::console::cell_size |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@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::parse $args -cache 1 withid ::punk::console::cell_size] |
|
set terminal [dict get $argd opts -console] |
|
set newsize [dict get $argd values newsize] |
|
|
|
#cell_size is a per-console fact (the default console's record is mirrored in the legacy |
|
#::punk::console::cell_size variable via console_fact_set) |
|
set cinfo [console_spec_resolve $terminal] |
|
set inout [list [dict get $cinfo in] [dict get $cinfo out]] |
|
set cell_size [console_fact_get $inout 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 $terminal] |
|
lassign $pixeldict _w sw _h sh |
|
if {[string is integer -strict $sw] && [string is integer -strict $sh]} { |
|
lassign [punk::console::get_size $terminal] _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} |
|
console_fact_set $inout cell_size $cell_size |
|
return $cell_size |
|
} else { |
|
set cell_size $::punk::console::cell_size_fallback |
|
console_fact_set $inout cell_size $cell_size |
|
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::console::cell_size error - expected format WxH where W and H are positive integers - got '$newsize'" |
|
} |
|
console_fact_set $inout 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" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@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::parse $args -cache 1 withid ::punk::console::test_is_vt52] |
|
set inoutchannels [dict get $argd opts -console] |
|
#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 -console $inoutchannels $request $capturingregex] |
|
#puts -->$payload<-- |
|
return [expr {$payload in {Z K M}}] |
|
} |
|
|
|
#todo - determine cursor on/off state before the call to restore properly. |
|
variable get_size_mechanism |
|
set get_size_mechanism [dict create] |
|
|
|
#Determine with certainty whether an input channel is closed or at eof (and so can never deliver |
|
#a terminal response). A pipe that has been fully consumed/half-closed may not have its eof flag set |
|
#until a read is attempted - so for pipe-like channels a non-blocking 1-byte probe read is performed. |
|
#Any byte consumed by the probe is preserved in ::punk::console::input_chunks_waiting($input) for |
|
#cooperating readers (repl etc). |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::input_at_eof |
|
@cmd -name punk::console::input_at_eof -summary\ |
|
"Determine with certainty whether an input channel is closed/at eof (probe read for deferred pipe eof; probed bytes preserved in input_chunks_waiting)."\ |
|
-help\ |
|
"NOTE: plain positional signature - this definition is documentation." |
|
@values -min 0 -max 1 |
|
input -type string -default stdin -optional 1 -help\ |
|
"Input channel name." |
|
}] |
|
proc input_at_eof {{input stdin}} { |
|
#see PUNKARGS id ::punk::console::input_at_eof |
|
if {[catch {chan eof $input} is_eof]} { |
|
return 1 ;#closed/invalid channel - unusable |
|
} |
|
if {$is_eof} { |
|
return 1 |
|
} |
|
if {[catch {chan configure $input} conf]} { |
|
return 1 |
|
} |
|
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
|
#console/tty - not subject to the deferred-eof pipe situation, and we must not consume a |
|
#pending keystroke with a probe read here. |
|
return 0 |
|
} |
|
#pipe-like channel - probe without blocking to force eof detection |
|
if {[catch { |
|
set prior_blocking [dict get $conf -blocking] |
|
chan configure $input -blocking 0 |
|
set probe [read $input 1] |
|
chan configure $input -blocking $prior_blocking |
|
}]} { |
|
return 1 |
|
} |
|
if {$probe ne ""} { |
|
upvar ::punk::console::input_chunks_waiting input_chunks_waiting |
|
lappend input_chunks_waiting($input) $probe |
|
} |
|
return [chan eof $input] |
|
} |
|
|
|
#Best effort determination of whether an input channel could be connected to a terminal able to |
|
#answer ANSI queries (cursor position reports etc). |
|
#Returns 0 only when reasonably confident it cannot: channel closed/at eof (probed), or no console/tty |
|
#indicators and no terminal-suggesting environment hints. |
|
#Note: mintty without winpty (e.g git bash) presents a terminal's stdin as a pipe with no -inputmode, |
|
#so absence of console/tty indicators alone must not be treated as 'not a terminal'. Environment hints |
|
#(MSYSTEM, TERM_PROGRAM) are used to avoid false negatives there, at the cost of false positives in |
|
#environments that inherit such vars with genuinely piped (but still open) input - those paths still |
|
#rely on the ANSI query timeout mechanisms rather than hanging indefinitely. |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::is_input_console_or_tty |
|
@cmd -name punk::console::is_input_console_or_tty -summary\ |
|
"Best-effort test whether an input channel could be a terminal able to answer ANSI queries (0 only when reasonably certain it cannot)."\ |
|
-help\ |
|
"NOTE: plain positional signature - this definition is documentation." |
|
@values -min 0 -max 1 |
|
input -type string -default stdin -optional 1 -help\ |
|
"Input channel name." |
|
}] |
|
proc is_input_console_or_tty {{input stdin}} { |
|
#see PUNKARGS id ::punk::console::is_input_console_or_tty |
|
if {[catch {chan configure $input} conf]} { |
|
return 0 |
|
} |
|
if {[dict exists $conf -inputmode]} { |
|
#windows console (and some other terminal environments) |
|
return 1 |
|
} |
|
if {[dict exists $conf -mode]} { |
|
#tty on unix-like platforms |
|
return 1 |
|
} |
|
if {[input_at_eof $input]} { |
|
return 0 |
|
} |
|
if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { |
|
#possibly mintty (or similar) without winpty - terminal presenting channels as pipes |
|
return 1 |
|
} |
|
return 0 |
|
} |
|
|
|
#Resolve a console specification to its channel pair and (optionally) governing object. |
|
#Accepted forms: |
|
# 2-element list - {in out} channel pair (legacy/primitive form) |
|
# 1-element value - name of an anchored opunk::console instance |
|
# >=7 element list - an ::opunk::Console (or subclass) object value (voo) |
|
#Returns dict: in <chan> out <chan> object <objectvalue-or-empty-string> |
|
#The opunk::console package is only required for the name/object forms (lazy - punk::console |
|
#itself must remain loadable without opunk::console; voo is now in bootsupport via |
|
#include_modules.config but opunk::console is not, and channel-pair-only callers should not |
|
#pay any object-layer load cost). |
|
proc console_spec_resolve {spec} { |
|
switch -exact -- [llength $spec] { |
|
2 { |
|
set in [lindex $spec 0] |
|
set out [lindex $spec 1] |
|
#auto-attach the process-default console object (anchored opunk::console instance |
|
#'default' - normally constructed during repl::init) when it governs this channel pair, |
|
#so all query sites benefit from its settled facts without explicitly passing it. |
|
#info exists on the anchor variable is cheap and requires no package load. |
|
if {[info exists ::opunk::console::instances::default]} { |
|
set dobj [set ::opunk::console::instances::default] |
|
if {[::opunk::Console::in $dobj] eq $in && [::opunk::Console::out $dobj] eq $out} { |
|
return [dict create in $in out $out object $dobj] |
|
} |
|
} |
|
return [dict create in $in out $out object ""] |
|
} |
|
1 { |
|
if {[catch {package require opunk::console} errM]} { |
|
error "console_spec_resolve: spec '$spec' looks like an anchored console instance name but package opunk::console is unavailable ($errM)" |
|
} |
|
ensure_object_integration |
|
set obj [opunk::console::instance $spec] |
|
return [dict create in [::opunk::Console::in $obj] out [::opunk::Console::out $obj] object $obj] |
|
} |
|
default { |
|
if {[llength $spec] >= 7} { |
|
set tag [lindex $spec 0] |
|
if {![catch {package require opunk::console}] && ![catch {voo::isVooClass $tag} isclass] && $isclass} { |
|
ensure_object_integration |
|
return [dict create in [::opunk::Console::in $spec] out [::opunk::Console::out $spec] object $spec] |
|
} |
|
} |
|
error "console_spec_resolve: unrecognised console specification '$spec' - expected {in out} channel pair, anchored opunk::console instance name, or ::opunk::Console object value" |
|
} |
|
} |
|
} |
|
|
|
#Return the name of the anchored process-default console instance (creating it for {stdin stdout} |
|
#if it doesn't yet exist), or empty string if opunk::console is unavailable. |
|
#The default console is normally constructed - and its can_respond settled where safely possible - |
|
#during repl::init. console_spec_resolve auto-attaches it for matching channel pairs. |
|
proc default_console {} { |
|
if {[info exists ::opunk::console::instances::default]} { |
|
#instance exists => opunk::console is loaded - ensure integration wiring applies |
|
ensure_object_integration |
|
#the instance may predate the lifecycle-hook wiring (or opunk::console may be an |
|
#older version without it) - make sure the default console has a registered owner |
|
if {[console_owner_get {stdin stdout}] eq ""} { |
|
console_owner_register {stdin stdout} |
|
} |
|
return default |
|
} |
|
if {[catch {package require opunk::console}]} { |
|
return "" |
|
} |
|
ensure_object_integration |
|
opunk::console::create default stdin stdout |
|
if {[console_owner_get {stdin stdout}] eq ""} { |
|
console_owner_register {stdin stdout} |
|
} |
|
return default |
|
} |
|
|
|
# -- --- --- --- --- --- --- |
|
#Per-console facts (G-007 location transparency; originated as interim store for G-001/G-002). |
|
#Facts that are properties of a particular terminal (vt52 mode, tabwidth, cell size, quirk |
|
#test results, DA1 response) are keyed by the console's canonical {in out} channel pair and |
|
#stored in tsv (shared array 'punk_console_facts') so every thread of the process reads the |
|
#same values with no RPC. Infrastructure tsv arrays are punk_-prefixed: tsv names are |
|
#process-global and subshell application code may use tsv for its own purposes. |
|
#The process-default console {stdin stdout} keeps the legacy namespace variables |
|
#(::punk::console::is_vt52, tabwidth, cell_size, last_da1_result, grapheme_cluster_support, |
|
#::punk::console::check::has_bug_*) as its authoritative local storage, so external readers |
|
#AND writers of those variables (punk::repl, textblock, overtype, punk::ansi, punk::ns, test |
|
#suites) continue to work. Write traces on those variables (installed at the end of this |
|
#module) mirror every write - including direct variable writes that bypass console_fact_set - |
|
#into tsv, where non-owner threads read them. Which context may treat the legacy variables as |
|
#authoritative is decided by the console ownership registry below (unregistered = every |
|
#context is local, preserving single-interp behaviour exactly). |
|
#Non-default consoles store facts only in tsv, with the key qualified by the owner context |
|
#(registry owner, else the calling thread) because non-std channel *names* are thread-local - |
|
#two threads can each have a channel named e.g sock10 referring to different consoles, and an |
|
#unqualified key would alias them. |
|
#Deliberately NOT stored here (process-global): |
|
# - ansi_wanted/colour_disabled - they gate string *generation* (code_a+ etc) where the |
|
# eventual output console is unknown |
|
# - ansi_available - determined via the real process console (twapi); object consoles carry |
|
# their own settled can_respond capability instead |
|
# - tsv punk_console is_raw and the enableRaw/disableRaw family - raw mode is a property of the |
|
# real attached console; get_ansi_response_payload already guards against cycling it for |
|
# non-console channels |
|
variable console_fact_info |
|
set console_fact_info [dict create {*}{ |
|
is_vt52 {legacyvar ::punk::console::is_vt52 default 0} |
|
tabwidth {legacyvar ::punk::console::tabwidth default 8} |
|
cell_size {legacyvar ::punk::console::cell_size default ""} |
|
last_da1_result {legacyvar ::punk::console::last_da1_result default ""} |
|
grapheme_cluster_support {legacyvar ::punk::console::grapheme_cluster_support default {}} |
|
has_bug_legacysymbolwidth {legacyvar ::punk::console::check::has_bug_legacysymbolwidth default -1} |
|
has_bug_zwsp {legacyvar ::punk::console::check::has_bug_zwsp default -1} |
|
}] |
|
|
|
# -- --- --- --- --- --- --- |
|
#Console ownership registry (G-007). |
|
#Exactly one context can own an input channel's reader and the process console's raw mode - |
|
#operations on a console you do not own must be brokered to the owner. This registry records |
|
#which thread that is, per console, keyed by canonical {in out} channel pair in tsv (shared |
|
#array 'punk_console_owners') so any thread can consult it. |
|
#Ownership is captured at registration time: the context anchoring an opunk::console instance |
|
#is recorded via the ::opunk::console lifecycle callback (wired by ensure_object_integration), |
|
#and default_console registers the default console {stdin stdout} - in a punk session that |
|
#happens in the repl thread during repl::init. Re-registration (last anchor wins) is |
|
#deliberate: ownership is process topology, not a terminal fact, and consoles can be handed |
|
#between contexts. Consult-time liveness validation clears entries whose owning thread has |
|
#exited, recovering lifecycle cohesion when forget was never called. |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_owner_register |
|
@cmd -name punk::console::console_owner_register -summary\ |
|
"Record the owning thread for a console in the process-wide ownership registry."\ |
|
-help\ |
|
"The owner is the context whose reader/raw-mode arbitration governs the console - |
|
operations from other contexts consult the registry to route to it. Normally called |
|
automatically when an opunk::console instance is anchored (and by default_console); |
|
direct calls are for consoles managed without the object layer. Re-registration |
|
overwrites (last anchor wins). Returns the recorded owner thread id." |
|
@values -min 1 -max 2 |
|
consolespec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
ownerthread -type string -optional 1 -help\ |
|
"Thread id of the owning thread (as returned by thread::id in that thread). |
|
Defaults to the calling thread." |
|
}] |
|
proc console_owner_register {consolespec {ownerthread ""}} { |
|
#see PUNKARGS id ::punk::console::console_owner_register |
|
set pair [internal::spec_to_channelpair $consolespec] |
|
if {$ownerthread eq ""} { |
|
set ownerthread [thread::id] |
|
} |
|
tsv::set punk_console_owners $pair $ownerthread |
|
return $ownerthread |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_owner_get |
|
@cmd -name punk::console::console_owner_get -summary\ |
|
"Return the registered owning thread id for a console, or empty string."\ |
|
-help\ |
|
"Returns empty string when the console is unregistered - callers treat that as |
|
'operate locally' so single-interp (non-repl) usage is unaffected by the registry. |
|
Owner liveness is validated at consult time: a registry entry whose thread no longer |
|
exists is cleared and reported as unregistered." |
|
@values -min 1 -max 1 |
|
consolespec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
}] |
|
proc console_owner_get {consolespec} { |
|
#see PUNKARGS id ::punk::console::console_owner_get |
|
set pair [internal::spec_to_channelpair $consolespec] |
|
if {![tsv::get punk_console_owners $pair owner]} { |
|
return "" |
|
} |
|
if {[catch {thread::exists $owner} alive] || !$alive} { |
|
#stale entry - owning thread has exited (or recorded handle is invalid) |
|
catch {tsv::unset punk_console_owners $pair} |
|
return "" |
|
} |
|
return $owner |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_owner_forget |
|
@cmd -name punk::console::console_owner_forget -summary\ |
|
"Remove a console's entry from the ownership registry."\ |
|
-help\ |
|
"Normally called automatically when the anchored opunk::console instance is |
|
forgotten. A forgotten console reads as unregistered (operate locally)." |
|
@values -min 1 -max 1 |
|
consolespec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
}] |
|
proc console_owner_forget {consolespec} { |
|
#see PUNKARGS id ::punk::console::console_owner_forget |
|
set pair [internal::spec_to_channelpair $consolespec] |
|
if {[tsv::exists punk_console_owners $pair]} { |
|
tsv::unset punk_console_owners $pair |
|
} |
|
return |
|
} |
|
# -- --- --- --- --- --- --- |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_fact_get |
|
@cmd -name punk::console::console_fact_get -summary\ |
|
"Read a per-console fact for the specified console."\ |
|
-help\ |
|
"Facts for the process-default console {stdin stdout} are read from the legacy |
|
namespace variables in the console's owning context (or any context when |
|
unregistered), and from their tsv mirror elsewhere; other consoles use the tsv |
|
store keyed by owner-qualified canonical channel pair. |
|
Returns the fact's default when nothing has been recorded for the console." |
|
@values -min 2 -max 2 |
|
consolespec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
key -type string -choices {is_vt52 tabwidth cell_size last_da1_result grapheme_cluster_support has_bug_legacysymbolwidth has_bug_zwsp} |
|
}] |
|
proc console_fact_get {consolespec key} { |
|
#see PUNKARGS id ::punk::console::console_fact_get |
|
variable console_fact_info |
|
set consolespec [internal::spec_to_channelpair $consolespec] |
|
if {[lindex $consolespec 0] eq "stdin" && [lindex $consolespec 1] eq "stdout"} { |
|
if {[internal::is_default_console_context]} { |
|
return [set [dict get $console_fact_info $key legacyvar]] |
|
} |
|
#another context owns the default console - its legacy-variable writes (traced) are |
|
#mirrored in tsv |
|
if {[tsv::get punk_console_facts [list {} stdin stdout $key] mirrored]} { |
|
return $mirrored |
|
} |
|
#nothing mirrored yet - this context's own legacy variable holds the module default |
|
return [set [dict get $console_fact_info $key legacyvar]] |
|
} |
|
if {[tsv::get punk_console_facts [internal::console_fact_key $consolespec $key] val]} { |
|
return $val |
|
} |
|
return [dict get $console_fact_info $key default] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_fact_set |
|
@cmd -name punk::console::console_fact_set -summary\ |
|
"Record a per-console fact for the specified console."\ |
|
-help\ |
|
"Facts for the process-default console {stdin stdout} are stored in the legacy |
|
namespace variables (visible to their external readers) with a traced tsv mirror; |
|
a write from a context that does not own the default console is forwarded to the |
|
owning thread so the owner's legacy variables stay authoritative. Other consoles |
|
use the tsv store keyed by owner-qualified canonical channel pair. Returns the |
|
value." |
|
@values -min 3 -max 3 |
|
consolespec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
key -type string -choices {is_vt52 tabwidth cell_size last_da1_result grapheme_cluster_support has_bug_legacysymbolwidth has_bug_zwsp} |
|
value -type any |
|
}] |
|
proc console_fact_set {consolespec key value} { |
|
#see PUNKARGS id ::punk::console::console_fact_set |
|
variable console_fact_info |
|
set consolespec [internal::spec_to_channelpair $consolespec] |
|
if {[lindex $consolespec 0] eq "stdin" && [lindex $consolespec 1] eq "stdout"} { |
|
set owner [console_owner_get {stdin stdout}] |
|
if {$owner eq "" || $owner eq [thread::id]} { |
|
#this context is authoritative - the write trace mirrors the value to tsv |
|
set [dict get $console_fact_info $key legacyvar] $value |
|
} else { |
|
#keep this thread's own legacy variable current for its local readers |
|
#(the write trace does not mirror from a non-owner context) |
|
set [dict get $console_fact_info $key legacyvar] $value |
|
#apply the write in the owning thread so the owner's legacy variables (its |
|
#authoritative local store) stay in sync - safe while the owner services |
|
#events, as the repl thread does while a codethread executes (the established |
|
#vt52-alias transport). thread::send executes in the target thread's MAIN |
|
#interp (where a punk session's console-owning punk::console lives); routing |
|
#for nested/child interps is the interp-alias layer of G-007, not this path. |
|
catch {thread::send $owner [list ::punk::console::console_fact_set [list stdin stdout] $key $value]} |
|
#ensure the tsv mirror holds the value regardless of the send outcome: the |
|
#owner's write trace mirrors it with a current punk::console, but the owner |
|
#may be unreachable, have no punk::console in its main interp, or run an |
|
#older punk::console that accepts the write without mirroring (idempotent |
|
#when the trace already did it) |
|
tsv::set punk_console_facts [list {} stdin stdout $key] $value |
|
} |
|
} else { |
|
tsv::set punk_console_facts [internal::console_fact_key $consolespec $key] $value |
|
} |
|
return $value |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_fact_clear |
|
@cmd -name punk::console::console_fact_clear -summary\ |
|
"Clear all recorded facts for the specified console."\ |
|
-help\ |
|
"For the process-default console {stdin stdout} every fact is re-recorded at its |
|
module default (via console_fact_set, so ownership forwarding and the tsv mirror |
|
apply); for other consoles the recorded tsv entries are removed so subsequent |
|
reads fall back to the fact defaults. Primarily for tests and maintenance." |
|
@values -min 1 -max 1 |
|
consolespec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
}] |
|
proc console_fact_clear {consolespec} { |
|
#see PUNKARGS id ::punk::console::console_fact_clear |
|
variable console_fact_info |
|
set consolespec [internal::spec_to_channelpair $consolespec] |
|
if {[lindex $consolespec 0] eq "stdin" && [lindex $consolespec 1] eq "stdout"} { |
|
dict for {key finfo} $console_fact_info { |
|
console_fact_set $consolespec $key [dict get $finfo default] |
|
} |
|
} else { |
|
dict for {key finfo} $console_fact_info { |
|
set tsvkey [internal::console_fact_key $consolespec $key] |
|
if {[tsv::exists punk_console_facts $tsvkey]} { |
|
tsv::unset punk_console_facts $tsvkey |
|
} |
|
} |
|
} |
|
return |
|
} |
|
|
|
namespace eval internal { |
|
#Helpers for the per-console fact store and ownership registry (G-007). |
|
punk::args::define { |
|
@id -id ::punk::console::internal::spec_to_channelpair |
|
@cmd -name punk::console::internal::spec_to_channelpair -summary\ |
|
"Resolve any console spec form to its canonical {in out} channel pair."\ |
|
-help\ |
|
"2-element specs are already canonical and returned as-is (no object-layer |
|
cost); instance-name and object-value specs resolve via console_spec_resolve." |
|
@values -min 1 -max 1 |
|
spec -type list -help\ |
|
"Console specification: {in out} channel pair, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
} |
|
proc spec_to_channelpair {spec} { |
|
#see PUNKARGS id ::punk::console::internal::spec_to_channelpair |
|
if {[llength $spec] != 2} { |
|
set cinfo [punk::console::console_spec_resolve $spec] |
|
return [list [dict get $cinfo in] [dict get $cinfo out]] |
|
} |
|
return $spec |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::is_default_console_context |
|
@cmd -name punk::console::internal::is_default_console_context -summary\ |
|
"True when the calling thread may treat the default-console legacy variables as authoritative."\ |
|
-help\ |
|
"True when the calling thread is the registered owner of the default console |
|
{stdin stdout}, or when no owner is registered (single-interp/non-repl usage |
|
behaves exactly as before the ownership registry existed)." |
|
@values -min 0 -max 0 |
|
} |
|
proc is_default_console_context {} { |
|
#see PUNKARGS id ::punk::console::internal::is_default_console_context |
|
set owner [punk::console::console_owner_get {stdin stdout}] |
|
return [expr {$owner eq "" || $owner eq [thread::id]}] |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::console_share_qualifier |
|
@cmd -name punk::console::internal::console_share_qualifier -summary\ |
|
"Owner qualifier used in shared (tsv) store keys for a canonical channel pair."\ |
|
-help\ |
|
"Empty string for the process-default console {stdin stdout} (std channels are |
|
process-wide names). For other consoles: the registered owner thread, else the |
|
calling thread - non-std channel names are thread-local, so unqualified keys |
|
would alias distinct consoles that happen to share a channel name across |
|
threads." |
|
@values -min 1 -max 1 |
|
inoutchannels -type list -help\ |
|
"Canonical {in out} channel pair." |
|
} |
|
proc console_share_qualifier {inoutchannels} { |
|
#see PUNKARGS id ::punk::console::internal::console_share_qualifier |
|
if {[lindex $inoutchannels 0] eq "stdin" && [lindex $inoutchannels 1] eq "stdout"} { |
|
return "" |
|
} |
|
set owner [punk::console::console_owner_get $inoutchannels] |
|
if {$owner ne ""} { |
|
return $owner |
|
} |
|
return [thread::id] |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::console_fact_key |
|
@cmd -name punk::console::internal::console_fact_key -summary\ |
|
"tsv key for a fact of a non-default console: {qualifier in out factkey}." |
|
@values -min 2 -max 2 |
|
inoutchannels -type list -help\ |
|
"Canonical {in out} channel pair." |
|
key -type string -help\ |
|
"Fact key (as accepted by console_fact_get/console_fact_set)." |
|
} |
|
proc console_fact_key {inoutchannels key} { |
|
#see PUNKARGS id ::punk::console::internal::console_fact_key |
|
return [list [console_share_qualifier $inoutchannels] [lindex $inoutchannels 0] [lindex $inoutchannels 1] $key] |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::default_fact_write_trace |
|
@cmd -name punk::console::internal::default_fact_write_trace -summary\ |
|
"Variable write-trace callback mirroring default-console legacy fact variables to tsv."\ |
|
-help\ |
|
"Installed at module load on each legacy fact variable so every write - including |
|
direct variable writes that bypass console_fact_set - is visible to other |
|
threads. Only mirrors when the calling context is authoritative for the default |
|
console (a non-owner thread's hollow copies of the variables must not clobber |
|
the owner's values)." |
|
@leaders |
|
key -type string -help\ |
|
"Fact key the traced variable stores." |
|
legacyvar -type string -help\ |
|
"Fully qualified name of the traced legacy variable." |
|
@values -min 0 -max 3 |
|
traceargs -type any -optional 1 -multiple 1 -help\ |
|
"name1 name2 op appended by the trace mechanism (unused)." |
|
} |
|
proc default_fact_write_trace {key legacyvar args} { |
|
#see PUNKARGS id ::punk::console::internal::default_fact_write_trace |
|
if {[is_default_console_context]} { |
|
tsv::set punk_console_facts [list {} stdin stdout $key] [set $legacyvar] |
|
} |
|
} |
|
punk::args::define { |
|
@id -id ::punk::console::internal::object_console_lifecycle |
|
@cmd -name punk::console::internal::object_console_lifecycle -summary\ |
|
"opunk::console lifecycle callback maintaining the console ownership registry."\ |
|
-help\ |
|
"Registered as ::opunk::console::lifecycle_callback by ensure_object_integration. |
|
The context anchoring a console instance is recorded as that console's owner; |
|
forgetting the instance clears the entry. For the process-default console |
|
{stdin stdout} the first registration wins: anchored instances are per-thread, |
|
so a second thread anchoring the std channels is creating a local view of the |
|
already-owned console, not taking over its reader. Non-std channel names are |
|
thread-local, so for other pairs each anchor is a genuinely distinct console |
|
and the latest registration wins." |
|
@values -min 3 -max 3 |
|
event -type string -choices {created forgotten} -help\ |
|
"Lifecycle event." |
|
name -type string -help\ |
|
"Anchored instance name (unused - ownership is keyed by channel pair)." |
|
channels -type list -help\ |
|
"Canonical {in out} channel pair of the instance." |
|
} |
|
proc object_console_lifecycle {event name channels} { |
|
#see PUNKARGS id ::punk::console::internal::object_console_lifecycle |
|
switch -exact -- $event { |
|
created { |
|
if {[lindex $channels 0] eq "stdin" && [lindex $channels 1] eq "stdout"} { |
|
if {[punk::console::console_owner_get $channels] ne ""} { |
|
return |
|
} |
|
} |
|
punk::console::console_owner_register $channels |
|
} |
|
forgotten { |
|
if {[lindex $channels 0] eq "stdin" && [lindex $channels 1] eq "stdout"} { |
|
#only the owner's forget releases the default console - a non-owner |
|
#thread forgetting its local anchor view must not clear the entry |
|
set owner [punk::console::console_owner_get $channels] |
|
if {$owner ne "" && $owner ne [thread::id]} { |
|
return |
|
} |
|
} |
|
punk::console::console_owner_forget $channels |
|
} |
|
} |
|
return |
|
} |
|
} |
|
# -- --- --- --- --- --- --- |
|
|
|
#default timeout for the active can_respond settling probe (see settle_can_respond) |
|
#short enough not to stall first use badly on non-responding consoles - long enough for real |
|
#terminals (incl. moderate ssh latency) to answer a cursor position report. |
|
variable can_respond_probe_timeout_ms |
|
if {![info exists can_respond_probe_timeout_ms]} { |
|
set can_respond_probe_timeout_ms 500 |
|
} |
|
#latch: true while settle_can_respond's own probe is in flight, so get_ansi_response_payload's |
|
#first-use settling trigger cannot recurse into another settle |
|
variable can_respond_settling |
|
if {![info exists can_respond_settling]} { |
|
set can_respond_settling 0 |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::console::settle_can_respond |
|
@cmd -name punk::console::settle_can_respond -summary\ |
|
"Actively settle a console's response capability."\ |
|
-help\ |
|
"Determines whether the console specified can answer ANSI queries, settling the result |
|
on the governing opunk::console instance when one is anchored (instance name spec, or a |
|
channel pair governed by the anchored 'default' instance). Layered determination: |
|
1. certainty - input at eof/closed -> 0 (no query emitted) |
|
2. heuristic - input provably not a console/tty and no terminal env hints -> 0 |
|
(no query emitted - piped/CI output streams stay clean) |
|
3. active probe - a cursor position report (CSI 6n) is emitted and 1 settled only if a |
|
response arrives within -timeout_ms. Only reached in the ambiguous zone |
|
(real consoles, or pipe-presenting terminals such as mintty without |
|
winpty) where queries are already routine. |
|
Unmatched input consumed while waiting is preserved in punk::console::input_chunks_waiting. |
|
For an unanchored object-value or plain channel-pair spec the result is returned but cannot |
|
be persisted." |
|
@opts |
|
-force -type none -help\ |
|
"Re-probe and re-settle even if capability is already settled." |
|
-timeout_ms -type integer -default "" -help\ |
|
"Probe timeout in ms. Empty uses punk::console::can_respond_probe_timeout_ms." |
|
@values -min 1 -max 1 |
|
consolespec -type list -help\ |
|
"Console specification: 2-element {in out} channel list, anchored opunk::console instance |
|
name, or ::opunk::Console object value." |
|
} |
|
proc settle_can_respond {args} { |
|
variable can_respond_probe_timeout_ms |
|
set argd [punk::args::parse $args withid ::punk::console::settle_can_respond] |
|
lassign [dict values $argd] leaders opts values received |
|
set opt_force [dict exists $received -force] |
|
set timeout_ms [dict get $opts -timeout_ms] |
|
if {$timeout_ms eq ""} { |
|
set timeout_ms $can_respond_probe_timeout_ms |
|
} |
|
set consolespec [dict get $values consolespec] |
|
|
|
set cinfo [console_spec_resolve $consolespec] |
|
set in [dict get $cinfo in] |
|
set out [dict get $cinfo out] |
|
set cobj [dict get $cinfo object] |
|
|
|
#determine the anchor variable (persistence point) if any |
|
set anchorvar "" |
|
if {[llength $consolespec] == 1} { |
|
set anchorvar [opunk::console::instancevar $consolespec] |
|
} elseif {$cobj ne "" && [info exists ::opunk::console::instances::default] && $cobj eq [set ::opunk::console::instances::default]} { |
|
set anchorvar ::opunk::console::instances::default |
|
} |
|
|
|
if {$cobj ne ""} { |
|
set settled [::opunk::Console::get.o_can_respond $cobj] |
|
if {$settled != -1 && !$opt_force} { |
|
return $settled |
|
} |
|
if {$opt_force && $anchorvar ne ""} { |
|
#unsettle first so the probe's own query is not refused by get_ansi_response_payload |
|
upvar #0 $anchorvar reprobe_obj |
|
::opunk::Console::set.o_can_respond reprobe_obj -1 |
|
} |
|
} |
|
|
|
#layer 1 - certainty: an eof/closed input can never deliver a response |
|
if {[input_at_eof $in]} { |
|
set verdict 0 |
|
} elseif {![is_input_console_or_tty $in]} { |
|
#layer 2 - strong negative heuristic: plain pipe, no terminal indicators or env hints. |
|
#No query is emitted - piped output streams stay clean. |
|
set verdict 0 |
|
} else { |
|
#layer 3 - active probe (ambiguous zone only): cursor position report |
|
variable can_respond_settling |
|
set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} |
|
set can_respond_settling 1 |
|
try { |
|
if {[catch { |
|
punk::console::internal::get_ansi_response_payload -expected_ms $timeout_ms -console [list $in $out] "\033\[6n" $capturingregex |
|
} payload]} { |
|
set verdict 0 |
|
} else { |
|
set verdict [expr {$payload ne "" ? 1 : 0}] |
|
} |
|
} finally { |
|
set can_respond_settling 0 |
|
} |
|
} |
|
|
|
if {$anchorvar ne ""} { |
|
upvar #0 $anchorvar settle_obj |
|
::opunk::Console::set.o_can_respond settle_obj $verdict |
|
} |
|
return $verdict |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::console::get_size |
|
@cmd -name punk::console::get_size -summary\ |
|
"Console size in character cells."\ |
|
-help\ |
|
"Size of the console as a dict with keys columns and rows. |
|
Mechanisms are tried fastest-first: chan configure -winsize on the output channel, then ANSI |
|
cursor-report mechanisms (timed per console on first use), then tput, defaulting to 80x24. |
|
ANSI mechanisms are skipped when the input side cannot answer queries: a supplied console |
|
object with settled can_respond 0 is authoritative (its default_size is returned), otherwise |
|
heuristic channel/eof detection applies. A settled can_respond 1 bypasses the heuristics. |
|
NOTE: argument parsing in this proc is manual for performance - this definition is documentation." |
|
@opts |
|
-console -default {stdin stdout} -type list -help\ |
|
"Console specification: a 2-element {in out} channel list, an anchored opunk::console |
|
instance name, or an ::opunk::Console object value." |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
} |
|
proc get_size {args} { |
|
#manual argument parsing - performance sensitive path (see PUNKARGS id ::punk::console::get_size for documentation) |
|
set consolespec [internal::hybrid_console_spec $args get_size] |
|
set cinfo [console_spec_resolve $consolespec] |
|
set in [dict get $cinfo in] |
|
set out [dict get $cinfo out] |
|
set cobj [dict get $cinfo object] |
|
set inoutchannels [list $in $out] ;#canonical channel pair - also the get_size_mechanism cache key |
|
|
|
if {$cobj ne ""} { |
|
#object-governed: dispatch through the (virtual) ::opunk::Console::size method so |
|
#subclass overrides (channel environments, widget terminals) are honoured from every |
|
#punk::console call site. The base class method consults our registered |
|
#size_query_provider for the ANSI mechanisms. |
|
ensure_object_integration |
|
if {[::opunk::Console::get.o_can_respond $cobj] == -1} { |
|
#first-use active settling - only for persistable specs (anchored instance name, or |
|
#the auto-attached default instance) so unanchored object values can't cause a probe |
|
#per call. settle_can_respond only emits a query in the ambiguous zone. |
|
if {[llength $consolespec] == 1 || ([info exists ::opunk::console::instances::default] && $cobj eq [set ::opunk::console::instances::default])} { |
|
settle_can_respond $consolespec |
|
#settlement persisted via the anchor - re-resolve for the updated object value |
|
set cinfo [console_spec_resolve $consolespec] |
|
set cobj [dict get $cinfo object] |
|
} |
|
} |
|
return [::opunk::Console::size $cobj] |
|
} |
|
|
|
#legacy channel-pair path (no governing object) |
|
|
|
#fastest mechanism if available - use Tcl's inbuilt -winsize key from chan configure if available - this is much faster than any ANSI mechanism |
|
#unknown which platforms support this. |
|
if {![catch {get_size_using_chanconfigure $inoutchannels} sizedict]} { |
|
return $sizedict |
|
} |
|
|
|
if {![is_input_console_or_tty $in]} { |
|
#input channel can't answer cursor position queries - skip the ANSI cursor-report mechanisms |
|
#entirely (they would hang or timeout waiting for a response that cannot arrive) |
|
if {![catch {get_size_using_tput $inoutchannels} sizedict]} { |
|
return $sizedict |
|
} |
|
#fall back to a conventional default size rather than erroring, so callers laying out text |
|
#(help tables etc) still function with piped/redirected input. |
|
return [dict create columns 80 rows 24] |
|
} |
|
|
|
set sized [size_via_query_mechanisms $inoutchannels] |
|
if {[dict size $sized]} { |
|
return $sized |
|
} |
|
#undetermined - conventional default rather than an error (see PUNKARGS help) |
|
return [dict create columns 80 rows 24] |
|
} |
|
|
|
#ANSI/tput size mechanisms with per-console-pair timing cache. Returns a dict |
|
#{columns <int> rows <int>} or an empty dict when size cannot be determined. |
|
#Used by the legacy get_size channel path and (as console_size_provider) by the base |
|
#::opunk::Console::size method via the pluggable ::opunk::console::size_query_provider hook. |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::size_via_query_mechanisms |
|
@cmd -name punk::console::size_via_query_mechanisms -summary\ |
|
"ANSI/tput size mechanisms with per-console-pair timing cache - {columns <c> rows <r>} or empty dict when undetermined."\ |
|
-help\ |
|
"Internal mechanism dispatcher used by get_size and (as console_size_provider) by the |
|
::opunk::Console::size method. Callers supply a canonical {in out} channel pair." |
|
@values -min 1 -max 1 |
|
inoutchannels -type list -help\ |
|
"Canonical {in out} channel pair." |
|
}] |
|
proc size_via_query_mechanisms {inoutchannels} { |
|
#see PUNKARGS id ::punk::console::size_via_query_mechanisms |
|
if {[console_fact_get $inoutchannels is_vt52]} { |
|
#vt52 doesn't support cursor save/restore or cursor position reports. |
|
if {![catch {get_size_using_tput $inoutchannels} sizedict]} { |
|
return $sizedict |
|
} |
|
return [dict create] |
|
} |
|
|
|
variable get_size_mechanism ;#dict keyed on terminal ident. (currently just list of inoutchannels but may be something else in future such as terminal object or ident string) |
|
if {![dict exists $get_size_mechanism $inoutchannels]} { |
|
set try_order [list] |
|
#call each mechanism once to see if it works - and to ensure we don't include initial run in our timings. |
|
#we will also use the results for our initial return of the size. |
|
set successful_mechs [list] |
|
set sizedict [dict create] |
|
if {![catch {get_size_using_cursorrestore $inoutchannels} result]} { |
|
lappend successful_mechs "cursorrestore" |
|
if {![dict size $sizedict]} { |
|
set sizedict $result |
|
} |
|
} |
|
if {![catch {get_size_using_cursormove $inoutchannels} result]} { |
|
lappend successful_mechs "cursormove" |
|
if {![dict size $sizedict]} { |
|
set sizedict $result |
|
} |
|
} |
|
if {![catch {get_size_using_tput $inoutchannels} result] } { |
|
lappend successful_mechs "tput" |
|
if {![dict size $sizedict]} { |
|
set sizedict $result |
|
} |
|
} |
|
set timings [list] |
|
set t_ms 250 ;#default timerate is 1000ms - we are trying at least 3 mechanisms so 1000ms is a bit long for this test as it can slow down the first call to get_size significantly. |
|
foreach sm $successful_mechs { |
|
catch { |
|
set timing_result [timerate {get_size_using_$sm $inoutchannels} $t_ms] |
|
set micros [expr {int([lindex $timing_result 0])}] |
|
lappend timings [list $micros $sm] |
|
} |
|
} |
|
set sorted [lsort -integer -index 0 $timings] |
|
if {[llength $sorted] > 0} { |
|
set try_order [lmap t $sorted {lindex $t 1}] |
|
} else { |
|
set try_order [list] |
|
} |
|
dict set get_size_mechanism $inoutchannels $try_order |
|
return $sizedict |
|
} |
|
|
|
foreach mech [dict get $get_size_mechanism $inoutchannels] { |
|
if {![catch {get_size_using_$mech $inoutchannels} sizedict]} { |
|
return $sizedict |
|
} |
|
} |
|
return [dict create] |
|
} |
|
|
|
#Registered as the ::opunk::console::size_query_provider (see ensure_object_integration): |
|
#gives the base ::opunk::Console::size method access to the ANSI query mechanisms without the |
|
#class depending on punk::console. |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::console_size_provider |
|
@cmd -name punk::console::console_size_provider -summary\ |
|
"Registered as ::opunk::console::size_query_provider - gives the base Console::size method the ANSI size mechanisms." |
|
@values -min 1 -max 1 |
|
obj -type list -help\ |
|
"::opunk::Console (or subclass) object value." |
|
}] |
|
proc console_size_provider {obj} { |
|
#see PUNKARGS id ::punk::console::console_size_provider |
|
size_via_query_mechanisms [::opunk::Console::channels $obj] |
|
} |
|
|
|
variable object_integration_done |
|
if {![info exists object_integration_done]} { |
|
set object_integration_done 0 |
|
} |
|
#One-time wiring performed whenever punk::console works with opunk::console objects: |
|
# - unify the class's probe-byte store with our cooperative input_chunks_waiting so probe-consumed |
|
# bytes stay visible to active readers (punk repl etc) |
|
# - register the size-query provider (only if none registered - a deliberately customised |
|
# provider is respected) |
|
proc ensure_object_integration {} { |
|
variable object_integration_done |
|
if {$object_integration_done} { |
|
return |
|
} |
|
set ::opunk::console::waiting_chunks_arrayvar ::punk::console::input_chunks_waiting |
|
if {$::opunk::console::size_query_provider eq ""} { |
|
set ::opunk::console::size_query_provider [list ::punk::console::console_size_provider] |
|
} |
|
#ownership registry maintenance rides the anchor lifecycle (older opunk::console |
|
#versions have no lifecycle_callback - default_console's explicit registration and |
|
#consult-time liveness validation still cover the default console there) |
|
if {[info exists ::opunk::console::lifecycle_callback] && $::opunk::console::lifecycle_callback eq ""} { |
|
set ::opunk::console::lifecycle_callback [list ::punk::console::internal::object_console_lifecycle] |
|
} |
|
set object_integration_done 1 |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_size_using_chanconfigure |
|
@cmd -name punk::console::get_size_using_chanconfigure -summary\ |
|
"Console size from 'chan configure -winsize' on the output channel - errors when unsupported." |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -default {stdin stdout} -optional 1 -help\ |
|
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)." |
|
}] |
|
proc get_size_using_chanconfigure {{inoutchannels {stdin stdout}}} { |
|
#see PUNKARGS id ::punk::console::get_size_using_chanconfigure |
|
set out [lindex $inoutchannels 1] |
|
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 [dict create columns $cols rows $lines] |
|
} |
|
} |
|
error "chan configure method of getting console size not supported or failed to get valid size info" |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_size_using_tput |
|
@cmd -name punk::console::get_size_using_tput -summary\ |
|
"Console size via the external tput utility (process terminal) - errors when tput is unavailable." |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -default {stdin stdout} -optional 1 -help\ |
|
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)." |
|
}] |
|
proc get_size_using_tput {{inoutchannels {stdin stdout}}} { |
|
#see PUNKARGS id ::punk::console::get_size_using_tput |
|
set tputcmd [auto_execok tput] |
|
if {$tputcmd eq ""} { |
|
error "tput command not found - cannot use tput method to get console size" |
|
} |
|
lassign [exec {*}$tputcmd lines cols] lines cols |
|
return [dict create columns $cols rows $lines] |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_size_using_cursormove |
|
@cmd -name punk::console::get_size_using_cursormove -summary\ |
|
"Console size via big cursor move + position report (no cursor save/restore)." |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -default {stdin stdout} -optional 1 -help\ |
|
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)." |
|
}] |
|
proc get_size_using_cursormove {{inoutchannels {stdin stdout}}} { |
|
#see PUNKARGS id ::punk::console::get_size_using_cursormove |
|
set out [lindex $inoutchannels 1] |
|
#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_using_cursormove output channel $out seems to be closed ([info level 1])" |
|
} else { |
|
if {$is_eof} { |
|
error "punk::console::get_size_using_cursormove eof on output channel $out ([info level 1])" |
|
} |
|
} |
|
|
|
lassign [get_cursor_pos_list $inoutchannels] start_row start_col |
|
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::move 2000 2000] |
|
lassign [get_cursor_pos_list $inoutchannels] lines cols |
|
puts -nonewline $out [punk::ansi::move $start_row $start_col][punk::ansi::cursor_on];flush $out |
|
set result [dict create columns $cols rows $lines] |
|
} errM]} { |
|
puts -nonewline $out [punk::ansi::move $start_row $start_col] |
|
puts -nonewline $out [punk::ansi::cursor_on] |
|
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 |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_size_using_cursorrestore |
|
@cmd -name punk::console::get_size_using_cursorrestore -summary\ |
|
"Console size via big cursor move + position report, bracketed by DEC cursor save/restore." |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -default {stdin stdout} -optional 1 -help\ |
|
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)." |
|
}] |
|
proc get_size_using_cursorrestore {{inoutchannels {stdin stdout}}} { |
|
#see PUNKARGS id ::punk::console::get_size_using_cursorrestore |
|
lassign $inoutchannels in out |
|
set outconf [chan configure $out] |
|
#don't use shortcut mechanisms - this function is intended to specificall use the cursor_save/restore method |
|
|
|
if {[catch {chan eof $out} is_eof]} { |
|
error "punk::console::get_size_using_cursorrestore output channel $out seems to be closed ([info level 1])" |
|
} else { |
|
if {$is_eof} { |
|
error "punk::console::get_size_using_cursorrestore eof on output channel $out ([info level 1])" |
|
} |
|
} |
|
|
|
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::ansi::cursor_on];flush $out |
|
set result [dict create 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 |
|
} |
|
} |
|
|
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_dimensions |
|
@cmd -name punk::console::get_dimensions -summary\ |
|
"Console size as a WxH string (see get_size)."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_dimensions {args} { |
|
#see PUNKARGS id ::punk::console::get_dimensions |
|
lassign [get_size {*}$args] _c cols _l lines |
|
return "${cols}x${lines}" |
|
} |
|
|
|
|
|
|
|
#the (xterm?) CSI 18t query is supported by *some* terminals |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_xterm_size |
|
@cmd -name punk::console::get_xterm_size -summary\ |
|
"Query text-area size via xterm CSI 18t - returns {columns <c> rows <r>}."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_xterm_size {args} { |
|
#see PUNKARGS id ::punk::console::get_xterm_size |
|
set inoutchannels [internal::hybrid_console_spec $args get_xterm_size] |
|
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 -console $inoutchannels $request $capturingregex] |
|
lassign [split $payload {;}] rows cols |
|
return [list columns $cols rows $rows] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::get_xterm_pixels |
|
@cmd -name punk::console::get_xterm_pixels -summary\ |
|
"Query text-area pixel size via xterm CSI 14t - returns {width <w> height <h>}."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc get_xterm_pixels {args} { |
|
#see PUNKARGS id ::punk::console::get_xterm_pixels |
|
set inoutchannels [internal::hybrid_console_spec $args get_xterm_pixels] |
|
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 -console $inoutchannels $request $capturingregex] |
|
lassign [split $payload {;}] height width |
|
return [list width $width height $height] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_get_mode_line_wrap |
|
@cmd -name punk::console::dec_get_mode_line_wrap -summary\ |
|
"Query DEC autowrap mode (DECAWM, mode 7) state via DECRQM."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc dec_get_mode_line_wrap {args} { |
|
#see PUNKARGS id ::punk::console::dec_get_mode_line_wrap |
|
set inoutchannels [internal::hybrid_console_spec $args dec_get_mode_line_wrap] |
|
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 -console $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
#Terminals generally default to LNM being reset (off) ie enter key sends a lone <cr> |
|
#windows terminal defaults to LNM on, but wezterm on windows default to LNM off |
|
#LNM on sends both <cr> and <lf> ?? |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi_get_mode_LNM |
|
@cmd -name punk::console::ansi_get_mode_LNM -summary\ |
|
"Query ANSI linefeed/newline mode (LNM, mode 20) state via DECRQM."\ |
|
-help\ |
|
"NOTE: argument parsing is manual - this definition is documentation." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
inoutchannels -type list -optional 1 -help\ |
|
"Legacy positional console specification (same forms accepted as -console)." |
|
}] |
|
proc ansi_get_mode_LNM {args} { |
|
#see PUNKARGS id ::punk::console::ansi_get_mode_LNM |
|
set inoutchannels [internal::hybrid_console_spec $args ansi_get_mode_LNM] |
|
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 -console $inoutchannels $request $capturingregex] |
|
return $payload |
|
} |
|
|
|
|
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_get_mode |
|
@cmd -name punk::console::dec_get_mode\ |
|
-summary\ |
|
{Get DEC mode}\ |
|
-help\ |
|
{Get DEC mode by sending to the console |
|
the sequence: |
|
ESC [ ? <code> $ p |
|
Where <code> is an integer |
|
formed from the supplied ${$I}mode${$NI} value. |
|
|
|
The terminal should respond with a sequence of the form: |
|
ESC [ ? <code> ; <s> $ y |
|
where <s> is one of the statuses: |
|
0 - mode not recognised |
|
1 - mode is set |
|
2 - mode is unset |
|
3 - mode is permanently set |
|
4 - mode is permanently unset |
|
|
|
The response is automatically retrieved from the terminal |
|
and so should not be displayed unless there is such a |
|
significant delay that the request times out. |
|
|
|
The value of <s> is returned by the dec_get_mode function. |
|
|
|
The delay in retrieving a terminal response can range from |
|
a few ms to 10s of ms depending on the terminal or other |
|
runtime conditions. |
|
In some cases it may be beneficial to call dec_has_mode first, |
|
(which is cached) to reduce the number of queries to the terminal. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
@values -min 1 -max 1 |
|
mode -type {int|string} -multiple 0 -help\ |
|
"integer for DEC mode, or name as in the dict: |
|
::punk::ansi::decmode_names |
|
See also the command: ${$B}dec_modes${$N}" |
|
}] |
|
} |
|
#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 dec_get_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode] |
|
lassign [dict values $argd] leaders opts values |
|
set terminal [dict get $opts -console] |
|
set passthrough [dict get $opts -passthrough] |
|
set mode [dict get $values mode] |
|
|
|
if {[string is integer -strict $mode]} { |
|
set m $mode |
|
} else { |
|
upvar ::punk::ansi::decmode_names decmode_names |
|
if {[dict exists $decmode_names $mode]} { |
|
set m [dict get $decmode_names $mode] |
|
} else { |
|
error "punk::console::dec_get_mode unrecognised mode '$mode'. 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 -console $terminal -passthrough $passthrough $request $capturingregex] |
|
return $payload |
|
} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_set_mode |
|
@cmd -name punk::console::dec_set_mode\ |
|
-summary\ |
|
{Set DEC mode(s) (DECSET)}\ |
|
-help\ |
|
{Set DEC mode(s) by sending to the console |
|
the DECSET sequence: |
|
ESC [ ? <codes> h |
|
Where <codes> is a semicolon delimited set of integers |
|
formed from the supplied ${$I}mode${$NI} values. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 1 -max -1 |
|
mode -type {int|string} -multiple 1 -help\ |
|
"integer for DEC mode, or name as in the dict: |
|
::punk::ansi::decmode_names |
|
See also the command: ${$B}dec_modes${$N}" |
|
}] |
|
} |
|
#todo - should accept multiple mode nums/names at once |
|
proc dec_set_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode] |
|
lassign [dict values $argd] leaders opts values |
|
set terminal [dict get $opts -console] |
|
set modes [dict get $values mode] ;#multiple |
|
|
|
set modelist [list] |
|
foreach num_or_name $modes { |
|
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::dec_set_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" |
|
} |
|
} |
|
lappend modelist $m |
|
} |
|
set modes_string [join $modelist {;}] |
|
set term_out [dict get [console_spec_resolve $terminal] out] |
|
puts -nonewline $term_out "\x1b\[?${modes_string}h" |
|
} |
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_unset_mode |
|
@cmd -name punk::console::dec_unset_mode\ |
|
-summary\ |
|
{Unset DEC mode(s) (DECRST)}\ |
|
-help\ |
|
{Unset DEC mode(s) by sending to the console |
|
the DECRST sequence: |
|
ESC [ ? <codes> l |
|
Where <codes> is a semicolon delimited set of integers |
|
formed from the supplied ${$I}mode${$NI} values. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 1 -max -1 |
|
mode -type {int|string} -multiple 1 -help\ |
|
"integer for DEC mode, or name as in the dict: |
|
::punk::ansi::decmode_names |
|
See also the command: ${$B}dec_modes${$N}" |
|
}] |
|
} |
|
proc dec_unset_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode] |
|
lassign [dict values $argd] leaders opts values |
|
set terminal [dict get $opts -console] |
|
set modes [dict get $values mode] ;#multiple |
|
|
|
set modelist [list] |
|
foreach num_or_name $modes { |
|
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::dec_unset_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" |
|
} |
|
} |
|
lappend modelist $m |
|
} |
|
set modes_string [join $modelist {;}] |
|
set term_out [dict get [console_spec_resolve $terminal] out] |
|
puts -nonewline $term_out "\x1b\[?${modes_string}l" |
|
} |
|
|
|
#dec_has_mode/ansi_has_mode results are cached in tsv (shared array 'punk_console_modecache', |
|
#one entry per {dectype qualifier in out passthrough mode} key) so every thread of the |
|
#process shares one cache per console and cache writes are single-key atomic (G-007). |
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_has_mode |
|
@cmd -name punk::console::dec_has_mode\ |
|
-summary\ |
|
{Check if console supports a particular DEC mode}\ |
|
-help\ |
|
{Check if console supports a particular DEC mode by emitting query to the console using |
|
the sequence: |
|
ESC [ ? <n> $ p |
|
Where <n> is an integer identifier. |
|
|
|
Will return zero if the mode is unsupported, 1|2|3|4 if supported. |
|
|
|
The result is cached. |
|
Cached values of 1 or 2 may not represent current state. |
|
${$B}dec_get_mode${$N} or ${$B}dec_has_mode -refresh${$N} should be |
|
used if up-to-date current state of a supported mode is required. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
-refresh -type none -help\ |
|
"Force a re-test of the mode." |
|
-return -type string -choices {dict result} -default result -choicelabels { |
|
dict\ |
|
"Return a dict with keys source and result |
|
source indicates whether the result came |
|
from query or cache." |
|
} |
|
@values -min 1 -max 1 |
|
mode -type {int|string} -help\ |
|
"integer for DEC mode, or name as in the dict: |
|
::punk::ansi::decmode_names" |
|
}] |
|
} |
|
proc dec_has_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode] |
|
lassign [dict values $argd] leaders opts values received |
|
set console [dict get $opts -console] |
|
set passthrough [dict get $opts -passthrough] |
|
set num_or_name [dict get $values mode] |
|
set do_refresh [dict exists $received -refresh] |
|
set return [dict get $opts -return] |
|
|
|
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::dec_has_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" |
|
} |
|
} |
|
set cinfo [console_spec_resolve $console] |
|
set console [list [dict get $cinfo in] [dict get $cinfo out]] |
|
#cache in tsv on the canonical channel pair (owner-qualified for non-default consoles) |
|
#and passthrough - all -console spec forms addressing the same console share one cache |
|
#entry, visible to all threads of the process |
|
set cachekey [list dec [internal::console_share_qualifier $console] [lindex $console 0] [lindex $console 1] $passthrough $m] |
|
if {$do_refresh} { |
|
if {[tsv::exists punk_console_modecache $cachekey]} { |
|
tsv::unset punk_console_modecache $cachekey |
|
} |
|
} |
|
|
|
if {![tsv::get punk_console_modecache $cachekey has_mode]} { |
|
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 -console $console -passthrough $passthrough $request $capturingregex] |
|
#set has_mode [expr {$payload != 0}] |
|
#we can use the payload result as the response as non-zero responses evaluate to true |
|
set has_mode $payload |
|
if {$has_mode ne ""} { |
|
tsv::set punk_console_modecache $cachekey $has_mode |
|
set source "query" |
|
} else { |
|
#don't cache an empty/failed response - review |
|
set has_mode 0 |
|
set source "failedquery" |
|
} |
|
} else { |
|
set source "cache" |
|
} |
|
if {$return eq "dict"} { |
|
return [dict create result $has_mode source $source] |
|
} |
|
return $has_mode |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_modes |
|
@cmd -name punk::console::dec_modes\ |
|
-summary\ |
|
{Show table of DEC modes}\ |
|
-help\ |
|
{Show table of DEC modes with basic information.} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
-test -type none -help\ |
|
"Test current value/support for each mode" |
|
-supported -type none -help\ |
|
"Limit results to supported DEC modes" |
|
@values -min 0 -max -1 |
|
match -type indexset|string -multiple 1 -optional 1 -help\ |
|
"Match code or name" |
|
}] |
|
proc dec_modes {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes] |
|
lassign [dict values $argd] leaders opts values received |
|
set terminal [dict get $opts -console] |
|
set passthrough [dict get $opts -passthrough] |
|
set do_test [dict exists $received -test] |
|
set only_supported [dict exists $received -supported] |
|
if {[dict exists $values match]} { |
|
set matches [dict get $values match] |
|
} else { |
|
set matches {} |
|
} |
|
|
|
upvar ::punk::ansi::decmode_data decmode_data |
|
upvar ::punk::ansi::decmode_names decmode_names |
|
set t [textblock::class::table new "Dec Modes"] |
|
$t configure -show_header 1 -show_hseps 1 |
|
$t add_column -headers Code |
|
$t add_column -headers Names |
|
$t add_column -headers Origin |
|
$t add_column -headers Description |
|
$t add_column -headers set-state |
|
$t add_column -headers reset-state |
|
if {$do_test} { |
|
$t add_column -headers Status |
|
} |
|
set names [dict keys $decmode_names] |
|
if {[llength $matches] == 0} { |
|
#show all entries |
|
set codes [dict keys $decmode_data] |
|
} else { |
|
set codes [list] |
|
foreach m $matches { |
|
if {[punk::lib::is_indexset $m]} { |
|
set defaultmax 10000 ;#some codes are very high e.g foot IME 737769 - but we don't want to default test/scan for hours |
|
#todo set max to actual largest value from indexset |
|
lappend codes {*}[punk::lib::indexset_resolve -base 1 $defaultmax $m] |
|
} else { |
|
foreach nm $names { |
|
if {[string match -nocase $m $nm]} { |
|
set code [dict get $decmode_names $nm] |
|
#only suppress dupes if sequential (display loop will still show multiple entries for the code if it has multiple origin entries) |
|
if {[lindex $codes end] ne $code} { |
|
lappend codes [dict get $decmode_names $nm] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
#dict for {code items} $decmode_data {} |
|
foreach code $codes { |
|
if {[dict exists $decmode_data $code]} { |
|
set items [dict get $decmode_data $code] |
|
} else { |
|
set items [list [dict create origin ? description "" names "" set-state "" reset-state ""]] |
|
} |
|
set colour "" |
|
set set_state_colour "" |
|
set reset_state_colour "" |
|
set RST "" |
|
if {$do_test} { |
|
#dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying |
|
set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code] |
|
switch -- [dict get $hasmode_dict result] { |
|
0 { |
|
if {$only_supported} { |
|
continue |
|
} |
|
if {[dict get $hasmode_dict source] eq "failedquery"} { |
|
set testresult "no response" |
|
} else { |
|
set testresult 0 |
|
} |
|
} |
|
1 - 2 { |
|
if {[dict get $hasmode_dict source] eq "cache"} { |
|
#a terminal query is required |
|
set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code] |
|
} else { |
|
set testresult [dict get $hasmode_dict result] |
|
if {![string is integer -strict $testresult]} { |
|
set testresult "No response" |
|
} |
|
} |
|
} |
|
default { |
|
#3|4 - permanently enabled or permanently disabled |
|
set testresult [dict get $hasmode_dict result] |
|
} |
|
} |
|
|
|
switch -- $testresult { |
|
0 { |
|
set colour [punk::ansi::a+ red bold] |
|
} |
|
1 { |
|
set colour [punk::ansi::a+ green] |
|
set set_state_colour $colour |
|
} |
|
2 { |
|
set colour [punk::ansi::a+ yellow bold] |
|
set reset_state_colour $colour |
|
} |
|
3 { |
|
set colour [punk::ansi::a+ green] |
|
set set_state_colour $colour |
|
} |
|
4 { |
|
set colour [punk::ansi::a+ yellow bold] |
|
set reset_state_colour $colour |
|
} |
|
default { |
|
#failedquery |
|
set colour [punk::ansi::a+ red bold] |
|
} |
|
} |
|
if {$colour ne ""} { |
|
set RST "\x1b\[m" |
|
} |
|
set testdisplay $colour$testresult$RST |
|
} else { |
|
if {$only_supported} { |
|
#dec_has_mode still queries terminal - but is cached if a response was received |
|
if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} { |
|
continue |
|
} |
|
} |
|
} |
|
foreach itm $items { |
|
set code $colour$code$RST |
|
set names $colour[dict get $itm names]$RST |
|
set origin [dict get $itm origin] |
|
set desc [dict get $itm description] |
|
set set_state $set_state_colour[dict get $itm set-state]$RST |
|
set reset_state $reset_state_colour[dict get $itm reset-state]$RST |
|
set row [list $code [join $names \n] $origin $desc $set_state $reset_state] |
|
if {$do_test} { |
|
lappend row $testdisplay |
|
} |
|
$t add_row $row |
|
} |
|
} |
|
set out [$t print] |
|
$t destroy |
|
return $out |
|
} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi_has_mode |
|
@cmd -name punk::console::ansi_has_mode\ |
|
-summary\ |
|
{Check if console supports a particular ANSI mode}\ |
|
-help\ |
|
{Check if console supports a particular ANSI mode by emitting query to the console using |
|
the sequence: |
|
${$B}ESC [ <n> $ p${$N} |
|
Where ${$B}<n>${$N} is an integer identifier. |
|
} |
|
@opts |
|
#review - problem with 's ansi_has_mode' |
|
#-console -type list -typesynopsis {{${$I}inputchan${$NI} ${$I}outputchan${$NI}}} -minsize 2 -default {stdin stdout} |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
-refresh -type none |
|
-return -type string -choices {dict result} -default result -choicelabels { |
|
dict\ |
|
"Return a dict with keys source and result |
|
source indicates whether the result came |
|
from query or cache." |
|
} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
@values -min 1 -max 1 |
|
mode -type {int|string} -help\ |
|
"integer for ANSI mode, or name as in the dict: |
|
::punk::ansi::ansimode_names" |
|
}] |
|
} |
|
proc ansi_has_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode] |
|
lassign [dict values $argd] leaders opts values received |
|
set console [dict get $opts -console] |
|
set num_or_name [dict get $values mode] |
|
set return [dict get $opts -return] |
|
set passthrough [dict get $opts -passthrough] |
|
set do_refresh [dict exists $received -refresh] |
|
|
|
if {[string is integer -strict $num_or_name]} { |
|
set m $num_or_name |
|
} else { |
|
upvar ::punk::ansi::ansimode_names ansimode_names |
|
if {[dict exists $ansimode_names $num_or_name]} { |
|
set m [dict get $ansimode_names $num_or_name] |
|
} else { |
|
error "punk::console::ansi_has_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $ansimode_names]" |
|
} |
|
} |
|
set cinfo [console_spec_resolve $console] |
|
set console [list [dict get $cinfo in] [dict get $cinfo out]] |
|
#cache in tsv on the canonical channel pair (owner-qualified for non-default consoles) |
|
#and passthrough - all -console spec forms addressing the same console share one cache |
|
#entry, visible to all threads of the process |
|
set cachekey [list ansi [internal::console_share_qualifier $console] [lindex $console 0] [lindex $console 1] $passthrough $m] |
|
if {$do_refresh} { |
|
if {[tsv::exists punk_console_modecache $cachekey]} { |
|
tsv::unset punk_console_modecache $cachekey |
|
} |
|
} |
|
|
|
if {![tsv::get punk_console_modecache $cachekey has_mode]} { |
|
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 -console $console -passthrough $passthrough $request $capturingregex] |
|
#set has_mode [expr {$payload != 0}] |
|
set has_mode $payload |
|
if {$has_mode ne ""} { |
|
tsv::set punk_console_modecache $cachekey $has_mode |
|
set source "query" |
|
} else { |
|
#don't cache an empty/failed response - review |
|
set has_mode 0 |
|
set source "failedquery" |
|
} |
|
} else { |
|
set source "cache" |
|
} |
|
if {$return eq "dict"} { |
|
return [dict create result $has_mode source $source] |
|
} |
|
return $has_mode |
|
} |
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi_set_mode |
|
@cmd -name punk::console::ansi_set_mode\ |
|
-summary\ |
|
{Set ANSI mode(s) (SM)}\ |
|
-help\ |
|
{Set ANSI mode(s) by sending to the console |
|
the SM sequence: |
|
ESC [ <codes> h |
|
Where <codes> is a semicolon delimited set of integers |
|
formed from the supplied ${$I}mode${$NI} values. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 1 -max -1 |
|
mode -type {int|string} -multiple 1 -help\ |
|
"integer for ANSI mode, or name as in the dict: |
|
::punk::ansi::ansimode_names |
|
See also the command: ${$B}ansi_modes${$N}" |
|
}] |
|
} |
|
proc ansi_set_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode] |
|
lassign [dict values $argd] leaders opts values |
|
set terminal [dict get $opts -console] |
|
set modes [dict get $values mode] ;#multiple |
|
|
|
set modelist [list] |
|
foreach num_or_name $modes { |
|
if {[string is integer -strict $num_or_name]} { |
|
set m $num_or_name |
|
} else { |
|
upvar ::punk::ansi::ansimode_names ansimode_names |
|
if {[dict exists $ansimode_names $num_or_name]} { |
|
set m [dict get $ansimode_names $num_or_name] |
|
} else { |
|
error "punk::console::ansi_set_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $ansimode_names]" |
|
} |
|
} |
|
lappend modelist $m |
|
} |
|
set modes_string [join $modelist {;}] |
|
set term_out [dict get [console_spec_resolve $terminal] out] |
|
puts -nonewline $term_out "\x1b\[${modes_string}h" |
|
} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi_unset_mode |
|
@cmd -name punk::console::ansi_unset_mode\ |
|
-summary\ |
|
{Unset ANSI mode(s) (RM)}\ |
|
-help\ |
|
{Unset ANSI mode(s) by sending to the console |
|
the RM sequence: |
|
ESC [ <codes> l |
|
Where <codes> is a semicolon delimited set of integers |
|
formed from the supplied ${$I}mode${$NI} values. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 1 -max -1 |
|
mode -type {int|string} -multiple 1 -help\ |
|
"integer for ANSI mode, or name as in the dict: |
|
::punk::ansi::ansimode_names |
|
See also the command: ${$B}ansi_modes${$N}" |
|
}] |
|
} |
|
proc ansi_unset_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode] |
|
lassign [dict values $argd] leaders opts values |
|
set terminal [dict get $opts -console] |
|
set modes [dict get $values mode] ;#multiple |
|
|
|
set modelist [list] |
|
foreach num_or_name $modes { |
|
if {[string is integer -strict $num_or_name]} { |
|
set m $num_or_name |
|
} else { |
|
upvar ::punk::ansi::ansimode_names ansimode_names |
|
if {[dict exists $ansimode_names $num_or_name]} { |
|
set m [dict get $ansimode_names $num_or_name] |
|
} else { |
|
error "punk::console::ansi_unset_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $ansimode_names]" |
|
} |
|
} |
|
lappend modelist $m |
|
} |
|
set modes_string [join $modelist {;}] |
|
set term_out [dict get [console_spec_resolve $terminal] out] |
|
puts -nonewline $term_out "\x1b\[${modes_string}l" |
|
} |
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi_get_mode |
|
@cmd -name punk::console::ansi_get_mode\ |
|
-summary\ |
|
{Get ANSI mode}\ |
|
-help\ |
|
{Get ANSI mode by sending to the console |
|
the sequence: |
|
ESC [ <code> $ p |
|
Where <code> is an integer |
|
formed from the supplied ${$I}mode${$NI} value. |
|
|
|
The terminal should respond with a sequence of the form: |
|
ESC [ <code> ; <s> $ y |
|
where <s> is one of the statuses: |
|
0 - mode not recognised |
|
1 - mode is set |
|
2 - mode is unset |
|
3 - mode is permanently set |
|
4 - mode is permanently unset |
|
|
|
The response is automatically retrieved from the terminal |
|
and so should not be displayed unless there is such a |
|
significant delay that the request times out. |
|
|
|
The value of <s> is returned by the ansi_get_mode function. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
@values -min 1 -max 1 |
|
mode -type {int|string} -multiple 0 -help\ |
|
"integer for ANSI mode, or name as in the dict: |
|
::punk::ansi::ansimode_names |
|
See also the command: ${$B}ansi_modes${$N}" |
|
}] |
|
} |
|
#DECRPM responses e.g: |
|
# \x1b\[12\;1\$y |
|
# \x1b\[?7\;2\$y |
|
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) |
|
proc ansi_get_mode {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode] |
|
lassign [dict values $argd] leaders opts values |
|
set terminal [dict get $opts -console] |
|
set passthrough [dict get $opts -passthrough] |
|
set mode [dict get $values mode] |
|
|
|
if {[string is integer -strict $mode]} { |
|
set m $mode |
|
} else { |
|
upvar ::punk::ansi::ansimode_names ansimode_names |
|
if {[dict exists $ansimode_names $mode]} { |
|
set m [dict get $ansimode_names $mode] |
|
} else { |
|
error "punk::console::ansi_get_mode unrecognised mode '$mode'. Known mode names: [dict keys $ansimode_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 -console $terminal -passthrough $passthrough $request $capturingregex] |
|
return $payload |
|
} |
|
#todo ansi_unset_mode |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi_modes |
|
@cmd -name punk::console::ansi_modes\ |
|
-summary\ |
|
{Show table of ANSI modes}\ |
|
-help\ |
|
{Show table of ANSI modes with basic information.} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]} |
|
-test -type none -help\ |
|
"Test current value/support for each mode" |
|
-supported -type none -help\ |
|
"Limit results to supported ANSI modes" |
|
@values -min 0 -max -1 |
|
match -type indexset|string -multiple 1 -optional 1 -help\ |
|
"Match code or name" |
|
}] |
|
proc ansi_modes {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes] |
|
lassign [dict values $argd] leaders opts values received |
|
set terminal [dict get $opts -console] |
|
set passthrough [dict get $opts -passthrough] |
|
set do_test [dict exists $received -test] |
|
if {[dict exists $values match]} { |
|
set matches [dict get $values match] |
|
} else { |
|
set matches {} |
|
} |
|
set only_supported [dict exists $received -supported] |
|
|
|
upvar ::punk::ansi::ansimode_data ansimode_data |
|
upvar ::punk::ansi::ansimode_names ansimode_names |
|
|
|
set t [textblock::class::table new "ANSI Modes"] |
|
$t configure -show_header 1 -show_hseps 1 |
|
$t add_column -headers Code |
|
$t add_column -headers Names |
|
$t add_column -headers Origin |
|
$t add_column -headers Description |
|
$t add_column -headers set-state |
|
$t add_column -headers reset-state |
|
if {$do_test} { |
|
$t add_column -headers Status |
|
} |
|
set names [dict keys $ansimode_names] |
|
if {[llength $matches] == 0} { |
|
#show all entries |
|
set codes [dict keys $ansimode_data] |
|
} else { |
|
set codes [list] |
|
foreach m $matches { |
|
if {[punk::lib::is_indexset $m]} { |
|
set iparts [split $m ,] |
|
#determine the largest index requested - which may be greater than the defined range if explicitly specified |
|
#(allow scanning for unusual ansi modes above 22 - *some* known to exist - private modes should use DECSET DECRESET instead) |
|
#above 22 values seem to be mainly from SCOANSI and Wyse terminals |
|
|
|
set maxint [dict size $ansimode_data] |
|
foreach i $iparts { |
|
if {[string is integer -strict $i]} { |
|
if {$i > $maxint} { |
|
set maxint $i |
|
} |
|
} else { |
|
if {![string match *end* $i]} { |
|
lassign [split [string map [list .. \uFFEF] $i] \uFFEF] a b |
|
if {$a > $b} { |
|
if {$a > $maxint} { |
|
set maxint $a |
|
} |
|
} else { |
|
if {$b > $maxint} { |
|
set maxint $b |
|
} |
|
} |
|
} |
|
} |
|
} |
|
puts "---> maxint: $maxint" |
|
lappend codes {*}[punk::lib::indexset_resolve -base 1 $maxint $m] |
|
} else { |
|
foreach nm $names { |
|
if {[string match -nocase $m $nm]} { |
|
set code [dict get $ansimode_names $nm] |
|
#only suppress dupes if sequential (display loop will still show multiple entries for the code if it has multiple origin entries) |
|
if {[lindex $codes end] ne $code} { |
|
lappend codes [dict get $ansimode_names $nm] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
#dict for {code items} $ansimode_data {} |
|
foreach code $codes { |
|
if {[dict exists $ansimode_data $code]} { |
|
set items [dict get $ansimode_data $code] |
|
} else { |
|
set items [list [dict create origin ? description "" names "" set-state "" reset-state ""]] |
|
} |
|
set colour "" |
|
set set_state_colour "" |
|
set reset_state_colour "" |
|
set RST "" |
|
if {$do_test} { |
|
set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code] |
|
switch -- [dict get $hasmode_dict result] { |
|
0 { |
|
if {$only_supported} { |
|
continue |
|
} |
|
if {[dict get $hasmode_dict source] eq "failedquery"} { |
|
set testresult "no response" |
|
} else { |
|
set testresult 0 |
|
} |
|
} |
|
1 - 2 { |
|
if {[dict get $hasmode_dict source] eq "cache"} { |
|
#a terminal query is required |
|
set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code] |
|
} else { |
|
set testresult [dict get $hasmode_dict result] |
|
if {![string is integer -strict $testresult]} { |
|
set testresult "No response" |
|
} |
|
} |
|
} |
|
default { |
|
#3|4 - permanently enabled or permanently disabled |
|
set testresult [dict get $hasmode_dict result] |
|
} |
|
} |
|
|
|
#set testresult [ansi_get_mode $code] |
|
switch -- $testresult { |
|
0 { |
|
set colour [punk::ansi::a+ red bold] |
|
} |
|
1 { |
|
set colour [punk::ansi::a+ green] |
|
set set_state_colour $colour |
|
} |
|
2 { |
|
set colour [punk::ansi::a+ yellow bold] |
|
set reset_state_colour $colour |
|
} |
|
3 { |
|
set colour [punk::ansi::a+ green] |
|
set set_state_colour $colour |
|
} |
|
4 { |
|
set colour [punk::ansi::a+ yellow bold] |
|
set reset_state_colour $colour |
|
} |
|
default { |
|
#unexpected |
|
} |
|
} |
|
if {$colour ne ""} { |
|
set RST "\x1b\[m" |
|
} |
|
set testdisplay $colour$testresult$RST |
|
} else { |
|
if {$only_supported} { |
|
#ansi_has_mode still queries terminal - but is cached if a response was received |
|
if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} { |
|
continue |
|
} |
|
} |
|
} |
|
foreach itm $items { |
|
set code $colour$code$RST |
|
set names $colour[dict get $itm names]$RST |
|
set origin [dict get $itm origin] |
|
set desc [dict get $itm description] |
|
set set_state $set_state_colour[dict get $itm set-state]$RST |
|
set reset_state $reset_state_colour[dict get $itm reset-state]$RST |
|
|
|
set row [list $code [join $names \n] $origin $desc $set_state $reset_state] |
|
if {$do_test} { |
|
lappend row $testdisplay |
|
} |
|
$t add_row $row |
|
} |
|
} |
|
set out [$t print] |
|
$t destroy |
|
return $out |
|
} |
|
|
|
#see https://vt100.net/dec/ek-vt520-rm.pdf |
|
set DECRQSS_DATA { |
|
"Assign Color" DECAC ",|" |
|
"Alternate Text Color" DECATC ",\}" |
|
"CRT Saver Timing" DECCRTST "-q" |
|
"Down Line Load Allocation" DECDLDA ",z" |
|
"Energy Save Timing" DECSEST "-r" |
|
"Select Auto Repeat Rate" DECARR "-p" |
|
"Select Active Status Display" DECSASD "$\}" |
|
"Select Attribute Change Extent" DECSACE "*x" |
|
"Set Character Attribute" DECSCA "\"q" |
|
"Select Communication Port" DECSCP "*u" |
|
"Set Columns Per Page" DECSCPP "\$|" |
|
"Set Conformance Level" DECSCL "\"p" |
|
"Select Communication Speed" DECSCS "*r" |
|
"Set Cursor Style" DECSCUSR " q" |
|
"Select Disconnect Delay Time" DECSDDT "\$q" |
|
"Select Digital Printed Data Type" DECSDPT "(p" |
|
"Select Flow Control Type" DECSFC "*s" |
|
"Set Key Click Volume" DECSKCV " r" |
|
"Set Lock Key Style" DECSLCK " v" |
|
"Set Left and Right Margins" DECSLRM "s" |
|
"Set Lines Per Page" DECSLPP "t" |
|
"Set Margin Bell Volume" DECSMBV " u" |
|
"Set Number of Lines per Screen" DECSNLS "*|" |
|
"Session Page Memory Allocation" DECSPMA ",x" |
|
"Set Port Parameter" DECSPP "\+w" |
|
"Select ProPrinter Character Set" DECSPPCS "*p" |
|
"Select Printer Type" DECSPRTT "\$s" |
|
"Select Refresh Rate" DECSRFR "\"t" |
|
"Set Scroll Speed" DECSSCLS " p" |
|
"Set Status Line Type" DECSSDT "$~" |
|
"Select Set-Up Language" DECSSL "p" |
|
"Set Top and Bottom Margins" DECSTBM "r" |
|
"Select Color Lookup Table" DECSTGLT ")\{" |
|
"Set Transmit Rate Limit" DECSTRL "u" |
|
"Set Warning Bell Volume" DECSWBV " t" |
|
"Select Zero Symbol" DECSZS ",\{" |
|
"Terminal Mode Emulation" DECTME " ~" |
|
"Set Graphic Rendition" SGR "m" |
|
"invalid" invalid ".." |
|
} |
|
set DECRQSS_DICT [dict create] |
|
foreach {desc name str} $DECRQSS_DATA { |
|
dict set DECRQSS_DICT $name $str |
|
} |
|
|
|
|
|
namespace eval argdoc { |
|
proc decrqss_choices_and_help {} { |
|
#return a string for use in the punk::args definition for ::punk::console::dec_request_setting that lists the valid choices for the name argument, and their help text. |
|
#This requires a -choices and -choicelabels pair in the args definition, to allow the help text to be directly associated with the choices. |
|
upvar ::punk::console::DECRQSS_DATA DECRQSS_DATA |
|
set outstr "name -type string -choices \{" |
|
foreach {desc name str} $DECRQSS_DATA { |
|
append outstr " $name" |
|
} |
|
append outstr " \}" |
|
append outstr " -choicecolumns 4 -choicelabels \{" \n |
|
foreach {desc name str} $DECRQSS_DATA { |
|
append outstr " $name \{ ${desc}\}" \n |
|
} |
|
append outstr " \} -help " |
|
append outstr " {Dec setting name to query.}" |
|
return $outstr |
|
|
|
#append argdef " \} -choicecolumns $opt_columns -choicelabels \{" \n |
|
#append argdef " $choicelabelsdict" \n |
|
#append argdef " \} -choiceinfo \{$choiceinfodict\} -unindentedfields \{-choicelabels\}" \n |
|
} |
|
set DECRQSS_CHOICES [::punk::console::argdoc::decrqss_choices_and_help] |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::dec_request_setting |
|
@cmd -name punk::console::dec_request_setting\ |
|
-summary\ |
|
{Perform DECRQSS query to get DECRPSS response}\ |
|
-help\ |
|
{DECRQSS query for DEC Selection or Setting. |
|
Return payload from console's DECRPSS response. |
|
} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 1 -max 1 |
|
${$DECRQSS_CHOICES} |
|
} |
|
] |
|
} |
|
#emit DECRQSS and get DECRPSS response |
|
# --------------------- |
|
#NOTE: https://vt100.net/docs/vt510-rm/DECRPSS.html |
|
#response: DCS Ps $ r D...D ST |
|
#Conflict between above doc saying Ps of 0 indicates a valid request and 1 indicates invalid - and the behaviour of windows terminal, wezterm and the reported xterm behaviour |
|
# shown at: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html |
|
#REVIEW |
|
# --------------------- |
|
#Note also on Freebsd xterm we seem to get response ': 1 $ r D...D ST' |
|
#(no leading DCS) - review |
|
|
|
proc dec_request_setting {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting] |
|
lassign [dict values $argd] leaders opts values |
|
set console [dict get $opts -console] |
|
set name [dict get $values name] |
|
|
|
variable DECRQSS_DICT |
|
if {![dict exists $DECRQSS_DICT $name]} { |
|
error "dec_request_setting unrecognised name $name. Known values: [dict keys $DECRQSS_DICT]" |
|
} |
|
set str [dict get $DECRQSS_DICT $name] |
|
set re_str [string map [list | \\| * \\* \$ \\\$ + \\+ ( \\( ) \\)] $str] ;#regex escaped |
|
#review {[0-9;:]} - too restrictive? - what values can be returned? alnum? - we perhaps at least need to exclude ESC so we don't overmatch |
|
set capturingregex [string map [list %s% $re_str] {(.*)(\x1bP([0-1]\$r[0-9;:]*)(?:%s%){0,1}\x1b\\)$}] ;#must capture prefix,entire-response,response-payload |
|
#todo - handle xterm : [0-1] $ r D...D ST |
|
set request "\x1bP\$q${str}\x1b\\" |
|
set payload [punk::console::internal::get_ansi_response_payload -console $console $request $capturingregex] |
|
set c1 [string index $payload 0] |
|
switch -- $c1 { |
|
0 { |
|
error "dec_request_setting - terminal doesn't support querying settings for $name '[punk::ansi::ansistring VIEW $request]'" |
|
} |
|
1 {} |
|
default { |
|
#probable timeout - terminal doesn't recognise/respond |
|
error "dec_request_setting - unrecognised or missing response to request '[punk::ansi::ansistring VIEW $request]'. payload: [punk::ansi::ansistring VIEW $payload]" |
|
} |
|
} |
|
#strip leading 1$r |
|
return [string range $payload 3 end] |
|
} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::cursor_style |
|
@cmd -name punk::console::cursor_style\ |
|
-summary\ |
|
{Get/Set cursor style}\ |
|
-help\ |
|
{Set cursor style using DECSCUSR. |
|
Note that support for DECSCUSR may be inconsistent across terminals. |
|
Some terminals may only support a subset of the possible styles.} |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]} |
|
@values -min 0 -max 1 |
|
style -type dict -optional 1 -choicerestricted 0 -choices {0 default 1 block-blink 2 block-steady 3 underline-blink 4 underline-steady 5 beam-blink 6 beam-steady} -choicecolumns 2 -help\ |
|
"Cursor style to set |
|
May be an integer or name as in the choices or a dict of the form {<num> <name>} |
|
as returned by a query of the current style. |
|
|
|
e.g to set block-blink style, you could specify style as 1, block-blink or {1 block-blink} |
|
|
|
After setting to 0 (default) - a subsequent query will not return {0 default} but rather the number and name |
|
of the actual style that the terminal has reset to. |
|
|
|
If not supplied, the current style will be queried and returned as a dict |
|
where num is the key and name is the value, e.g. {2 block-steady}. |
|
This allows querying the current style and then re-setting it after temporarily changing it." |
|
}] |
|
} |
|
|
|
proc cursor_style {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::console::cursor_style] |
|
lassign [dict values $argd] leaders opts values |
|
set console [dict get $opts -console] |
|
set style "" ;#if not supplied, will query current style instead of setting |
|
set style_num_to_name [dict create {*}{ |
|
0 default |
|
1 block-blink |
|
2 block-steady |
|
3 underline-blink |
|
4 underline-steady |
|
5 beam-blink |
|
6 beam-steady |
|
}] |
|
set style_name_to_num [dict create {*}{ |
|
default 0 |
|
block-blink 1 |
|
block-steady 2 |
|
underline-blink 3 |
|
underline-steady 4 |
|
beam-blink 5 |
|
beam-steady 6 |
|
}] |
|
if {[dict exists $values style]} { |
|
set style [dict get $values style] |
|
} |
|
if {$style eq ""} { |
|
#query current style using DECRQSS/DECRPSS (dec_request_setting DECSCUSR) |
|
set resultnum [dec_request_setting -console $console DECSCUSR] |
|
if {![string is integer -strict $resultnum]} { |
|
error "cursor_style query for current style returned non-integer result '$resultnum'" |
|
} |
|
if {![dict exists $style_num_to_name $resultnum]} { |
|
error "cursor_style query for current style returned unrecognised style number '$resultnum'. Known styles: [dict keys $style_num_to_name]" |
|
} |
|
set resultname [dict get $style_num_to_name $resultnum] |
|
set result [dict create $resultnum $resultname] |
|
return $result |
|
} |
|
if {[string is integer -strict $style]} { |
|
set style_num $style |
|
if {![dict exists $style_num_to_name $style_num]} { |
|
error "cursor_style unrecognised style number '$style_num'. Known styles: [dict keys $style_num_to_name]" |
|
} |
|
} elseif {[::punk::args::lib::string_is_dict $style]} { |
|
#allow setting cursor using the response from a previous call to query the current style. |
|
if {[dict size $style] != 1} { |
|
error "cursor_style style dict should have exactly one key-value pair {<num> <style>}. Got [dict size $style]" |
|
} |
|
dict for {style_num style_name} $style {} ;#extract the num and name from the dict. |
|
if {![string is integer -strict $style_num]} { |
|
error "cursor_style style dict should be of the form {<num> <value>}. Got '$style'" |
|
} |
|
if {![dict exists $style_num_to_name $style_num]} { |
|
error "cursor_style unrecognised style number '$style_num'. Known styles: [dict keys $style_num_to_name]" |
|
} |
|
if {![dict exists $style_name_to_num $style_name]} { |
|
error "cursor_style unrecognised style name '$style_name'. Known styles: [dict keys $style_name_to_num]" |
|
} |
|
} else { |
|
if {![dict exists $style_name_to_num $style]} { |
|
error "cursor_style unrecognised style '$style'. Known styles: [dict keys $style_name_to_num]" |
|
} |
|
set style_num [dict get $style_name_to_num $style] |
|
} |
|
#set cursor style using DECSCUSR |
|
set request "\x1b\[${style_num} q" |
|
set term_out [dict get [console_spec_resolve $console] out] |
|
puts -nonewline $term_out $request |
|
flush $term_out |
|
} |
|
|
|
#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?) |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::test_char_width |
|
@cmd -name punk::console::test_char_width -summary "Measure a string's rendered width via cursor position reports." |
|
@leaders |
|
char_or_string -type string |
|
emit -type boolean -default 0 -optional 1 -help\ |
|
"Leave the test string visible instead of erasing the line around the test." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc test_char_width {char_or_string args} { |
|
#see PUNKARGS id ::punk::console::test_char_width |
|
#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] |
|
} |
|
set emit 0 |
|
if {[llength $args] % 2 == 1} { |
|
set emit [lindex $args 0] |
|
set args [lrange $args 1 end] |
|
} |
|
set inoutchannels [internal::opt_console_channels $args] |
|
set out [lindex $inoutchannels 1] |
|
|
|
if {!$emit} { |
|
puts -nonewline $out \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 |
|
} |
|
set response "" |
|
if {[catch { |
|
set response [punk::console::get_cursor_pos $inoutchannels] |
|
} 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 $out $char_or_string |
|
} errM]} { |
|
puts stderr "test_char_width couldn't emit this string - \nerror: $errM" |
|
} |
|
|
|
set response [punk::console::get_cursor_pos $inoutchannels] |
|
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 $out \033\[2K\033\[1G |
|
} |
|
flush $out;#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 |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::test_string_cursor |
|
@cmd -name punk::console::test_string_cursor -summary "Report cursor row/column offsets produced by emitting a string (uses alt screen)." |
|
@leaders |
|
teststring -type string |
|
emit -type boolean -default 0 -optional 1 -help\ |
|
"Leave the test string visible instead of erasing the line around the test." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc test_string_cursor {teststring args} { |
|
#see PUNKARGS id ::punk::console::test_string_cursor |
|
variable ansi_available |
|
if {!$ansi_available} { |
|
puts stderr "No ansi - cannot test char_width of '$teststring' returning [string length $teststring]" |
|
return [string length $teststring] |
|
} |
|
set emit 0 |
|
if {[llength $args] % 2 == 1} { |
|
set emit [lindex $args 0] |
|
set args [lrange $args 1 end] |
|
} |
|
set inoutchannels [internal::opt_console_channels $args] |
|
set out [lindex $inoutchannels 1] |
|
punk::console::enable_alt_screen -console $inoutchannels |
|
punk::console::move 0 0 -console $inoutchannels |
|
if {!$emit} { |
|
puts -nonewline $out \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 |
|
} |
|
set response "" |
|
if {[catch { |
|
set response [punk::console::get_cursor_pos $inoutchannels] |
|
} 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 $out $teststring |
|
flush $out |
|
set response [punk::console::get_cursor_pos $inoutchannels] |
|
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 $out \033\[2K\033\[1G |
|
} |
|
flush $out;#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 -console $inoutchannels |
|
return [list rowoffset [expr {$row2 - $row1}] columnoffset [expr {$col2 - $col1}]] |
|
} |
|
|
|
#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 ""} { |
|
if {[catch {twapi::get_console_handle stdout} h_out]} { |
|
puts stderr "test_can_ansi: twapi cannot get console handle for stdout" |
|
return 0 |
|
} |
|
set existing_mode [twapi::GetConsoleMode $h_out] |
|
if {$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 (per-console fact storage for the default console) |
|
#todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::grapheme_cluster_support |
|
@cmd -name punk::console::grapheme_cluster_support -summary\ |
|
"Determine terminal grapheme cluster support (decmode 2027), as a dict with keys available and mode."\ |
|
-help\ |
|
"Returns a pre-recorded per-console fact if one exists (see console_fact_get/console_fact_set) |
|
- otherwise queries the console each call (the query result is not auto-recorded as the mode |
|
may change during a session)." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc grapheme_cluster_support {args} { |
|
#see PUNKARGS id ::punk::console::grapheme_cluster_support |
|
set inout [internal::opt_console_channels $args] |
|
set recorded [console_fact_get $inout grapheme_cluster_support] |
|
if {[dict size $recorded]} { |
|
return $recorded |
|
} |
|
|
|
if {[lindex $inout 0] eq "stdin" && [lindex $inout 1] eq "stdout" && [info exists ::env(TERM_PROGRAM)]} { |
|
#env hints describe the process's own terminal - only trust them for the default console |
|
#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) (2025-12 update - 2027 request works) |
|
# 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 [dec_get_mode -console $inout 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 punk_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] |
|
#} |
|
#The emit functions in this namespace accept an optional trailing '-console <consolespec>' |
|
#pair (see PUNKARGS id ::punk::console::argdoc::console_emit_opts), parsed manually for |
|
#performance via ::punk::console::internal::opt_console_out and friends. Each proc's |
|
#PUNKARGS definition is documentation-only and must be kept synchronized with the parsing. |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::clear |
|
@cmd -name punk::console::ansi::clear -summary "Emit clear-display sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc clear {args} { |
|
#see PUNKARGS id ::punk::console::ansi::clear |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::clear_above |
|
@cmd -name punk::console::ansi::clear_above -summary "Emit clear-above-cursor sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc clear_above {args} { |
|
#see PUNKARGS id ::punk::console::ansi::clear_above |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear_above] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::clear_below |
|
@cmd -name punk::console::ansi::clear_below -summary "Emit clear-below-cursor sequence (ANSI or vt52)." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc clear_below {args} { |
|
#see PUNKARGS id ::punk::console::ansi::clear_below |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::clear_below] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52clear_below] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::clear_all |
|
@cmd -name punk::console::ansi::clear_all -summary "Emit clear-all sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc clear_all {args} { |
|
#see PUNKARGS id ::punk::console::ansi::clear_all |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear_all] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::clear_scrollback |
|
@cmd -name punk::console::ansi::clear_scrollback -summary "Emit clear-scrollback sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc clear_scrollback {args} { |
|
#see PUNKARGS id ::punk::console::ansi::clear_scrollback |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear_scrollback] |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::S8C1R |
|
@cmd -name punk::console::ansi::S8C1R -summary "Emit S8C1R (request 8-bit C1 response) sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc S8C1R {args} { |
|
#see PUNKARGS id ::punk::console::ansi::S8C1R |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::S8C1R] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::reset |
|
@cmd -name punk::console::ansi::reset -summary "Emit terminal reset sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc reset {args} { |
|
#see PUNKARGS id ::punk::console::ansi::reset |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::reset] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursor_on |
|
@cmd -name punk::console::ansi::cursor_on -summary "Emit cursor-visible sequence (ANSI or vt52)." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursor_on {args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursor_on |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::cursor_on] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52cursor_on] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursor_off |
|
@cmd -name punk::console::ansi::cursor_off -summary "Emit cursor-hidden sequence (ANSI or vt52)." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursor_off {args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursor_off |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::cursor_off] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52cursor_off] |
|
} |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move |
|
@cmd -name punk::console::ansi::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 dec_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. |
|
|
|
} |
|
@leaders |
|
row -type integer -help\ |
|
"row number - starting at 1" |
|
col -type integer -help\ |
|
"column number - starting at 1" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move {row col args} { |
|
#see PUNKARGS id ::punk::console::ansi::move |
|
#returns the sequence as a string - the -console spec selects ANSI vs vt52 encoding |
|
#based on that console's is_vt52 fact (no emission occurs here) |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
return [punk::ansi::move $row $col] |
|
} else { |
|
return [punk::ansi::vt52move $row $col] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_forward |
|
@cmd -name punk::console::ansi::move_forward -summary "Emit cursor-forward sequence (ANSI or vt52)." |
|
@leaders |
|
n -type integer -help "number of columns to move forward" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_forward {n args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_forward |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::move_forward $n] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52move_forward $n] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_back |
|
@cmd -name punk::console::ansi::move_back -summary "Emit cursor-back sequence (ANSI or vt52)." |
|
@leaders |
|
n -type integer -help "number of columns to move back" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_back {n args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_back |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::move_back $n] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52move_back $n] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_up |
|
@cmd -name punk::console::ansi::move_up -summary "Emit cursor-up sequence (ANSI or vt52)." |
|
@leaders |
|
n -type integer -help "number of rows to move up" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_up {n args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_up |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::move_up $n] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52move_up $n] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_down |
|
@cmd -name punk::console::ansi::move_down -summary "Emit cursor-down sequence (ANSI or vt52)." |
|
@leaders |
|
n -type integer -help "number of rows to move down" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_down {n args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_down |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::move_down $n] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52move_down $n] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_column |
|
@cmd -name punk::console::ansi::move_column -summary "Emit move-to-column sequence (ANSI or vt52)." |
|
@leaders |
|
col -type integer -help "column number - starting at 1" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_column {col args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_column |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::move_column $col] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52move_column $col] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_row |
|
@cmd -name punk::console::ansi::move_row -summary "Emit move-to-row sequence." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_row {row args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_row |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::move_row $row] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_emit |
|
@cmd -name punk::console::ansi::move_emit -summary "Emit data at row,col (ANSI or vt52)." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
data -type string |
|
triple -type any -optional 1 -multiple 1 -help\ |
|
"additional row col data triples" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_emit {row col data args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_emit |
|
set inout [::punk::console::internal::opt_console_channels_var args] |
|
set out [lindex $inout 1] |
|
if {![punk::console::console_fact_get $inout is_vt52]} { |
|
puts -nonewline $out [punk::ansi::move_emit $row $col $data {*}$args] |
|
} else { |
|
puts -nonewline $out [punk::ansi::vt52move_emit $row $col $data {*}$args] |
|
} |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_emit_return |
|
@cmd -name punk::console::ansi::move_emit_return -summary "Emit data at row,col then return cursor to its previous position." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
data -type string |
|
triple -type any -optional 1 -multiple 1 -help\ |
|
"additional row col data triples" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_emit_return {row col data args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_emit_return |
|
#todo detect if in raw mode or not? |
|
set is_in_raw 0 |
|
set inout [::punk::console::internal::opt_console_channels_var args] |
|
lassign [punk::console::get_cursor_pos_list $inout] orig_row orig_col |
|
|
|
set commands "" |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
foreach {row col data} $args { |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
} |
|
if {!$is_in_raw} { |
|
incr orig_row -1 |
|
} |
|
append commands [punk::ansi::move $orig_row $orig_col] |
|
puts -nonewline [lindex $inout 1] $commands |
|
return "" |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_emitblock_return |
|
@cmd -name punk::console::ansi::move_emitblock_return -summary "Emit a multiline textblock at row,col then return cursor to its previous position." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
textblock -type string |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_emitblock_return {row col textblock args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_emitblock_return |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
lassign [punk::console::get_cursor_pos_list $inout] orig_row orig_col |
|
|
|
set commands [punk::ansi::move_emit $row $col $textblock] ;#move_emit can handle multiple line blocks. |
|
#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 [lindex $inout 1] $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.. |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursorsave_move_emit_return |
|
@cmd -name punk::console::ansi::cursorsave_move_emit_return -summary "Emit data at row,col bracketed by cursor save/restore (ANSI or vt52)." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
data -type string |
|
triple -type any -optional 1 -multiple 1 -help\ |
|
"additional row col data triples" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursorsave_move_emit_return {row col data args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursorsave_move_emit_return |
|
set inout [::punk::console::internal::opt_console_channels_var args] |
|
set out [lindex $inout 1] |
|
#JMN |
|
set commands "" |
|
if {![punk::console::console_fact_get $inout 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::vt52cursor_save] |
|
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::vt52cursor_restore] |
|
} |
|
puts -nonewline $out $commands; flush $out |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursorsave_move_emitblock_return |
|
@cmd -name punk::console::ansi::cursorsave_move_emitblock_return -summary "Emit a multiline textblock at row,col bracketed by cursor save/restore (ANSI or vt52)." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
textblock -type string |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursorsave_move_emitblock_return {row col textblock args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursorsave_move_emitblock_return |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
set commands "" |
|
if {![punk::console::console_fact_get $inout 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::vt52cursor_save] |
|
foreach ln [split $textblock \n] { |
|
append commands [punk::ansi::vt52move_emit $row $col $ln] |
|
incr row |
|
} |
|
append commands [punk::ansi::vt52cursor_restore] |
|
} |
|
puts -nonewline $out $commands;flush $out |
|
return |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::move_call_return |
|
@cmd -name punk::console::ansi::move_call_return -summary "Move cursor to row,col, run script, then return cursor to its previous position." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
script -type string |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc move_call_return {row col script args} { |
|
#see PUNKARGS id ::punk::console::ansi::move_call_return |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set out [lindex $inout 1] |
|
lassign [punk::console::get_cursor_pos_list $inout] orig_row orig_col |
|
#move here is the string-returning ansi::move - emit its result explicitly |
|
puts -nonewline $out [move $row $col -console $inout] |
|
uplevel 1 $script |
|
puts -nonewline $out [move $orig_row $orig_col -console $inout] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::scroll_up |
|
@cmd -name punk::console::ansi::scroll_up -summary "Emit scroll-up sequence." |
|
@leaders |
|
n -type integer -help "number of rows to scroll" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc scroll_up {n args} { |
|
#see PUNKARGS id ::punk::console::ansi::scroll_up |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::scroll_up $n] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::scroll_down |
|
@cmd -name punk::console::ansi::scroll_down -summary "Emit scroll-down sequence." |
|
@leaders |
|
n -type integer -help "number of rows to scroll" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc scroll_down {n args} { |
|
#see PUNKARGS id ::punk::console::ansi::scroll_down |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::scroll_down $n] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::enable_alt_screen |
|
@cmd -name punk::console::ansi::enable_alt_screen -summary "Emit switch-to-alternate-screen sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc enable_alt_screen {args} { |
|
#see PUNKARGS id ::punk::console::ansi::enable_alt_screen |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::enable_alt_screen] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::disable_alt_screen |
|
@cmd -name punk::console::ansi::disable_alt_screen -summary "Emit switch-to-main-screen sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc disable_alt_screen {args} { |
|
#see PUNKARGS id ::punk::console::ansi::disable_alt_screen |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [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 |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursor_save |
|
@cmd -name punk::console::ansi::cursor_save -summary "Emit SCOSC cursor-save sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursor_save {args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursor_save |
|
#*** !doctools |
|
#[call [fun cursor_save]] |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[s |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursor_restore |
|
@cmd -name punk::console::ansi::cursor_restore -summary "Emit SCORC cursor-restore sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursor_restore {args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursor_restore |
|
#*** !doctools |
|
#[call [fun cursor_restore]] |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[u |
|
} |
|
#DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursor_save_dec |
|
@cmd -name punk::console::ansi::cursor_save_dec -summary "Emit DECSC cursor-save sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursor_save_dec {args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursor_save_dec |
|
#*** !doctools |
|
#[call [fun cursor_save_dec]] |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b7 |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::cursor_restore_dec |
|
@cmd -name punk::console::ansi::cursor_restore_dec -summary "Emit DECRC cursor-restore sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc cursor_restore_dec {args} { |
|
#see PUNKARGS id ::punk::console::ansi::cursor_restore_dec |
|
#*** !doctools |
|
#[call [fun cursor_restore_dec]] |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b8 |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::insert_spaces |
|
@cmd -name punk::console::ansi::insert_spaces -summary "Emit insert-spaces (ICH) sequence." |
|
@leaders |
|
count -type integer |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc insert_spaces {count args} { |
|
#see PUNKARGS id ::punk::console::ansi::insert_spaces |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}@ |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::delete_characters |
|
@cmd -name punk::console::ansi::delete_characters -summary "Emit delete-characters (DCH) sequence." |
|
@leaders |
|
count -type integer |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc delete_characters {count args} { |
|
#see PUNKARGS id ::punk::console::ansi::delete_characters |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}P |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::erase_characters |
|
@cmd -name punk::console::ansi::erase_characters -summary "Emit erase-characters (ECH) sequence." |
|
@leaders |
|
count -type integer |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc erase_characters {count args} { |
|
#see PUNKARGS id ::punk::console::ansi::erase_characters |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}X |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::insert_lines |
|
@cmd -name punk::console::ansi::insert_lines -summary "Emit insert-lines (IL) sequence." |
|
@leaders |
|
count -type integer |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc insert_lines {count args} { |
|
#see PUNKARGS id ::punk::console::ansi::insert_lines |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}L |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::delete_lines |
|
@cmd -name punk::console::ansi::delete_lines -summary "Emit delete-lines (DL) sequence." |
|
@leaders |
|
count -type integer |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc delete_lines {count args} { |
|
#see PUNKARGS id ::punk::console::ansi::delete_lines |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}M |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::titleset |
|
@cmd -name punk::console::ansi::titleset -summary "Emit window-title (OSC) sequence." |
|
@leaders |
|
windowtitle -type string |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc titleset {windowtitle args} { |
|
#see PUNKARGS id ::punk::console::ansi::titleset |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::titleset $windowtitle] |
|
} |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::ansi::test_decaln |
|
@cmd -name punk::console::ansi::test_decaln -summary "Emit DECALN screen-alignment test pattern sequence." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc test_decaln {args} { |
|
#see PUNKARGS id ::punk::console::ansi::test_decaln |
|
puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::test_decaln] |
|
} |
|
} |
|
if {[catch {namespace import ::punk::console::ansi::*} errm]} { |
|
puts stderr "Error importing ansi commands into punk::console namespace: $errm" |
|
puts stderr "REVIEW - package loaded or partially loadded earlier?" |
|
#puts stderr "titleset [info body ::punk::console::titleset]" |
|
#error $errm |
|
} |
|
catch {rename titleset ""} |
|
#namespace import ansi::titleset |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::titleset |
|
@cmd -name punk::console::titleset -summary "Set the terminal window title (ANSI or local mechanism)." |
|
@leaders |
|
windowtitle -type string |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc titleset {windowtitle args} { |
|
#see PUNKARGS id ::punk::console::titleset |
|
variable ansi_wanted |
|
if { $ansi_wanted <= 0} { |
|
#local mechanism acts on the process console regardless of any -console argument |
|
internal::opt_console_out $args ;#validate the tail even though the channel is unused |
|
punk::console::local::titleset $windowtitle |
|
} else { |
|
ansi::titleset $windowtitle {*}$args |
|
} |
|
} |
|
#no known pure-ansi solution |
|
proc titleget {} { |
|
return [local::titleget] |
|
} |
|
|
|
#emitting counterpart of the string-returning ansi::move (the imported command is renamed away) |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::move |
|
@cmd -name punk::console::move -summary "Emit ANSI or vt52 sequence moving the cursor to row,col." |
|
@leaders |
|
row -type integer -help "row number - starting at 1" |
|
col -type integer -help "column number - starting at 1" |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
catch {rename move ""} |
|
proc move {row col args} { |
|
#see PUNKARGS id ::punk::console::move |
|
puts -nonewline [internal::opt_console_out $args] [ansi::move $row $col {*}$args] |
|
} |
|
|
|
|
|
|
|
#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 PUNKARGS |
|
#the has_bug_* results are per-console facts (see punk::console::console_fact_get); these |
|
#namespace variables are the storage for the process-default console {stdin stdout} |
|
variable has_bug_legacysymbolwidth -1 ;#undetermined |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::check::has_bug_legacysymbolwidth |
|
@cmd -name punk::console::check::has_bug_legacysymbolwidth -summary\ |
|
"Test (cached per console) whether the terminal miscounts legacy symbol widths." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc has_bug_legacysymbolwidth {args} { |
|
#see PUNKARGS id ::punk::console::check::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 |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set cached [punk::console::console_fact_get $inout has_bug_legacysymbolwidth] |
|
if {!$cached} { |
|
return 0 |
|
} |
|
if {$cached == -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 -console $inout] |
|
if {$w == 1} { |
|
set verdict 0 |
|
} else { |
|
#can return 2 on legacy window consoles for example |
|
set verdict 1 |
|
} |
|
punk::console::console_fact_set $inout has_bug_legacysymbolwidth $verdict |
|
return $verdict |
|
} |
|
return 1 |
|
} |
|
variable has_bug_zwsp -1 ;#undetermined |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::check::has_bug_zwsp |
|
@cmd -name punk::console::check::has_bug_zwsp -summary\ |
|
"Test (cached per console) whether the terminal mishandles inline zero-width-space width." |
|
@opts |
|
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} |
|
@values -min 0 -max 0 |
|
}] |
|
proc has_bug_zwsp {args} { |
|
#see PUNKARGS id ::punk::console::check::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. |
|
set inout [::punk::console::internal::opt_console_channels $args] |
|
set cached [punk::console::console_fact_get $inout has_bug_zwsp] |
|
if {!$cached} { |
|
return 0 |
|
} |
|
if {$cached == -1} { |
|
set w [punk::console::test_char_width X\u200bY -console $inout] |
|
if {$w == 2} { |
|
set verdict 0 |
|
} else { |
|
#may return 3 - but this gives no indication of whether terminal hides it or not. |
|
set verdict 1 |
|
} |
|
punk::console::console_fact_set $inout has_bug_zwsp $verdict |
|
return $verdict |
|
} |
|
return 1 |
|
} |
|
|
|
} |
|
namespace eval punk::console::system { |
|
|
|
proc enableRaw_stty {{channel stdin}} { |
|
upvar ::punk::console::previous_stty_state_$channel 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 "" |
|
} |
|
} |
|
|
|
#REVIEW |
|
switch $channel { |
|
stdin { |
|
exec {*}$sttycmd -icanon -echo -isig |
|
} |
|
default { |
|
exec {*}$sttycmd raw -echo <@$channel |
|
} |
|
} |
|
if {[catch { |
|
tsv::set punk_console is_raw 1 |
|
} errMsg]} { |
|
puts stderr "enableRaw_stty failed to run tsv::set punk_console is_raw 1: $errMsg" |
|
} |
|
catch { |
|
chan configure stdin -inputmode raw |
|
} |
|
#puts "enableRaw_stty previous_stty_state_$channel: [set previous_stty_state_$channel]" |
|
return [dict create previous [set previous_stty_state_$channel]] |
|
} |
|
proc disableRaw_stty {{channel stdin}} { |
|
upvar ::punk::console::previous_stty_state_$channel 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 "" |
|
} |
|
|
|
switch $channel { |
|
stdin { |
|
exec {*}$sttycmd icanon echo isig |
|
} |
|
default { |
|
exec {*}$sttycmd -raw echo <@$channel |
|
} |
|
} |
|
if {[catch { |
|
tsv::set punk_console is_raw 0 |
|
} errMsg]} { |
|
puts stderr "disableRaw_stty failed to run tsv::set punk_console is_raw 0: $errMsg" |
|
} |
|
catch { |
|
chan configure stdin -inputmode normal |
|
} |
|
return done |
|
} |
|
|
|
proc enableRaw_mintty {{channel stdin}} { |
|
#mintty specific enableRaw |
|
upvar ::punk::console::previous_stty_state_$channel 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 "" |
|
} |
|
} |
|
|
|
#REVIEW |
|
switch $channel { |
|
stdin { |
|
exec {*}$sttycmd -icanon -echo -isig |
|
} |
|
default { |
|
exec {*}$sttycmd raw -echo <@$channel |
|
} |
|
} |
|
catch { |
|
tsv::set punk_console is_raw 1 |
|
} |
|
|
|
catch { |
|
chan configure stdin -inputmode raw |
|
} |
|
return [dict create previous [set previous_stty_state_$channel]] |
|
} |
|
proc disableRaw_mintty {{channel stdin}} { |
|
#mintty specific disableRaw |
|
upvar ::punk::console::previous_stty_state_$channel 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 "" |
|
#puts stderr "previous stty state restored" |
|
} else { |
|
#REVIEW |
|
switch $channel { |
|
stdin { |
|
exec {*}$sttycmd icanon echo isig |
|
} |
|
default { |
|
exec {*}$sttycmd -raw echo <@$channel |
|
} |
|
} |
|
} |
|
|
|
catch { |
|
tsv::set punk_console is_raw 0 |
|
} |
|
#mintty on windows seems to have -inputmode available when running with winpty, |
|
#and is missing the -inputmode key when running without winpty. |
|
#we could potentially use this as a detection method for whether we're running in mintty with or without winpty? |
|
|
|
#sometimes mintty on windows has -inputmode available - sometimes not |
|
#sometimes mintty seems to need -inputmode to be set manually. |
|
catch { |
|
chan configure stdin -inputmode normal |
|
} |
|
return done |
|
} |
|
|
|
#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 enableRaw_twapi {{channel stdin}} { |
|
#twapi version of enableRaw. |
|
upvar ::punk::console::previous_stty_state_$channel previous_stty_state_$channel |
|
|
|
if {[catch {twapi::get_console_handle stdin} console_handle]} { |
|
puts stderr "enableRaw error: twapi cannot get console handle for stdin" |
|
#review. If twapi couldn't get a console handle - no point trying other mechanisms(?) |
|
return |
|
} |
|
#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 punk_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]] |
|
} |
|
proc disableRaw_twapi {{channel stdin}} { |
|
#disableRaw twapi version |
|
upvar ::punk::console::previous_stty_state_$channel previous_stty_state_$channel |
|
set ch_state [chan conf $channel] |
|
if {[dict exists $ch_state -inputmode]} { |
|
chan conf $channel -inputmode normal |
|
tsv::set punk_console is_raw 0 |
|
return [list $channel [list from [dict get $ch_state -inputmode] to normal]] |
|
} else { |
|
if {[catch {twapi::get_console_handle stdin} console_handle]} { |
|
#e.g tkcon/wish |
|
puts stderr "disableRaw error: twapi cannot get console handle for stdin" |
|
return ;# ??? |
|
} |
|
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 punk_console is_raw 0 |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} |
|
} |
|
|
|
proc enableRaw_powershell {{channel stdin}} { |
|
#enableRaw_powershell is a fallback for when twapi is not present. |
|
#It uses a persistent powershell process to set the console mode to raw, by writing commands to a named pipe that the powershell process is listening on. |
|
|
|
#This does not need to be used in windows in the rare case where the console is an alternative terminal that supports stty (e.g mintty without winpty) |
|
#- but it is really intended for use in environments where twapi is not present and stty doesn't work (e.g standard windows console). |
|
|
|
#puts stderr "punk::console::enableRaw" |
|
upvar ::punk::console::previous_stty_state_$channel previous_stty_state_$channel |
|
upvar ::punk::console::ps_consolemode_contents ps_consolemode_contents |
|
upvar ::punk::console::ps_pipename ps_pipename |
|
|
|
|
|
if {[info exists ps_consolemode_contents]} { |
|
#ps_pipename e.g \\.\pipe\punkwinshell_ps_consolemode_12345-1223456 |
|
|
|
set trynum 0 |
|
set wrote 0 |
|
while {$trynum < 5} { |
|
incr trynum |
|
if {![catch { |
|
set pipe [open $ps_pipename w] |
|
} errMsg]} { |
|
chan conf $pipe -buffering line |
|
puts -nonewline $pipe "enableraw\r\n" |
|
#flush $pipe |
|
#after 10 |
|
#close $pipe |
|
set wrote 1 |
|
break |
|
} else { |
|
after 100 |
|
} |
|
} |
|
if {$wrote} { |
|
tsv::set punk_console is_raw 1 |
|
#after 100 |
|
close $pipe |
|
} else { |
|
puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg" |
|
} |
|
} elseif {[set sttycmd [auto_execok stty]] ne ""} { |
|
#todo - something else entirely |
|
#this approach does not *usually* work on windows |
|
#the msys/cygwin stty command is launched as a subprocess - can be used to retrieve info |
|
# but seems to be useless as far as affecting the calling process/console |
|
#An exception is when running in an msys/cygwin terminal - e.g mintty *when* it is configured to not use winpty |
|
#(e.g by setting environment variable MSYS = disable_pcon, prior to launch.) |
|
if {[set previous_stty_state_$channel] eq ""} { |
|
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] |
|
} |
|
|
|
exec {*}$sttycmd raw -echo <@$channel |
|
tsv::set punk_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" |
|
} |
|
} |
|
proc disableRaw_powershell {{channel stdin}} { |
|
#disableRaw powershell version |
|
upvar ::punk::console::previous_stty_state_$channel previous_stty_state_$channel |
|
|
|
set ch_state [chan conf $channel] |
|
if {[dict exists $ch_state -inputmode]} { |
|
chan conf $channel -inputmode normal |
|
tsv::set punk_console is_raw 0 |
|
return [list $channel [list from [dict get $ch_state -inputmode] to normal]] |
|
} else { |
|
#tcl <= 8.6x doesn't support -inputmode |
|
if {[set sttycmd [auto_execok stty]] ne ""} { |
|
#this doesn't work on windows |
|
#It may seem to - only because running *any* external utility can exit raw mode |
|
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 punk_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" |
|
} |
|
} |
|
} |
|
} |
|
|
|
namespace eval punk::console { |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
|
|
if {$has_twapi} { |
|
#this is really enableAnsi *processing* |
|
proc 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 |
|
if {[catch {twapi::get_console_handle stdout} h_out]} { |
|
puts stderr "enableAnsi failed: twapi cannot get console handle for stdout" |
|
return |
|
} |
|
|
|
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) enables reporting of windows resize events to console input buffer - no direct stty equiv for unix - sigwinch? |
|
#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}] |
|
|
|
|
|
##test |
|
#set newmode_in [expr {$oldmode_in & ~8}] |
|
#set newmode_in [expr {$newmode_in & ~0x200}] |
|
|
|
#twapi::SetConsoleMode $h_in $newmode_in |
|
|
|
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
return [list stdout [list from $oldmode_out to $newmode_out]] |
|
} |
|
proc 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}] |
|
|
|
##test |
|
#set newmode_in [expr {$oldmode_in | 8}] |
|
#set newmode_in [expr {$newmode_in | 0x200}] |
|
|
|
#twapi::SetConsoleMode $h_in $newmode_in |
|
|
|
|
|
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
return [list stdout [list from $oldmode_out to $newmode_out]] |
|
} |
|
proc 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 | 0x208}] |
|
#test |
|
#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 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 & ~0x208}] |
|
#test |
|
#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 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 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]] |
|
} |
|
|
|
proc enableRaw {{channel stdin}} [info body ::punk::console::system::enableRaw_twapi] |
|
proc disableRaw {{channel stdin}} [info body ::punk::console::system::disableRaw_twapi] |
|
|
|
} else { |
|
|
|
variable ps_consolemode_pid |
|
variable ps_consolemode_contents |
|
variable ps_pipename |
|
if {![info exists ps_consolemode_contents]} { |
|
#start persistent powershell consolemode_server.ps1 named pipe server |
|
#::argv0 is absent in secondary threads (thread::create workers, codethreads) - |
|
#the module must remain loadable there |
|
if {[info exists ::argv0] && $::argv0 ne ""} { |
|
set pstooldir [file dirname [file dirname [file normalize $::argv0]]]/scriptlib/utils/pwsh |
|
} else { |
|
set pstooldir [pwd] |
|
} |
|
#set ps_script $pstooldir/consolemode_server.ps1 |
|
set ps_script $pstooldir/consolemode_server_async.ps1 |
|
if {[file exists $ps_script]} { |
|
set fd [open $ps_script r] |
|
chan configure $fd -translation binary |
|
set ps_consoleid [pid]-[expr {int(999 * rand())+1}] |
|
set ps_consolemode_contents [string map [list "<punkshell_consoleid>" $ps_consoleid] [read $fd]] |
|
close $fd |
|
#set ps_consolemode_pipe [twapi::namedpipe_client {//./pipe/punkshell_ps_consolemode} -access write] |
|
#set ps_cmd [auto_execok pwsh.exe] |
|
set ps_cmd [auto_execok pwsh.exe] |
|
if {$ps_cmd eq ""} { |
|
set ps_cmd [auto_execok powershell.exe] |
|
} |
|
if {$ps_cmd ne ""} { |
|
set ps_consolemode_pid [exec {*}$ps_cmd -nop -nol -c $ps_consolemode_contents &] |
|
set ps_pipename {\\.\pipe\punkshell_ps_consolemode_} |
|
append ps_pipename $ps_consoleid |
|
puts stderr "twapi not present, using persistent powershell process: pipename: $ps_pipename pid: $ps_consolemode_pid" |
|
#todo - taskkill /F /PID $ps_consolemode_pid |
|
#when? |
|
#review |
|
#if {[catch {puts "pidinfo: [::tcl::process::status $ps_consolemode_pid]"} errM]} { |
|
# puts stderr "--- failed to get process status for $ps_consolemode_pid\n$errM" |
|
#} |
|
#set p [open {\\.\pipe\punkshell_ps_consolemode} w] |
|
#chan conf $p -buffering none -blocking 1 |
|
#puts $p "" |
|
#close $p |
|
} |
|
} |
|
|
|
} |
|
|
|
proc enableRaw {{channel stdin}} [info body ::punk::console::system::enableRaw_powershell] |
|
proc disableRaw {{channel stdin}} [info body ::punk::console::system::disableRaw_powershell] |
|
|
|
|
|
#enableAnsi |
|
proc enableAnsi {} { |
|
} |
|
#disableAnsi |
|
proc disableAnsi {} { |
|
} |
|
#enableVirtualTerminal |
|
proc enableVirtualTerminal {{channels {input output}}} { |
|
} |
|
#disableVirtualTerminal |
|
proc disableVirtualTerminal {{channels {input output}}} { |
|
} |
|
#enableProcessedInput |
|
#disableProcessedInput |
|
|
|
} |
|
|
|
} else { |
|
#non-windows platforms |
|
|
|
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 |
|
|
|
proc enableVirtualTerminal {{channels {input output}}} { |
|
|
|
} |
|
proc disableVirtualTerminal {args} { |
|
|
|
} |
|
proc enableRaw {{channel stdin}} [info body ::punk::console::system::enableRaw_stty] |
|
proc disableRaw {{channel stdin}} [info body ::punk::console::system::disableRaw_stty] |
|
} |
|
|
|
|
|
if { "windows" eq $::tcl_platform(platform) && [info exists ::env(TERM)] && $::env(TERM) eq "mintty"} { |
|
#note - TERM could also be mintty-direct - apparently for use with wsl. |
|
# - we don't use terminfo or termcap here as we try to use ansi device queries etc. Todo - review. |
|
|
|
#mintty could be running with or without winpty |
|
#- if with winpty then we should be able to use the twapi enableRaw and disableRaw which work with winpty |
|
#- but if without winpty then those won't work, but stty should work. |
|
|
|
#we use a secondary device attributes query to detect if we're running in mintty with winpty or without. |
|
|
|
#REVIEW |
|
#Here we have a chicken and egg problem. querying the console reliably often requires the console to be in |
|
#raw mode - but we need to query the console to know whether we can use the twapi raw mode functions or need to use the stty based ones. |
|
|
|
#another possible method is to detect the presence of -inputmode in the results of chan configure stdin. |
|
#Unknown if -inputmode is a concept that only applies to windows consoles or if it is (or will be) a more |
|
#general concept that may be present in other environments - if the latter then it won't be a reliable detection method for winpty vs mintty without winpty. |
|
|
|
|
|
#an ugly method - but perhaps practical is to just use both mechanisms wrapped in a catch. |
|
|
|
#we need to set raw mode true before calling any console query functions because the query functions will internally |
|
#try to set raw mode if it's not already flagged as set. |
|
|
|
if {[catch {punk::console::system::enableRaw_stty} errMsg]} { |
|
puts stderr "enableRaw_stty failed: $errMsg" |
|
} |
|
#try also the 'best guess' implementation of enableRaw we installed above - which will be the twapi version if twapi is present, or the powershell version if not. |
|
if {[catch {punk::console::enableRaw} errMsg]} { |
|
puts stderr "enableRaw failed: $errMsg" |
|
} |
|
|
|
#set failed_classinfo 1 |
|
set failed_classinfo [catch {punk::console::class_info} classinfo] |
|
#puts stderr "got_classinfo: $failed_classinfo classinfo: $classinfo" |
|
|
|
if {$failed_classinfo || [dict get $classinfo class] eq "mintty"} { |
|
#we seem to be running in mintty on windows without winpty |
|
#override the windows enableRaw and disableRaw with the custom unix-like versions which use stty - as the twapi versions don't work in this environment. |
|
|
|
#git bash uses mintty - but it seems to behave differently to msys mintty launched directly. |
|
|
|
proc enableRaw {{channel stdin}} [info body ::punk::console::system::enableRaw_mintty] |
|
proc disableRaw {{channel stdin}} [info body ::punk::console::system::disableRaw_mintty] |
|
} |
|
punk::console::disableRaw |
|
} |
|
} |
|
|
|
|
|
namespace eval punk::console { |
|
#G-007: mirror every write of the default-console legacy fact variables into tsv so |
|
#non-owner threads read current values (see the console_facts store comments). Installed |
|
#here, at the end of the module, so all legacy fact variables and their namespaces exist. |
|
#Re-source safe: an identical previously-installed trace is removed before adding. |
|
dict for {factkey factinfo} $console_fact_info { |
|
set _legacyvar [dict get $factinfo legacyvar] |
|
set _tracecmd [list ::punk::console::internal::default_fact_write_trace $factkey $_legacyvar] |
|
foreach _tinfo [trace info variable $_legacyvar] { |
|
lassign $_tinfo _top _tcmd |
|
if {$_top eq "write" && $_tcmd eq $_tracecmd} { |
|
trace remove variable $_legacyvar write $_tracecmd |
|
} |
|
} |
|
trace add variable $_legacyvar write $_tracecmd |
|
} |
|
unset -nocomplain factkey factinfo _legacyvar _tracecmd _tinfo _top _tcmd |
|
} |
|
|
|
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::argdoc ::punk::console::internal ::punk::console::local ::punk::console::ansi ::punk::console::check |
|
} |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::console [namespace eval punk::console { |
|
variable version |
|
set version 0.6.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end]
|
|
|