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.
6914 lines
332 KiB
6914 lines
332 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.8.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::console 0 0.8.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 |
|
|
|
#G-007 choke-point brokering: a query on a console owned by another thread runs in |
|
#the owning thread - where the cooperative reader protocol (input_chunks_waiting), |
|
#raw-mode arbitration and the authoritative settled can_respond live. Forwarding the |
|
#whole call means the queueing, raw cycling and reader cooperation below all execute |
|
#in the owner's context, and every query proc layered above this choke point |
|
#inherits the routing. Routed before the local can_respond gate deliberately: a |
|
#non-owner context's anchored view of the default console may be unsettled while |
|
#the owner's is settled. The synchronous thread::send is safe because the owner |
|
#services events while this thread blocks (the property the repl-installed vt52 |
|
#alias transport already relies on), and re-entry in the owner resolves to |
|
#owner==self so the forward cannot ping-pong. |
|
set route_owner [console_route_owner $inoutchannels] |
|
if {$route_owner ne ""} { |
|
try { |
|
return [thread::send $route_owner [list ::punk::console::internal::get_ansi_response_payload -console $inoutchannels -expected_ms $expected -ignoreok $ignoreok -return $returntype -passthrough $passthrough $query $capturingendregex]] |
|
} on error {errM erropts} { |
|
#preserve the owner-side errorcode (where the transport propagates it) so |
|
#callers can discriminate, e.g. {PUNK CONSOLE QUERY HOSTAGE_COOKED_READ} |
|
#from the idle-reader guard |
|
return -code error -errorcode [dict get $erropts -errorcode] "get_ansi_response_payload query routed to console-owning thread $route_owner failed: $errM" |
|
} |
|
} |
|
|
|
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" |
|
} |
|
|
|
#tcl 8.6 windows console idle-reader hostage guard (fail fast, no emission). |
|
#With the console in cooked (line) mode and a readable handler armed on the input |
|
#channel, the 8.6 channel driver has a blocking cooked-mode ReadConsole parked |
|
#(arming is what posts it), and driver reads sample the console mode at issue time - |
|
#the raw cycle below cannot rescue it. Any response would be swallowed by that read |
|
#until the user presses Enter, then leak to the line reader as phantom input |
|
#(~500ms timeout now, input corruption later). This is the idle-at-a-line-mode-prompt |
|
#condition: the repl disarms its reader during command dispatch, so mid-command |
|
#queries are unaffected, and raw mode reads cooperatively and is exempt. Typical |
|
#trigger: a query from an after-script or worker thread firing while the shell sits |
|
#at a line-mode prompt. Best-effort by design: a parked read can outlive a removed |
|
#handler, so this catches the systematic case, not every conceivable one. |
|
if {![tsv::get punk_console is_raw] && $input eq "stdin" && $::punk::console::has_twapi} { |
|
set guard_conf [chan configure $input] |
|
if {![dict exists $guard_conf -inputmode] && ![dict exists $guard_conf -mode] |
|
&& [chan event $input readable] ne "" |
|
&& ![catch {twapi::get_console_handle stdin}]} { |
|
return -code error -errorcode [list PUNK CONSOLE QUERY HOSTAGE_COOKED_READ]\ |
|
"punk::console::get_ansi_response_payload refusing to emit query on '$input': tcl 8.6 console is in cooked (line) mode with an armed readable handler - the driver's parked cooked read would swallow the response until Enter (query issued from an idle line-mode prompt?). Use raw mode, or issue queries while the reader is disarmed (e.g. during repl command evaluation)." |
|
} |
|
} |
|
|
|
#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 {!$input_is_console_or_tty && $input eq "stdin" && $::punk::console::has_twapi} { |
|
#Tcl 8.6 windows console channels have no -inputmode configure key, so the |
|
#dict test alone misclassifies a real 8.6 console as a pipe: the raw cycle |
|
#is then skipped and the query response sits in the cooked line buffer until |
|
#Enter - timeout here plus the response leaking to the line reader as phantom |
|
#input. A twapi console handle for stdin is definitive. Channels other than |
|
#stdin stay excluded - the guard's purpose (pipe probes must not flip the |
|
#process console) is unchanged. |
|
set input_is_console_or_tty [expr {![catch {twapi::get_console_handle stdin}]}] |
|
} |
|
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 |
|
} |
|
variable has_twapi |
|
if {$input eq "stdin" && $has_twapi && ![catch {twapi::get_console_handle stdin}]} { |
|
#Tcl 8.6 windows console channels expose no -inputmode key, so the dict test above |
|
#misses them. Beyond the pending-keystroke concern, the probe read is fatal here: |
|
#a read on a drained 8.6 console channel makes the channel driver park a blocking |
|
#cooked-mode ReadConsole that cannot be cancelled by a later raw-mode flip - it |
|
#swallows a terminal query response emitted afterwards (get_ansi_response_payload |
|
#calls this guard immediately before its raw cycle) and only completes on Enter. |
|
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 |
|
} |
|
variable has_twapi |
|
if {$input eq "stdin" && $has_twapi && ![catch {twapi::get_console_handle stdin}]} { |
|
#Tcl 8.6 windows console channels expose no -inputmode key - a twapi console |
|
#handle for stdin is definitive: process stdin is the real console. Terminals |
|
#presenting channels as pipes (mintty without winpty) have no console handle |
|
#and fall through to the env heuristics below. |
|
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} -choiceprefix 0 |
|
}] |
|
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} -choiceprefix 0 |
|
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_route_owner |
|
@cmd -name punk::console::internal::console_route_owner -summary\ |
|
"Owning thread a console operation must be brokered to, or empty string to operate locally."\ |
|
-help\ |
|
"Routing consults the ownership registry for the process-default console |
|
{stdin stdout} only: std channel names are process-wide, so any context can |
|
refer to the shared console, but exactly one context owns its reader and |
|
raw-mode arbitration. Non-std channel names are thread-local - an {in out} |
|
pair spec names channels of the calling thread, making that thread the |
|
console's local context - so non-default pairs always operate locally |
|
(a registry entry for such a pair qualifies the shared fact store; it is |
|
not a routing target). A console anchored by code-interp/worker code is |
|
therefore operated on directly by its anchoring context, with no round-trip. |
|
Returns empty string when the caller is the owner or no live owner is |
|
registered." |
|
@values -min 1 -max 1 |
|
inoutchannels -type list -help\ |
|
"Canonical {in out} channel pair." |
|
} |
|
proc console_route_owner {inoutchannels} { |
|
#see PUNKARGS id ::punk::console::internal::console_route_owner |
|
if {[lindex $inoutchannels 0] ne "stdin" || [lindex $inoutchannels 1] ne "stdout"} { |
|
return "" |
|
} |
|
set owner [punk::console::console_owner_get {stdin stdout}] |
|
if {$owner eq "" || $owner eq [thread::id]} { |
|
return "" |
|
} |
|
return $owner |
|
} |
|
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 1 |
|
} |
|
if {![namespace exists ::opunk::console]} { |
|
#opunk::console not loaded - nothing to integrate with yet. In-module callers only |
|
#reach here after a successful 'package require opunk::console'; external/manual |
|
#callers may call speculatively. Deliberately does not set object_integration_done, |
|
#so a later call after opunk::console loads performs the wiring. |
|
return 0 |
|
} |
|
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] |
|
#catch-up registration: anchors created in this interp before the callback was |
|
#wired never fired a 'created' event, so their consoles have no recorded owner |
|
#(seen when user code does 'package require opunk::console; opunk::console::create ...' |
|
#before any punk::console object operation triggers this wiring). Anchors are |
|
#per-interp/per-thread, so the anchoring context is this thread - register it. |
|
#Only fills empty entries: an existing live registration is newer information than |
|
#these pre-wiring anchors (and for the default console first-registration wins). |
|
foreach v [info vars ::opunk::console::instances::*] { |
|
if {![info exists $v]} { |
|
continue |
|
} |
|
if {[catch {::opunk::Console::channels [set $v]} channels]} { |
|
continue |
|
} |
|
if {[console_owner_get $channels] eq ""} { |
|
console_owner_register $channels |
|
} |
|
} |
|
} |
|
set object_integration_done 1 |
|
return 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] |
|
#flush before querying: the position query may execute in the console-owning |
|
#thread (G-007 routing), whose flush acts on its own channel instance for the same |
|
#OS handle - an unflushed move here would leave the terminal reporting the |
|
#unmoved cursor position (seen as 'columns 1' on tcl 8.6 where the -winsize |
|
#shortcut is unavailable and this mechanism actually runs) |
|
flush $out |
|
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] |
|
catch {flush $out} |
|
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] |
|
#flush before querying - see get_size_using_cursormove (G-007 routing: the query |
|
#may flush a different channel instance in the console-owning thread) |
|
flush $out |
|
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] |
|
catch {flush $out} |
|
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 |
|
} |
|
#flush before each cursor query: the query may execute in the console-owning thread |
|
#(G-007 routing) whose flush acts on its own channel instance - unflushed emissions |
|
#here would be measured as if they never happened (see get_size_using_cursormove) |
|
flush $out |
|
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" |
|
} |
|
flush $out ;#the test emission must reach the terminal before the (possibly routed) query measures it |
|
|
|
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 |
|
} |
|
#flush before the cursor query - the alt-screen/move/erase emissions above must reach |
|
#the terminal first (the query may flush a different channel instance in the |
|
#console-owning thread under G-007 routing - see get_size_using_cursormove) |
|
flush $out |
|
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 { |
|
|
|
#------------------------------------------------------------------------------------- |
|
#G-106: powershell console-mode fallback (raw mode for twapi-less windows runtimes) |
|
#A persistent powershell/pwsh named-pipe server process, shared process-wide via tsv, |
|
#flips the console's line/echo input flags on request (the flags live on the console |
|
#object, so a sibling process attached to the same console can set them for us). |
|
#Started lazily on first use (loading punk::console in a piped/non-console or |
|
#worker-thread context must not spawn processes or emit noise); the server watches this |
|
#process's pid and exits with it, so no orphan pwsh processes are left behind. |
|
#Quiet by default - set env PUNK_PS_CONSOLEMODE_DEBUG=1 for diagnostics on both sides. |
|
#------------------------------------------------------------------------------------- |
|
|
|
#module location captured at load time - [info script] is empty later at call time, |
|
#and ::argv0 is absent in secondary threads. |
|
variable module_dir "" |
|
catch { |
|
set module_dir [file dirname [file normalize [info script]]] |
|
} |
|
|
|
#Embedded copy of scriptlib/utils/pwsh/consolemode_server_async.ps1 (the canonical |
|
#maintained file) - the last-resort script source so the fallback works from kits and |
|
#unusual cwds with no scriptlib on disk. Leading/trailing whitespace is insignificant |
|
#(the text is delivered to powershell via -c). Keep in sync with the canonical file - |
|
#the console testsuite (psfallback.test) compares them. |
|
variable ps_consolemode_script_embedded { |
|
#!SEMICOLONS must be placed after each command as scriptdata needs to be sent to powershell directly with the -c parameter! |
|
; |
|
# consolemode_server_async.ps1 - punkshell console-mode fallback server (canonical copy) (G-106) |
|
# Persistent named-pipe server used by punk::console when twapi is absent on windows. |
|
# The Tcl side (punk::console::system) resolves this file - or falls back to its embedded copy - and launches: |
|
# pwsh|powershell -nop -nol -noni -c <this text with the <punkshell_*> placeholders substituted> |
|
# The -c (command string) mechanism is deliberate: it needs no script file at run time (kits) and is not |
|
# subject to ExecutionPolicy restrictions that can block -File runs. |
|
# The server process shares the launching process's console; it must NOT have its stdin redirected |
|
# (the console input handle is how it reaches the console), and it never reads stdin. |
|
# Placeholders (each overridable by a positional arg for standalone debug runs): |
|
# <punkshell_consoleid> $args[0] unique id suffix for the pipe name |
|
# <punkshell_parentpid> $args[1] pid of the owning tcl process; the server exits when it does |
|
# <punkshell_psdebug> $args[2] "1" enables diagnostic write-host output (default silent) |
|
# Standalone debug run example (from this directory): |
|
# pwsh -nop -nol -f consolemode_server_async.ps1 test1 0 1 |
|
# Protocol (one line per named-pipe connection): enableraw | disableraw | ping | exit |
|
# MAINTENANCE: src/modules/punk/console-0.8.0.tm carries this file's text as |
|
# punk::console::system::ps_consolemode_script_embedded (the last-resort resolution for kits and |
|
# unusual cwds). Keep the two in sync - the console testsuite (psfallback.test) fails when they diverge. |
|
; |
|
# The NativeConsoleMethods C# snippet below derives from posh-git (github.com/dahlbyk/posh-git): |
|
# Copyright (c) 2010-2018 Keith Dahlby, Keith Hill, and contributors - MIT license. |
|
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: |
|
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. |
|
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
|
; |
|
if ($PSVersionTable.PSVersion.Major -le 5) { |
|
# For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath |
|
#snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e |
|
; |
|
$env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';'; |
|
}; |
|
|
|
$consoleModeSource = @" |
|
using System; |
|
using System.Runtime.InteropServices; |
|
|
|
public class NativeConsoleMethods |
|
{ |
|
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)] |
|
public static extern IntPtr GetStdHandle(int handleId); |
|
|
|
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)] |
|
public static extern bool GetConsoleMode(IntPtr hConsoleOutput, out uint dwMode); |
|
|
|
[DllImport("kernel32.dll", CharSet = CharSet.Unicode, SetLastError = true)] |
|
public static extern bool SetConsoleMode(IntPtr hConsoleOutput, uint dwMode); |
|
|
|
public static uint GetConsoleMode(bool input = false) |
|
{ |
|
var handle = GetStdHandle(input ? -10 : -11); |
|
uint mode; |
|
if (GetConsoleMode(handle, out mode)) |
|
{ |
|
return mode; |
|
} |
|
return 0xffffffff; |
|
} |
|
|
|
public static uint SetConsoleMode(bool input, uint mode) |
|
{ |
|
var handle = GetStdHandle(input ? -10 : -11); |
|
if (SetConsoleMode(handle, mode)) |
|
{ |
|
return GetConsoleMode(input); |
|
} |
|
return 0xffffffff; |
|
} |
|
} |
|
"@ |
|
; |
|
[Flags()] |
|
enum ConsoleModeInputFlags |
|
{ |
|
ENABLE_PROCESSED_INPUT = 0x0001 |
|
ENABLE_LINE_INPUT = 0x0002 |
|
ENABLE_ECHO_INPUT = 0x0004 |
|
ENABLE_WINDOW_INPUT = 0x0008 |
|
ENABLE_MOUSE_INPUT = 0x0010 |
|
ENABLE_INSERT_MODE = 0x0020 |
|
ENABLE_QUICK_EDIT_MODE = 0x0040 |
|
ENABLE_EXTENDED_FLAGS = 0x0080 |
|
ENABLE_AUTO_POSITION = 0x0100 |
|
ENABLE_VIRTUAL_TERMINAL_INPUT = 0x0200 |
|
}; |
|
|
|
if (!('NativeConsoleMethods' -as [System.Type])) { |
|
Add-Type $consoleModeSource |
|
}; |
|
|
|
function rawmode { |
|
param ( |
|
[validateSet('enable', 'disable')] |
|
[string]$Action |
|
); |
|
if (!('NativeConsoleMethods' -as [System.Type])) { |
|
Add-Type $consoleModeSource |
|
}; |
|
$inputFlags = [NativeConsoleMethods]::GetConsoleMode($true); |
|
$resultflags = $inputflags; |
|
if (($inputflags -band [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -eq [ConsoleModeInputFlags]::ENABLE_LINE_INPUT) { |
|
#cooked mode |
|
$initialstate = "cooked"; |
|
if ($action -eq "enable") { |
|
#disable cooked flags |
|
$disable = [uint32](-bnot [uint32][ConsoleModeInputFlags]::ENABLE_LINE_INPUT) -band ( -bnot [uint32][ConsoleModeInputFlags]::ENABLE_ECHO_INPUT); |
|
$adjustedflags = $inputflags -band ($disable); |
|
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags); |
|
}; |
|
} else { |
|
#raw mode |
|
$initialstate = "raw"; |
|
if ($action -eq "disable") { |
|
#set cooked flags |
|
$adjustedflags = $inputflags -bor [ConsoleModeInputFlags]::ENABLE_LINE_INPUT -bor [ConsoleModeInputFlags]::ENABLE_ECHO_INPUT; |
|
$resultflags = [NativeConsoleMethods]::SetConsoleMode($true,$adjustedflags); |
|
}; |
|
}; |
|
}; |
|
|
|
$consoleid = $args[0]; |
|
if ([string]::IsNullOrEmpty($consoleid)) { |
|
$consoleid = "<punkshell_consoleid>" |
|
}; |
|
$parentpidraw = $args[1]; |
|
if ([string]::IsNullOrEmpty($parentpidraw)) { |
|
$parentpidraw = "<punkshell_parentpid>" |
|
}; |
|
$psdebugraw = $args[2]; |
|
if ([string]::IsNullOrEmpty($psdebugraw)) { |
|
$psdebugraw = "<punkshell_psdebug>" |
|
}; |
|
$psdebug = ($psdebugraw -eq "1"); |
|
$pipeName = "punkshell_ps_consolemode_$consoleid"; |
|
function dbg { |
|
param([string]$m); |
|
if ($psdebug) { |
|
write-host "consolemode_server($pipeName): $m" |
|
}; |
|
}; |
|
dbg "starting - parentpidraw: $parentpidraw"; |
|
|
|
# Parent-process watch: hold a Process object obtained once by pid (handle-based, so immune to |
|
# pid reuse) and poll HasExited in the main loop. This is the orphan-prevention guarantee - the |
|
# owning tcl process does not need to send exit for this server to go away (G-106). |
|
# An unparseable/zero parent pid (e.g a standalone run with placeholders unsubstituted) disables the watch. |
|
$parentproc = $null; |
|
[int]$parentpidnum = 0; |
|
if ([int]::TryParse($parentpidraw, [ref]$parentpidnum) -and ($parentpidnum -gt 0)) { |
|
try { |
|
$parentproc = [System.Diagnostics.Process]::GetProcessById($parentpidnum); |
|
} catch { |
|
dbg "parent process $parentpidnum not found - exiting"; |
|
exit 1; |
|
}; |
|
}; |
|
|
|
$sharedData = [hashtable]::Synchronized(@{}); |
|
$scriptblock = { |
|
param($tsv); |
|
Add-Type -AssemblyName System.IO.Pipes; |
|
$keepgoing = $true; |
|
while ($keepgoing) { |
|
$pipeServer = $null; |
|
try { |
|
$pipeServer = New-Object System.IO.Pipes.NamedPipeServerStream($pipeName); |
|
try { |
|
$pipeServer.WaitForConnection(); |
|
$reader = New-Object System.IO.StreamReader($pipeServer); |
|
$message = $reader.ReadLine(); |
|
if ($message -eq "exit") { |
|
$tsv.State = "done"; |
|
[void]$msync.Set(); |
|
$keepgoing = $false; |
|
} elseif (($message -eq "enableraw") -or ($message -eq "disableraw")) { |
|
$tsv.Message = $message; |
|
[void]$msync.Set(); |
|
} elseif ($message -eq "ping") { |
|
# liveness probe - wake the main loop, no mode action |
|
; |
|
[void]$msync.Set(); |
|
}; |
|
# A null message (a connection that closed without sending a line - e.g a probe) |
|
# and unknown messages are ignored; only an explicit exit message or |
|
# parent-process death shuts the server down. |
|
# Do NOT Close/Dispose the StreamReader here: that disposes the underlying pipe |
|
# stream and a subsequent Disconnect/Dispose on it throws, killing this listener. |
|
# Disposing the pipe stream (finally below) is the whole per-connection cleanup. |
|
} finally { |
|
if ($null -ne $pipeServer) { |
|
$pipeServer.Dispose(); |
|
}; |
|
}; |
|
} catch { |
|
# unexpected listener failure (e.g pipe name already in use) - shut down rather than spin |
|
; |
|
$tsv.State = "done"; |
|
[void]$msync.Set(); |
|
$keepgoing = $false; |
|
}; |
|
}; |
|
}; |
|
|
|
$exitcode = 0; |
|
try { |
|
# AutoResetEvent: WaitOne consumes the signal atomically, so a Set that lands while the main |
|
# loop is servicing a message is never lost (the next WaitOne returns immediately). |
|
$syncEvent = New-Object System.Threading.AutoResetEvent($false); |
|
|
|
$runspace = [runspacefactory]::CreateRunspace(); |
|
[void]$runspace.Open(); |
|
$runspace.SessionStateProxy.SetVariable("pipeName", $pipeName); |
|
$runspace.SessionStateProxy.SetVariable("msync", $syncEvent); |
|
|
|
$powershell = [System.Management.Automation.PowerShell]::Create(); |
|
$powershell.Runspace = $runspace; |
|
[void]$powershell.Addscript($scriptblock).AddArgument($sharedData); |
|
|
|
$sharedData.State = "running"; |
|
$sharedData.Message = ""; |
|
$asyncResult = $powershell.BeginInvoke(); |
|
|
|
dbg "named pipe server started in runspace"; |
|
while ($true) { |
|
[void]$syncEvent.WaitOne(5000); |
|
$msg = $sharedData.Message; |
|
$sharedData.Message = ""; |
|
if ($msg -eq "enableraw") { |
|
dbg "enableraw"; |
|
$null = rawmode 'enable'; |
|
} elseif ($msg -eq "disableraw") { |
|
dbg "disableraw"; |
|
$null = rawmode 'disable'; |
|
}; |
|
if ($sharedData.State -eq "done") { |
|
dbg "exit message received"; |
|
break; |
|
}; |
|
if (($null -ne $parentproc) -and $parentproc.HasExited) { |
|
dbg "parent process $parentpidnum has exited"; |
|
break; |
|
}; |
|
}; |
|
} finally { |
|
# The listener runspace may be parked in WaitForConnection - connect once and send exit to |
|
# unblock it, otherwise the process could linger on a parked runspace thread. Skipped when |
|
# the listener already shut itself down (State done - it exited on an exit message or error). |
|
if ($sharedData.State -ne "done") { |
|
try { |
|
$cli = New-Object System.IO.Pipes.NamedPipeClientStream($pipeName); |
|
$cli.connect(1000); |
|
$writer = new-object System.IO.StreamWriter($cli); |
|
$writer.writeline("exit"); |
|
$writer.flush(); |
|
$cli.Dispose(); |
|
} catch { |
|
dbg "listener unblock skipped: $($PSItem.Exception.Message)"; |
|
}; |
|
}; |
|
try { |
|
if ($null -ne $runspace) { |
|
$runspace.Close(); |
|
$runspace.Dispose(); |
|
}; |
|
} catch { |
|
dbg "runspace tidyup error: $($PSItem.Exception.Message)"; |
|
}; |
|
try { |
|
if ($null -ne $powershell) { |
|
$powershell.dispose(); |
|
}; |
|
} catch { |
|
dbg "powershell tidyup error: $($PSItem.Exception.Message)"; |
|
}; |
|
}; |
|
dbg "shutdown complete"; |
|
exit $exitcode; |
|
} |
|
|
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::system::ps_consolemode_script_get |
|
@cmd -name "punk::console::system::ps_consolemode_script_get"\ |
|
-summary\ |
|
"Resolve the powershell console-mode fallback server script text."\ |
|
-help\ |
|
"Resolves the consolemode_server_async.ps1 script text used by the |
|
twapi-less windows raw-mode fallback (G-106). |
|
Resolution order: PUNK_PS_CONSOLEMODE_SCRIPT env override (used only |
|
when the named file exists), the argv0-derived project location, then |
|
module-location-derived project locations, then the embedded copy |
|
carried by this module (so kits and unusual cwds always resolve). |
|
Returns a dict with keys: source (env|scriptlib|embedded), path (empty |
|
string for embedded) and contents (raw script text with <punkshell_*> |
|
placeholders unsubstituted)." |
|
}] |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::system::ps_consolemode_server_ensure |
|
@cmd -name "punk::console::system::ps_consolemode_server_ensure"\ |
|
-summary\ |
|
"Ensure the process-wide powershell console-mode server is started."\ |
|
-help\ |
|
"Ensures a single persistent powershell console-mode server process |
|
exists for this tcl process (windows only). Server identity is shared |
|
across all interps/threads via tsv punk_console ps_server_* entries; |
|
the first caller spawns (pwsh.exe preferred, powershell.exe fallback), |
|
later callers reuse. The server is passed this process's pid and exits |
|
when this process does. |
|
Returns a dict: ok (0|1), and on ok=1 pipename, pid, spawntime |
|
(ms clock) and just_started (1 when this call spawned the server); |
|
on ok=0 an error key describes why." |
|
}] |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::system::ps_consolemode_send |
|
@cmd -name "punk::console::system::ps_consolemode_send"\ |
|
-summary\ |
|
"Send a command to the powershell console-mode server."\ |
|
-help\ |
|
"Sends one protocol message (enableraw|disableraw|ping|exit) to the |
|
powershell console-mode server, ensuring the server first (spawning it |
|
if required). Connection attempts retry until the deadline - a freshly |
|
spawned server is given a generous window for powershell startup. If |
|
the recorded server proves unreachable the recorded state is cleared |
|
and one respawn is attempted. |
|
Returns a dict: ok (0|1), and on failure an error key." |
|
@opts |
|
-deadlinems -type integer -optional 1 -help\ |
|
"Override the per-attempt connection deadline in milliseconds. |
|
Default: 15000 within 15s of server spawn (powershell startup), |
|
2500 thereafter." |
|
@values -min 1 -max 1 |
|
msg -type string -help\ |
|
"Protocol message: enableraw, disableraw, ping or exit." |
|
}] |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::console::system::ps_consolemode_server_stop |
|
@cmd -name "punk::console::system::ps_consolemode_server_stop"\ |
|
-summary\ |
|
"Stop the recorded powershell console-mode server, if any."\ |
|
-help\ |
|
"Best-effort shutdown of the recorded powershell console-mode server: |
|
sends the exit protocol message (short deadline, no respawn) and clears |
|
the recorded tsv state. Not required for orphan prevention - the server |
|
watches this process's pid and exits with it - but useful for tests and |
|
for releasing the server early. |
|
Returns a dict: ok 1, stopped (1 if the exit message was delivered), |
|
and pipename (when a server was recorded)." |
|
}] |
|
} |
|
|
|
proc ps_consolemode_script_get {} { |
|
#G-106 - see PUNKARGS definition for behaviour contract |
|
variable module_dir |
|
variable ps_consolemode_script_embedded |
|
set relpath scriptlib/utils/pwsh/consolemode_server_async.ps1 |
|
set candidates [list] |
|
if {[info exists ::env(PUNK_PS_CONSOLEMODE_SCRIPT)] && $::env(PUNK_PS_CONSOLEMODE_SCRIPT) ne ""} { |
|
#explicit dev/test override - falls through if the named file is missing |
|
lappend candidates [list env $::env(PUNK_PS_CONSOLEMODE_SCRIPT)] |
|
} |
|
if {[info exists ::argv0] && $::argv0 ne ""} { |
|
#argv0 grandparent as project root: covers src/make.tcl (repo root) and bin/<kit> launches |
|
lappend candidates [list scriptlib [file dirname [file dirname [file normalize $::argv0]]]/$relpath] |
|
} |
|
if {$module_dir ne ""} { |
|
#module in <project>/modules/punk -> project root is 2 up |
|
#module in <project>/src/modules/punk -> project root is 3 up |
|
#(a zipfs kit module path simply fails the file-exists probes) |
|
lappend candidates [list scriptlib [file dirname [file dirname $module_dir]]/$relpath] |
|
lappend candidates [list scriptlib [file dirname [file dirname [file dirname $module_dir]]]/$relpath] |
|
} |
|
foreach cand $candidates { |
|
lassign $cand source path |
|
if {[file exists $path]} { |
|
set readok [expr {![catch { |
|
set fd [open $path r] |
|
chan configure $fd -translation binary |
|
set contents [read $fd] |
|
close $fd |
|
}]}] |
|
if {$readok} { |
|
return [dict create source $source path $path contents $contents] |
|
} |
|
} |
|
} |
|
return [dict create source embedded path "" contents $ps_consolemode_script_embedded] |
|
} |
|
|
|
proc ps_consolemode_server_ensure {} { |
|
#G-106 - see PUNKARGS definition for behaviour contract |
|
if {"windows" ne $::tcl_platform(platform)} { |
|
return [dict create ok 0 just_started 0 error "powershell consolemode server is windows-only"] |
|
} |
|
#fast path - another interp/thread (or an earlier call) already started the server |
|
if {[tsv::exists punk_console ps_server_pipename]} { |
|
set result [dict create ok 1 just_started 0] |
|
dict set result pipename [tsv::get punk_console ps_server_pipename] |
|
dict set result pid [tsv::get punk_console ps_server_pid] |
|
dict set result spawntime [tsv::get punk_console ps_server_spawntime] |
|
return $result |
|
} |
|
set ps_cmd [auto_execok pwsh.exe] |
|
if {$ps_cmd eq ""} { |
|
set ps_cmd [auto_execok powershell.exe] |
|
} |
|
if {$ps_cmd eq ""} { |
|
return [dict create ok 0 just_started 0 error "neither pwsh.exe nor powershell.exe found on PATH"] |
|
} |
|
set scriptinfo [::punk::console::system::ps_consolemode_script_get] |
|
set psdebug 0 |
|
if {[info exists ::env(PUNK_PS_CONSOLEMODE_DEBUG)] && $::env(PUNK_PS_CONSOLEMODE_DEBUG) ni [list "" 0]} { |
|
set psdebug 1 |
|
} |
|
set spawned 0 |
|
set spawn_error "" |
|
set pipename "" |
|
set spawnpid "" |
|
set spawntime 0 |
|
tsv::lock punk_console { |
|
if {[tsv::exists punk_console ps_server_pipename]} { |
|
#another thread won the race |
|
set pipename [tsv::get punk_console ps_server_pipename] |
|
set spawnpid [tsv::get punk_console ps_server_pid] |
|
set spawntime [tsv::get punk_console ps_server_spawntime] |
|
} else { |
|
set ps_consoleid [pid]-[expr {int(999999 * rand())+1}] |
|
set contents [string map [list <punkshell_consoleid> $ps_consoleid <punkshell_parentpid> [pid] <punkshell_psdebug> $psdebug] [dict get $scriptinfo contents]] |
|
set pipename {\\.\pipe\punkshell_ps_consolemode_} |
|
append pipename $ps_consoleid |
|
#stdin must stay inherited - the console input handle is how the server reaches |
|
#the console. stdout/stderr are silenced unless debugging. |
|
if {$psdebug} { |
|
puts stderr "punk::console: starting persistent powershell consolemode server pipename: $pipename (script source: [dict get $scriptinfo source] [dict get $scriptinfo path])" |
|
set spawncatch [catch {exec {*}$ps_cmd -nop -nol -noni -c $contents &} spawnresult] |
|
} else { |
|
set spawncatch [catch {exec {*}$ps_cmd -nop -nol -noni -c $contents > NUL 2> NUL &} spawnresult] |
|
} |
|
if {$spawncatch} { |
|
set spawn_error $spawnresult |
|
} else { |
|
set spawnpid [lindex $spawnresult 0] |
|
set spawntime [clock milliseconds] |
|
tsv::set punk_console ps_server_pipename $pipename |
|
tsv::set punk_console ps_server_pid $spawnpid |
|
tsv::set punk_console ps_server_spawntime $spawntime |
|
set spawned 1 |
|
} |
|
} |
|
} |
|
if {$spawn_error ne ""} { |
|
return [dict create ok 0 just_started 0 error "failed to launch powershell consolemode server: $spawn_error"] |
|
} |
|
set result [dict create ok 1 just_started $spawned] |
|
dict set result pipename $pipename |
|
dict set result pid $spawnpid |
|
dict set result spawntime $spawntime |
|
return $result |
|
} |
|
|
|
proc ps_consolemode_send {msg args} { |
|
#G-106 - see PUNKARGS definition for behaviour contract |
|
#manual args parsing - called on raw enable/disable paths |
|
set opt_deadlinems "" |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-deadlinems { |
|
set opt_deadlinems $v |
|
} |
|
default { |
|
error "ps_consolemode_send unknown option '$k' - known options: -deadlinems" |
|
} |
|
} |
|
} |
|
set ensure [::punk::console::system::ps_consolemode_server_ensure] |
|
if {![dict get $ensure ok]} { |
|
return [dict create ok 0 error [dict get $ensure error]] |
|
} |
|
set attempt 0 |
|
set errMsg "" |
|
while 1 { |
|
incr attempt |
|
set deadlinems $opt_deadlinems |
|
if {$deadlinems eq ""} { |
|
#a freshly spawned server (from this call or another interp moments ago) can take |
|
#seconds to begin listening (powershell startup) - allow for it |
|
set age [expr {[clock milliseconds] - [dict get $ensure spawntime]}] |
|
if {$age < 15000} { |
|
set deadlinems 15000 |
|
} else { |
|
set deadlinems 2500 |
|
} |
|
} |
|
set pipename [dict get $ensure pipename] |
|
set endtime [expr {[clock milliseconds] + $deadlinems}] |
|
while {[clock milliseconds] < $endtime} { |
|
set ok_write 0 |
|
if {![catch {open $pipename w} pipe]} { |
|
if {![catch { |
|
chan configure $pipe -buffering line |
|
puts -nonewline $pipe "$msg\r\n" |
|
close $pipe |
|
} errMsg]} { |
|
set ok_write 1 |
|
} else { |
|
catch {close $pipe} |
|
} |
|
} else { |
|
set errMsg $pipe |
|
} |
|
if {$ok_write} { |
|
return [dict create ok 1 attempt $attempt] |
|
} |
|
after 100 |
|
} |
|
if {$attempt >= 2} { |
|
return [dict create ok 0 error "failed to reach powershell consolemode server on $pipename: $errMsg"] |
|
} |
|
#the recorded server may be stale (e.g killed externally) - clear the recorded state |
|
#(only if it still names the pipe we tried) and respawn once |
|
tsv::lock punk_console { |
|
if {[tsv::exists punk_console ps_server_pipename] && [tsv::get punk_console ps_server_pipename] eq $pipename} { |
|
tsv::unset punk_console ps_server_pipename |
|
tsv::unset punk_console ps_server_pid |
|
tsv::unset punk_console ps_server_spawntime |
|
} |
|
} |
|
set ensure [::punk::console::system::ps_consolemode_server_ensure] |
|
if {![dict get $ensure ok]} { |
|
return [dict create ok 0 error [dict get $ensure error]] |
|
} |
|
} |
|
} |
|
|
|
proc ps_consolemode_server_stop {} { |
|
#G-106 - see PUNKARGS definition for behaviour contract |
|
if {![tsv::exists punk_console ps_server_pipename]} { |
|
return [dict create ok 1 stopped 0 note "no powershell consolemode server recorded"] |
|
} |
|
set pipename [tsv::get punk_console ps_server_pipename] |
|
#deliberately not via ps_consolemode_send - that would respawn an unreachable server |
|
set sent 0 |
|
set endtime [expr {[clock milliseconds] + 1000}] |
|
while {[clock milliseconds] < $endtime} { |
|
if {![catch {open $pipename w} pipe]} { |
|
if {![catch { |
|
chan configure $pipe -buffering line |
|
puts -nonewline $pipe "exit\r\n" |
|
close $pipe |
|
}]} { |
|
set sent 1 |
|
break |
|
} else { |
|
catch {close $pipe} |
|
} |
|
} |
|
after 100 |
|
} |
|
tsv::lock punk_console { |
|
if {[tsv::exists punk_console ps_server_pipename] && [tsv::get punk_console ps_server_pipename] eq $pipename} { |
|
tsv::unset punk_console ps_server_pipename |
|
tsv::unset punk_console ps_server_pid |
|
tsv::unset punk_console ps_server_spawntime |
|
} |
|
} |
|
return [dict create ok 1 stopped $sent pipename $pipename] |
|
} |
|
|
|
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 (G-106). |
|
#It asks the persistent powershell console-mode server (started lazily on first use, |
|
#shared process-wide via tsv, self-terminating with this process - see |
|
#punk::console::system::ps_consolemode_server_ensure) to clear the console's |
|
#line/echo input flags. The channel argument is unused by the server path - the |
|
#server acts on the process console's input handle. |
|
|
|
#stty remains as a last resort: it does not *usually* work on windows |
|
#(the msys/cygwin stty is a subprocess - useful to retrieve info but generally unable |
|
#to affect the calling process/console). An exception is an msys/cygwin terminal such |
|
#as mintty configured without winpty (e.g env MSYS = disable_pcon prior to launch). |
|
upvar ::punk::console::previous_stty_state_$channel previous_stty_state_$channel |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set sendresult [::punk::console::system::ps_consolemode_send enableraw] |
|
if {[dict get $sendresult ok]} { |
|
tsv::set punk_console is_raw 1 |
|
#the server applies the console flags asynchronously (fire-and-forget protocol). |
|
#Where the runtime can read the live mode (tcl9 -inputmode on a console channel), |
|
#wait briefly for the flip so callers can rely on raw being active on return. |
|
set confirmed unknown |
|
if {[dict exists [chan configure $channel] -inputmode]} { |
|
set confirmed 0 |
|
set endtime [expr {[clock milliseconds] + 750}] |
|
while {[clock milliseconds] < $endtime} { |
|
if {[dict get [chan configure $channel] -inputmode] eq "raw"} { |
|
set confirmed 1 |
|
break |
|
} |
|
after 25 |
|
} |
|
} |
|
return [list $channel [list from unknown to raw note "set via powershell consolemode server (confirmed $confirmed)"]] |
|
} |
|
#not normal operation - fall through to stty attempt with an actionable note |
|
puts stderr "punk::console::enableRaw: powershell consolemode server unavailable ([dict get $sendresult error]) - trying stty" |
|
} |
|
if {[set sttycmd [auto_execok stty]] ne ""} { |
|
if {[set previous_stty_state_$channel] eq ""} { |
|
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] |
|
} |
|
exec {*}$sttycmd raw -echo <@$channel |
|
tsv::set 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, the powershell consolemode server, or stty to set raw mode - aborting" |
|
} |
|
} |
|
proc disableRaw_powershell {{channel stdin}} { |
|
#disableRaw powershell/fallback version (G-106) |
|
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 - ask the powershell consolemode server |
|
#to restore the console's line/echo input flags |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set sendresult [::punk::console::system::ps_consolemode_send disableraw] |
|
if {[dict get $sendresult ok]} { |
|
tsv::set punk_console is_raw 0 |
|
return [list $channel [list from unknown to normal note "set via powershell consolemode server"]] |
|
} |
|
#not normal operation - fall through to stty attempt with an actionable note |
|
puts stderr "punk::console::disableRaw: powershell consolemode server unavailable ([dict get $sendresult error]) - trying stty" |
|
} |
|
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 |
|
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, the powershell consolemode server, 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 { |
|
#no twapi - use the powershell console-mode fallback (G-106). |
|
#The persistent powershell named-pipe server is started lazily on first |
|
#enableRaw/disableRaw use (punk::console::system::ps_consolemode_server_ensure), |
|
#not at module load: loading punk::console in a piped/non-console or worker-thread |
|
#context must not spawn processes or emit noise. Server state is process-wide |
|
#(tsv punk_console ps_server_*), the server watches this process's pid and exits |
|
#with it, and script resolution no longer depends on argv0 alone |
|
#(see punk::console::system::ps_consolemode_script_get). |
|
|
|
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 ::punk::console::system ::punk::console::system::argdoc |
|
} |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::console [namespace eval punk::console { |
|
variable version |
|
set version 0.8.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end]
|
|
|