diff --git a/AGENTS.md b/AGENTS.md index 88e36e0e..aa5dc063 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -87,7 +87,7 @@ When the user requests a durable behavior change, record it here or in the relev - `src/modules/` — Main editable module source (see src/modules/AGENTS.md) - `src/modules/punk/` — Core punk namespace modules (see src/modules/punk/AGENTS.md) - `src/modules/test/` — Installed-module test packages (see src/modules/test/AGENTS.md) - - `src/modules/opunk/` — Alternative punk namespace + - `src/modules/opunk/` — Alternative punk namespace, voo-based classes (see src/modules/opunk/AGENTS.md) - `src/modules/punkcheck/` — Build/check system - `src/modules_tcl8/` — Tcl 8 specific modules (see src/modules_tcl8/AGENTS.md) - `src/modules_tcl9/` — Tcl 9 specific modules (see src/modules_tcl9/AGENTS.md) diff --git a/src/bootsupport/AGENTS.md b/src/bootsupport/AGENTS.md index 13bb1073..a32841cb 100644 --- a/src/bootsupport/AGENTS.md +++ b/src/bootsupport/AGENTS.md @@ -8,7 +8,8 @@ Modules and libraries required during the build/bootstrap/make process before th - Agents should not directly modify files in this tree unless the task specifically targets boot behaviour. - Bootsupport modules are snapshots that may lag behind or diverge from the corresponding `src/modules/` versions intentionally. -- The `dev lib.copyasmodule` command is the prescribed way to update bootsupport modules. +- The systematic update workflow is `modules/include_modules.config` (entries are ` ` pairs; base `src/vendormodules` for vendored modules, base `modules` for the project's *built* root modules - build with `make.tcl modules` first) followed by `tclsh src/make.tcl bootsupport`, which also propagates snapshots into the project-layout bootsupport trees. +- `dev lib.copyasmodule` is a manual convenience for copying a module (or a single-file pkgIndex.tcl library, converting it to .tm form) from a running punk shell - see `modules/README.md`; it is not the primary update mechanism. ## Local Contracts diff --git a/src/bootsupport/modules/include_modules.config b/src/bootsupport/modules/include_modules.config index 3c4ff251..72b5b2de 100644 --- a/src/bootsupport/modules/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -39,6 +39,7 @@ set bootsupport_modules [list\ src/vendormodules textutil::tabify\ src/vendormodules textutil::trim\ src/vendormodules textutil::wcswidth\ + src/vendormodules voo\ src/vendormodules uuid\ modules argp\ modules flagfilter\ @@ -107,6 +108,7 @@ set bootsupport_modules [list\ modules textblock\ modules natsort\ modules oolib\ + modules opunk::console\ modules zipper\ modules zzzload\ ] diff --git a/src/bootsupport/modules/opunk/console-0.1.0.tm b/src/bootsupport/modules/opunk/console-0.1.0.tm new file mode 100644 index 00000000..bf940c11 --- /dev/null +++ b/src/bootsupport/modules/opunk/console-0.1.0.tm @@ -0,0 +1,361 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm +# +# 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) 2026 +# +# @@ Meta Begin +# Application opunk::console 0.1.0 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +package require Tcl 8.6- + +package require voo +package require punk::args + +#opunk::Console - a voo (value-based) representation of a console: an in/out channel pair claimed to +#belong to one responding endpoint, together with settled capability facts about that endpoint. +# +#Motivation (see punk::console get_size / get_ansi_response_payload history): +#ANSI query mechanisms assume the input channel receives what the output channel's device emits in +#response. When stdio is redirected that pairing silently breaks - queries go to a terminal whose +#replies land in some other process's input. A console object makes the pairing an explicit, +#construction-time property instead of a per-query-site guess. +# +#Design notes: +# - Objects are voo values (plain lists). Consoles are entities, not values - so canonical instances +# are anchored at well-known namespace variables (::opunk::console::instances::) and the value +# semantics serve as cheap snapshots. Mutation (settling capabilities) goes through the anchor via +# the lowercase ::opunk::console wrapper procs. +# - The class is -virtual: slot 0 of each value carries the concrete class namespace, so channel +# environments that respond like terminals but aren't platform consoles can subclass +# (-extends ::opunk::Console) and override the capability/size methods, with existing holders of +# console values dispatching correctly. +# - This first cut is standalone and passive: capability detection is heuristic (channel options, +# probed eof, terminal env hints) and size uses chan -winsize else the default size. Active ANSI +# query probing arrives with punk::console integration (which will delegate here rather than the +# class depending on punk::console). + +tcl::namespace::eval ::opunk::console { + variable PUNKARGS + + #well-known cooperative store for bytes consumed by probe reads on pipe-like channels + #dict keyed by channel name -> list of chunks. Readers taking over a channel should consume + #and clear any entry for that channel first. (analogous to punk::console::input_chunks_waiting) + variable waiting_chunks + if {![info exists waiting_chunks]} { + set waiting_chunks [dict create] + } +} + +voo::class ::opunk::Console -virtual { + private { + #o_ prefix per opunk voo convention (distinguishes fields from locals in -update methods, + #and matches tclOO-style implementations elsewhere for easier code movement). + #Note the class is -virtual: slot 0 of the object value is the concrete class namespace tag. + string_t o_in stdin + string_t o_out stdout + string_t o_terminal_class "" ;#e.g windows-console, tty, pipe - "" until classified + list_t o_size_mechanism [list] ;#preferred size mechanism try-order - empty until timed/settled + dict_t o_default_size [dict create columns 80 rows 24] + } + public { + #settled response capability: -1 unknown, 0 cannot respond, 1 can respond. + #public accessors (get.o_can_respond / set.o_can_respond) so the anchored-mutation wrappers in + #::opunk::console can settle it without reaching into private my.* accessors. + int_t o_can_respond -1 + + method in {} { + my.get.o_in $this + } + method out {} { + my.get.o_out $this + } + method channels {} { + list [my.get.o_in $this] [my.get.o_out $this] + } + method terminal_class {} { + my.get.o_terminal_class $this + } + method default_size {} { + my.get.o_default_size $this + } + + #Certainty test: is the input channel closed or at eof (and so can never deliver a response)? + #A consumed/half-closed pipe may not flag eof until a read is attempted, so pipe-like channels + #get a non-blocking 1-byte probe. A probed byte is preserved in ::opunk::console::waiting_chunks + #for cooperating readers. Console/tty channels are never probed (must not consume a keystroke). + method at_eof {} -virtual { + if {[llength $this] < 7} { + error "invalid object $this" + } + set in [my.get.o_in $this] + if {[catch {chan eof $in} is_eof]} { + return 1 ;#closed/invalid channel - unusable + } + if {$is_eof} { + return 1 + } + if {[catch {chan configure $in} conf]} { + return 1 + } + if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { + return 0 + } + if {[catch { + set prior_blocking [dict get $conf -blocking] + chan configure $in -blocking 0 + set probe [read $in 1] + chan configure $in -blocking $prior_blocking + }]} { + return 1 + } + if {$probe ne ""} { + dict lappend ::opunk::console::waiting_chunks $in $probe + } + return [chan eof $in] + } + + #Heuristic: could the input channel be connected to a terminal able to answer queries? + #Returns 0 only when reasonably confident it cannot. mintty without winpty presents a + #terminal's stdin as a plain pipe, so env hints (MSYSTEM, TERM_PROGRAM) prevent false + #negatives there at the cost of false positives for genuinely piped-but-open input. + method is_console_or_tty {} -virtual { + if {[llength $this] < 7} { + error "invalid object $this" + } + set in [my.get.o_in $this] + if {[catch {chan configure $in} conf]} { + return 0 + } + if {[dict exists $conf -inputmode]} { + return 1 + } + if {[dict exists $conf -mode]} { + return 1 + } + if {[at_eof $this]} { + return 0 + } + if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { + return 1 + } + return 0 + } + + #Response capability: settled value if known, else computed heuristically (without settling - + #this method is pure; use ::opunk::console::can_respond to settle an anchored instance). + #TODO: active probe query (device attributes with timeout) when punk::console query machinery + #is integrated - heuristics can then be replaced by one settling probe at first use. + method can_respond {} -virtual { + if {[llength $this] < 7} { + error "invalid object $this" + } + set settled [get.o_can_respond $this] + if {$settled != -1} { + return $settled + } + return [is_console_or_tty $this] + } + + #Size of the console: chan -winsize on the output channel when available (fast, no query), + #else the configured default size. ANSI cursor-report mechanisms are deliberately absent from + #this standalone class - they arrive via punk::console integration and subclasses. + method size {} -virtual { + if {[llength $this] < 7} { + error "invalid object $this" + } + set out [my.get.o_out $this] + if {![catch {chan configure $out} oconf]} { + if {[dict exists $oconf -winsize]} { + lassign [dict get $oconf -winsize] cols lines + if {[string is integer -strict $cols] && [string is integer -strict $lines]} { + return [dict create columns $cols rows $lines] + } + } + } + return [my.get.o_default_size $this] + } + } + + constructor {in out} { + #new() supplies the class defaults including the virtual class tag at slot 0 + set obj [new()] + my.set.o_in obj $in + my.set.o_out obj $out + return $obj + } +} + +#make introspection (with i and punk::ns::cmdinfo) easier by making the class namespace an ensemble - we can still access it as ::opunk::Console +namespace eval ::opunk::Console { + namespace ensemble create +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Anchored instances - the 'consoles are entities' layer +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval ::opunk::console { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + + namespace eval instances { + #one variable per anchored console instance - the canonical location of each console object. + #Access via the sibling procs; methods needing to mutate an instance go through these anchors. + } + + proc create {name in out} { + if {![string is wordchar -strict $name]} { + error "opunk::console::create name must be alphanumeric/underscore, got '$name'" + } + set [namespace current]::instances::$name [::opunk::Console::new $in $out] + return [namespace current]::instances::$name + } + proc instancevar {name} { + set v [namespace current]::instances::$name + if {![info exists $v]} { + error "opunk::console: no anchored console instance named '$name' (known: [names])" + } + return $v + } + proc instance {name} { + set [instancevar $name] + } + proc names {} { + set result [list] + foreach v [info vars [namespace current]::instances::*] { + lappend result [namespace tail $v] + } + return $result + } + proc forget {name} { + unset [instancevar $name] + return + } + + #settle-and-cache response capability on the anchored instance. + #The class method is pure (value-in) - this wrapper owns the mutation via the anchor. + proc can_respond {name} { + upvar #0 [instancevar $name] obj + set settled [::opunk::Console::get.o_can_respond $obj] + if {$settled != -1} { + return $settled + } + set r [::opunk::Console::can_respond $obj] + ::opunk::Console::set.o_can_respond obj $r + return $r + } + proc size {name} { + ::opunk::Console::size [instance $name] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval ::opunk::console { + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)opunk::console" + @package -name "opunk::console" -help\ + "voo class ::opunk::Console representing a console as an in/out channel pair with settled + response-capability facts, plus anchored canonical instances under ::opunk::console::instances." + }] + + namespace eval argdoc { + proc package_name {} { + return opunk::console + } + proc about_topics {} { + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package opunk::console + voo class for consoles as channel-pair objects with anchored canonical instances. + } \n] + } + proc get_topic_License {} { + return "BSD" + } + proc get_topic_Version {} { + return "$::opunk::console::version" + } + proc get_topic_Contributors {} { + set authors {{"Julian Noble" "julian@precisium.com.au"}} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_classes {} { + punk::args::lib::tstr -return string { + opunk::Console "virtual class for consoles as in/out channel pairs" + } + } + } + + set overrides [dict create] + dict set overrides @id -id "::opunk::console::about" + dict set overrides @cmd -name "opunk::console::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About opunk::console + }] \n] + dict set overrides topic -choices [list {*}[opunk::console::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [opunk::console::argdoc::default_topics] + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + set argd [punk::args::parse $args withid ::opunk::console::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::opunk::console::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::opunk::console ::opunk::Console +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide opunk::console [tcl::namespace::eval ::opunk::console { + variable pkg opunk::console + variable version + set version 0.1.0 +}] +return diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index c9c2d7bf..085b4f60 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -244,6 +244,7 @@ tcl::namespace::eval punk::config { syslog_active 0 auto_exec_mechanism exec auto_noexec 0 + pipe_eof {} } xdg_config_home $default_xdg_config_home {*}{ } xdg_data_home $default_xdg_data_home {*}{ } xdg_cache_home $default_xdg_cache_home {*}{ @@ -284,6 +285,7 @@ tcl::namespace::eval punk::config { PUNK_LOGFILE_STDOUT {type string} PUNK_LOGFILE_STDERR {type string} PUNK_LOGFILE_ACTIVE {type string} + PUNK_PIPE_EOF {type string default "" help "punk shell behaviour when its input channel\n(usually piped/redirected stdin) reaches eof.\n exit - always terminate\n interactive - reopen console, interactive repl\n unset/other - console if available, else exit"} PUNK_SYSLOG_STDOUT {type string} PUNK_SYSLOG_STDERR {type string} PUNK_SYSLOG_ACTIVE {type string} diff --git a/src/bootsupport/modules/punk/console-0.1.3.tm b/src/bootsupport/modules/punk/console-0.1.3.tm new file mode 100644 index 00000000..9f38abcc --- /dev/null +++ b/src/bootsupport/modules/punk/console-0.1.3.tm @@ -0,0 +1,4618 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2023 +# +# @@ Meta Begin +# Application punk::console 0.1.3 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::console 0 0.1.3] +#[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 console is_raw]} { + tsv::set console is_raw 0 + } + + variable input_chunks_waiting + if {![info exists input_chunks_waiting(stdin)]} { + set input_chunks_waiting(stdin) [list] + } + variable ansi_response_chunk ;#array keyed on callid + variable ansi_response_wait ;#array keyed on callid + array set ansi_response_wait {} + variable ansi_response_queue [list];#list of callids + variable ansi_response_queuedata ;#dict keyed on callid - with function params + + # -- + variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. + #-1 still evaluates to true - as the modern assumption for ansi availability is true + #only false if ansi_available has been set 0 by test_can_ansi + #support ansistrip for legacy windows terminals + # -- + + variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset + + + + #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace + #directly acting means they write to stdout to cause the console to 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 + } + + + + + #review - document and decide granularity required. should we enable/disable more than one at once? + proc enable_mouse {} { + puts -nonewline stdout \x1b\[?1000h + puts -nonewline stdout \x1b\[?1003h + puts -nonewline stdout \x1b\[?1015h + puts -nonewline stdout \x1b\[?1006h + flush stdout + } + proc disable_mouse {} { + puts -nonewline stdout \x1b\[?1000l + puts -nonewline stdout \x1b\[?1003l + puts -nonewline stdout \x1b\[?1015l + puts -nonewline stdout \x1b\[?1006l + flush stdout + } + proc enable_mouse_sgr {} { + puts -nonewline stdout \x1b\[?1000h\x1b\[?1003h\x1b\[?1016h + flush stdout + } + proc disable_mouse_sgr {} { + puts -nonewline stdout \x1b\[?1000l\x1b\[?1003l\x1b\[?1016l + flush stdout + } + proc enable_bracketed_paste {} { + puts -nonewline stdout \x1b\[?2004h + } + proc disable_bracketed_paste {} { + puts -nonewline stdout \x1b\[?2004l + } + proc start_application_mode {} { + #need loop to read events? + puts -nonewline stdout \x1b\[?1049h ;#alt screen + enable_mouse + #puts -nonewline stdout \x1b\[?25l ;#hide cursor + puts -nonewline stdout \x1b\[?1003h\n + enable_bracketed_paste + } + #todo stop_application_mode {} {} + + proc mode {{raw_or_line query}} { + #variable is_raw + variable ansi_available + set raw_or_line [string tolower $raw_or_line] + if {$raw_or_line eq "query"} { + if {[tsv::get console is_raw]} { + return "raw" + } else { + return "line" + } + } elseif {$raw_or_line eq "raw"} { + if {[catch { + punk::console::enableRaw + } errM]} { + puts stderr "Warning punk::console::enableRaw failed - $errM" + } + if {[can_ansi]} { + punk::console::enableVirtualTerminal both + } + } elseif {$raw_or_line eq "line"} { + #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) + if {[catch { + punk::console::disableRaw + } errM]} { + puts stderr "Warning punk::console::disableRaw failed - $errM" + } + if {[can_ansi]} { + punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc + punk::console::enableVirtualTerminal output ;#display/use ansi codes + } + } else { + error "punk::console::mode expected 'raw' or 'line' or default value 'query'" + } + } + + namespace eval internal { + + proc abort_if_loop {{failmsg ""}} { + #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\;\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 cinfo [punk::console::console_spec_resolve $inoutchannels] + set inoutchannels [list [dict get $cinfo in] [dict get $cinfo out]] + lassign $inoutchannels input output + if {[dict get $cinfo object] ne "" && [::opunk::Console::get.o_can_respond [dict get $cinfo object]] == 0} { + error "punk::console::get_ansi_response_payload console object for '$input' '$output' is settled as unable to respond (can_respond=0) - refusing to emit query" + } + + #A closed or eof input channel can never deliver a terminal response - fail fast rather than + #emitting the query and waiting for a reply that cannot arrive (e.g piped/redirected stdin that + #has already been consumed). Deliberately only tests certainty of failure (with a probe read for + #deferred pipe eof) - a pipe that is still open could be mintty without winpty presenting a + #terminal's stdin as a pipe (see is_input_console_or_tty) + if {[::punk::console::input_at_eof $input]} { + error "punk::console::get_ansi_response_payload input channel '$input' is closed or at eof - cannot receive terminal response" + } + + #chunks from input that need to be handled by readers + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + + #we need to cooperate with other stdin/$input readers and put data here if we overconsume. + #Main repl reader may be currently active - or may be inactive. + #This call could come from within code called by the main reader - or from user code running while main read-loop is temporarily disabled + #In other contexts there may not even be another input reader + + #REVIEW - what if there is existing data in input_chunks_waiting - is it for us? + #This occurs for example with key held down on autorepeat and is normal + #enable it here for debug/testing only + #if {[info exists input_chunks_waiting($input)] && [llength $input_chunks_waiting($input)]} { + # puts stderr "[punk::ansi::a+ cyan bold]get_ansi_response_payload called while input_chunks_waiting($input) contained data: [punk::ansi::a][ansistring VIEW $input_chunks_waiting($input)]" + #} + + if {!$::punk::console::ansi_available} { + return "" + } + # -- --- + #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] + #Either is suitable here, where subsequent calls will be relatively far apart in time + #speed of call insignificant compared to function + set callid [clock clicks] + # -- --- + # + + upvar ::punk::console::ansi_response_chunk accumulator + upvar ::punk::console::ansi_response_wait waitvar + upvar ::punk::console::ansi_response_queue queue + upvar ::punk::console::ansi_response_queuedata queuedata + upvar ::punk::console::ansi_response_tslaunch tslaunch + upvar ::punk::console::ansi_response_tsclock tsclock + upvar ::punk::console::ansi_response_timeoutid timeoutid + set accumulator($callid) "" + set waitvar($callid) "" + + lappend queue $callid + if {[llength $queue] > 1} { + #while {[lindex $queue 0] ne $callid} {} + set queuedata($callid) $args + set runningid [lindex $queue 0] + while {$runningid ne $callid} { + #puts stderr "." + vwait ::punk::console::ansi_response_wait + set runningid [lindex $queue 0] + if {$runningid ne $callid} { + set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) + update ;#REVIEW - possibly a bad idea + after 10 + set runningid [lindex $queue 0] ;#jn test + } + } + } + + + + #todo - use a linked array and an accumulatorid and waitvar id? When can there be more than one terminal query in-flight? + + set existing_handler [chan event $input readable] ;#review! + set this_handler ::punk::console::internal::ansi_response_handler_regex + if {[lindex $existing_handler 0] eq $this_handler} { + puts stderr "[punk::ansi::a+ red]Warning for callid $callid get_ansi_response_payload called while existing ansi response handler in place[a]: $this_handler" + puts stderr "queue state: $queue" + flush stderr + + if {[lindex $queue 0] ne $callid} { + error "get_ansi_response_payload - re-entrancy unrecoverable" + } + } + chan event $input readable {} + + # - stderr vs stdout + #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions + #(presumably race conditions as to when data hits console?) + #review - experiment changing this and calling functions to stderr and see if it works + #review - Are there disadvantages to using stdout vs stderr? + + + set previous_input_state [chan configure $input] + #chan configure $input -blocking 0 + + #todo - make timeout configurable? + set waitvarname "::punk::console::ansi_response_wait($callid)" + + + if {![tsv::get console is_raw]} { + set was_raw 0 + punk::console::enableRaw + #after 0 [list chan event $input readable [list $this_handler $input $callid $capturingendregex]] + incr expected 50 ;#review + set timeoutid($callid) [after $expected [list set $waitvarname timedout]] + #puts stdout "sending console request [ansistring VIEW $query]" + } else { + set was_raw 1 + set timeoutid($callid) [after $expected [list set $waitvarname timedout]] + } + #write before console enableRaw vs after?? + #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it + + 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} { + 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 ' 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 + 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 + proc vt52 {{onoff {}}} { + #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 + variable is_vt52 + if {$onoff eq ""} { + return $is_vt52 + } + if {![string is boolean -strict $onoff]} { + error "vt52 setting must be a boolean - or empty to query" + } + if {$is_vt52} { + if {!$onoff} { + puts -nonewline "\x1b<" + set is_vt52 0 + colour on + } + } else { + if {$onoff} { + dec_unset_mode DECANM + set is_vt52 1 + colour off + } else { + puts -nonewline "\x1b<" + #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ + } + } + return $is_vt52 + } + + namespace eval local { + proc set_codepage_output {cpname} { + #todo + if {"windows" eq $::tcl_platform(platform)} { + twapi::set_console_output_codepage $cpname + } else { + error "set_codepage_output unimplemented on $::tcl_platform(platform)" + } + } + proc set_codepage_input {cpname} { + #todo + if {"windows" eq $::tcl_platform(platform)} { + twapi::set_console_input_codepage $cpname + } else { + error "set_codepage_input unimplemented on $::tcl_platform(platform)" + } + } + lappend PUNKARGS [list { + @id -id ::punk::console::local::echo + @cmd -name punk::console::local::echo -help\ + "Use stty on unix, or twapi on windows to set terminal + local input echo on/off - experimental" + @values -min 0 -max 1 + onoff -type boolean -default "" -help\ + "Omit or pass empty string to query current echo state." + }] + proc echo {args} { + set argd [punk::args::parse $args -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 + -console -default {stdin stdout} -type list -help\ + "console/terminal (currently list of in/out channels) (todo - object?)" + ${[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 + #review - can these functions sensibly be used on channels not attached to the local console? + #ie can we default to {stdin stdout} but allow other channel pairs? + # -- --- --- --- --- --- --- + proc get_cursor_pos {{inoutchannels {stdin stdout}}} { + if {$::punk::console::is_vt52} { + error "vt52 can't perform get_cursor_pos" + } + #response from terminal + #e.g \033\[46;1R + set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload + + #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 + } + + + + proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { + #e.g \x1b\[P44!~E797\x1b\\ + #re e.g {(.*)(\x1b\[P44!~([[:alnum:]])\x1b\[\\)$} + set capturingregex [string map [list %id% $id] {(.*)(\x1bP%id%!~([[:alnum:]]+)\x1b\\)$}] + set request "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" + set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex] + return $payload + } + proc get_device_status {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[([0-9]+)n)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[5n" + set payload [punk::console::internal::get_ansi_response_payload -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 + # + proc get_device_attributes {{inoutchannels {stdin stdout}}} { + #Note the vt52 rough equivalen \x1bZ - commonly supported but probably best considered obsolete as it collides with ECMA 48 SCI Single Character Introducer + #DA1 + variable last_da1_result + #first element in result is the terminal's architectural class 61,62,63,64.. ? + #for vt100 we get things like: "ESC\[?1;0c" + #for vt102 "ESC\[?6c" + + #set capturingregex {(.*)(\x1b\[\?6[0-9][;]*([;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload + set capturingregex {(.*)(\x1b\[\?([0-9]*[;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[c" + set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex] + set 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 + -console -type list -minsize 2 -default {stdin stdout} + @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 + -console -type list -minsize 2 -default {stdin stdout} + @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 + } + proc get_device_attributes_tertiary {{inoutchannels {stdin stdout}}} { + #DA3 + set capturingregex {(.*)(\x1bP!\|([0-9]{8})\x1b\\)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[=c" + set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex] + return $payload + } + proc get_terminal_id {{inoutchannels {stdin stdout}}} { + #DA3 - alias + get_device_attributes_tertiary $inoutchannels + } + + proc get_tabstops {{inoutchannels {stdin stdout}}} { + #DECTABSR \x1b\[2\$w + #response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) + #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} + #set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} + set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} + set request "\x1b\[2\$w" + set payload [punk::console::internal::get_ansi_response_payload -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 + proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { + set tslist [get_tabstops $inoutchannels] + if {![llength $tslist]} { + #either terminal failed to report - or none set. + set testw [test_char_width \t] + if {[string is integer -strict $testw]} { + return $testw + } + #We don't support none - default to 8 + return 8 + } + #we generally expect to see a tabstop at column 1 - but it may not be set. + if {[lindex $tslist 0] eq "1"} { + if {[llength $tslist] == 1} { + set testw [test_char_width \t] + if {[string is integer -strict $testw]} { + return $testw + } + return 8 + } else { + set next [lindex $tslist 1] + return [expr {$next - 1}] + } + } else { + #simplistic guess at width - review - do we need to consider leftmost tabstops as more likely to be non-representative and look further into the list? + if {[llength $tslist] == 1} { + return [lindex $tslist 0] + } else { + return [expr {[lindex $tslist 1] - [lindex $tslist 0]}] + } + } + } + #default to 8 just because it seems to be most common default in terminals + proc set_tabstop_width {{w 8}} { + set tsize [get_size] + set width [dict get $tsize columns] + set mod [expr {$width % $w}] + set max [expr {$width - $mod}] + set tstop_ansi "" + set c 1 + while {$c <= $max} { + append tstop_ansi [string repeat " " $w][punk::ansi::set_tabstop] + incr c $w + } + set ::punk::console::tabwidth $w ;#we also attempt to read terminal's tabstops and set tabwidth to the apparent spacing of first non-1 value in tabstops list. + #catch {textutil::tabify::untabify2 "" $w} ;#textutil tabify can end up uninitialised and raise errors like "can't read Spaces().." after a tabstop change This call seems to keep tabify happy - review. + puts -nonewline "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstop_ansi" + } + + + proc get_cursor_pos_list {{inoutchannels {stdin stdout}}} { + return [split [get_cursor_pos $inoutchannels] ";"] + } + + #todo - work out how to query terminal and set cell size in pixels + #for now use the windows default + variable cell_size + set cell_size "" + set cell_size_fallback 10x20 + + #todo - change -console to -terminalobject with prebuilt default + + punk::args::define { + @id -id ::punk::console::cell_size + -console -default {stdin stdout} -type list + @values -min 0 -max 1 + newsize -default "" -help\ + "character cell pixel dimensions WxH + or omit to query cell size." + } + proc cell_size {args} { + set argd [punk::args::parse $args -cache 1 withid ::punk::console::cell_size] + set terminal [dict get $argd opts -console] + set newsize [dict get $argd values newsize] + + variable cell_size + if {$newsize eq ""} { + #query existing setting + if {$cell_size eq ""} { + #not set - try to query terminal's overall dimensions + set pixeldict [punk::console::get_xterm_pixels $terminal] + lassign $pixeldict _w sw _h sh + if {[string is integer -strict $sw] && [string is integer -strict $sh]} { + lassign [punk::console::get_size] _cols columns _rows rows + #review - is returned size in pixels always a multiple of rows and cols? + set w [expr {$sw / $columns}] + set h [expr {$sh / $rows}] + set cell_size ${w}x${h} + return $cell_size + } else { + set cell_size $::punk::console::cell_size_fallback + puts stderr "punk::console::cell_size unable to query terminal for pixel data - using default $cell_size" + return $cell_size + } + } + return $cell_size + } + #newsize supplied - try to set + lassign [split [string tolower $newsize] x] w h + if {![string is integer -strict $w] || ![string is integer -strict $h] || $w < 1 || $h < 1} { + error "punk::sixel::cell_size error - expected format WxH where W and H are positive integers - got '$newsize'" + } + set cell_size ${w}x${h} + } + punk::args::define { + @id -id ::punk::console::test_is_vt52 + @cmd -name punk::console::test_is_vt52 -help\ + "in development.. broken" + -inoutchannels -default {stdin stdout} -type list + @values -min 0 -max 0 + } + + #only works in raw mode for windows terminal - (esc in output stripped?) why? + # works in line mode for alacrity and wezterm + proc test_is_vt52 {args} { + set argd [punk::args::parse $args -cache 1 withid ::punk::console::test_is_vt52] + set inoutchannels [dict get $argd opts -inoutchannels] + #ESC / K VT52 without printer + #ESC / M VT52 with printer + #ESC / Z VT52 emulator?? review + + #TODO + set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload + #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload + set request "\x1bZ" + set payload [punk::console::internal::get_ansi_response_payload -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). + proc input_at_eof {{input stdin}} { + if {[catch {chan eof $input} is_eof]} { + return 1 ;#closed/invalid channel - unusable + } + if {$is_eof} { + return 1 + } + if {[catch {chan configure $input} conf]} { + return 1 + } + if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { + #console/tty - not subject to the deferred-eof pipe situation, and we must not consume a + #pending keystroke with a probe read here. + return 0 + } + #pipe-like channel - probe without blocking to force eof detection + if {[catch { + set prior_blocking [dict get $conf -blocking] + chan configure $input -blocking 0 + set probe [read $input 1] + chan configure $input -blocking $prior_blocking + }]} { + return 1 + } + if {$probe ne ""} { + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + lappend input_chunks_waiting($input) $probe + } + return [chan eof $input] + } + + #Best effort determination of whether an input channel could be connected to a terminal able to + #answer ANSI queries (cursor position reports etc). + #Returns 0 only when reasonably confident it cannot: channel closed/at eof (probed), or no console/tty + #indicators and no terminal-suggesting environment hints. + #Note: mintty without winpty (e.g git bash) presents a terminal's stdin as a pipe with no -inputmode, + #so absence of console/tty indicators alone must not be treated as 'not a terminal'. Environment hints + #(MSYSTEM, TERM_PROGRAM) are used to avoid false negatives there, at the cost of false positives in + #environments that inherit such vars with genuinely piped (but still open) input - those paths still + #rely on the ANSI query timeout mechanisms rather than hanging indefinitely. + proc is_input_console_or_tty {{input stdin}} { + if {[catch {chan configure $input} conf]} { + return 0 + } + if {[dict exists $conf -inputmode]} { + #windows console (and some other terminal environments) + return 1 + } + if {[dict exists $conf -mode]} { + #tty on unix-like platforms + return 1 + } + if {[input_at_eof $input]} { + return 0 + } + if {[info exists ::env(TERM_PROGRAM)] || [info exists ::env(MSYSTEM)]} { + #possibly mintty (or similar) without winpty - terminal presenting channels as pipes + return 1 + } + return 0 + } + + #Resolve a console specification to its channel pair and (optionally) governing object. + #Accepted forms: + # 2-element list - {in out} channel pair (legacy/primitive form) + # 1-element value - name of an anchored opunk::console instance + # >=7 element list - an ::opunk::Console (or subclass) object value (voo) + #Returns dict: in out object + #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 { + return [dict create in [lindex $spec 0] out [lindex $spec 1] 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)" + } + 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} { + 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" + } + } + } + + 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) + switch -exact -- [llength $args] { + 0 { + set consolespec {stdin stdout} + } + 1 { + set consolespec [lindex $args 0] ;#legacy positional inoutchannels - accepts any console spec form + } + 2 { + if {[lindex $args 0] ne "-console"} { + error "get_size: expected ?consolespec? or -console - got '$args'" + } + set consolespec [lindex $args 1] + } + default { + error "get_size: expected ?consolespec? or -console - got '$args'" + } + } + 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 + set tried_mechlist [list] + + #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 + } + lappend tried_mechlist "chanconfigure" + + #settled facts on a supplied console object override the heuristics in both directions + set can_respond -1 + if {$cobj ne ""} { + set can_respond [::opunk::Console::get.o_can_respond $cobj] + } + if {$can_respond == 0} { + #console object is settled as unable to answer queries - its default_size is authoritative. + #(tput deliberately not consulted here: it reflects the controlling terminal environment, + # not the supplied channel pair) + return [::opunk::Console::default_size $cobj] + } + + if {$can_respond != 1 && ![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] + } + + + variable is_vt52 + if {$is_vt52} { + #vt52 doesn't support cursor save/restore or cursor position reports. + if {![catch {get_size_using_tput $inoutchannels} sizedict]} { + return $sizedict + } + lappend tried_mechlist "tput" + error "can't get console size. Tried mechanisms: $mechlist" + } + + 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 + } + lappend tried_mechlist $mech + } + + #if {![catch {get_size_using_cursorrestore $inoutchannels} sizedict]} { + # return $sizedict + #} + #lappend tried_mechlist "cursorrestore" + + #if {![catch {get_size_using_cursormove $inoutchannels} sizedict]} { + # return $sizedict + #} + #lappend tried_mechlist "cursormove" + + #if {![catch {get_size_using_tput $inoutchannels} sizedict]} { + # return $sizedict + #} + #lappend tried_mechlist "tput" + + error "can't get console size. Tried mechanisms: $tried_mechlist" + } + + proc get_size_using_chanconfigure {{inoutchannels {stdin stdout}}} { + 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" + + #we don't need to care about the input channel if chan configure on the output can give us the info. + #short circuit ansi cursor movement method if chan configure supports the -winsize value + set outconf [chan configure $out] + if {[dict exists $outconf -winsize]} { + #this mechanism is much faster than ansi cursor movements + #REVIEW check if any x-platform anomalies with this method? + #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least + lassign [dict get $outconf -winsize] cols lines + if {[string is integer -strict $cols] && [string is integer -strict $lines]} { + return [dict create columns $cols rows $lines] + } + #continue on to ansi mechanism if we didn't get 2 ints + } + + } + + proc get_size_using_tput {{inoutchannels {stdin stdout}}} { + 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] + } + + proc get_size_using_cursormove {{inoutchannels {stdin stdout}}} { + set out [lindex $inoutchannels 1] + #we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 + #chan eof is faster whether chan exists or not than + if {[catch {chan eof $out} is_eof]} { + error "punk::console::get_size_using_cursormove output channel $out seems to be closed ([info level 1])" + } else { + if {$is_eof} { + error "punk::console::get_size_using_cursormove eof on output channel $out ([info level 1])" + } + } + + lassign [get_cursor_pos_list $inoutchannels] start_row start_col + if {[catch { + #some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. + #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. + puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::move 2000 2000] + lassign [get_cursor_pos_list $inoutchannels] lines cols + puts -nonewline $out [punk::ansi::move $start_row $start_col][punk::ansi::cursor_on];flush stdout + set result [dict create columns $cols rows $lines] + } errM]} { + puts -nonewline $out [punk::ansi::move $start_row $start_col] + puts -nonewline $out [punk::ansi::cursor_on] + error "$errM" + } else { + return $result + } + } + + #faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore + proc get_size_using_cursorrestore {{inoutchannels {stdin stdout}}} { + lassign $inoutchannels in out + set outconf [chan configure $out] + #don't use shortcut mechanisms - this function is intended to specificall use the cursor_save/restore method + + if {[catch {chan eof $out} is_eof]} { + error "punk::console::get_size_using_cursorrestore output channel $out seems to be closed ([info level 1])" + } else { + if {$is_eof} { + error "punk::console::get_size_using_cursorrestore eof on output channel $out ([info level 1])" + } + } + + if {[catch { + #some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. + #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. + puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] + lassign [get_cursor_pos_list $inoutchannels] lines cols + puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out + set result [dict create columns $cols rows $lines] + } errM]} { + puts -nonewline $out [punk::ansi::cursor_restore_dec] + puts -nonewline $out [punk::ansi::cursor_on] + error "$errM" + } else { + return $result + } + } + + + proc get_dimensions {{inoutchannels {stdin stdout}}} { + lassign [get_size $inoutchannels] _c cols _l lines + return "${cols}x${lines}" + } + + + + #the (xterm?) CSI 18t query is supported by *some* terminals + proc get_xterm_size {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[18t" + set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex] + lassign [split $payload {;}] rows cols + return [list columns $cols rows $rows] + } + proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[14t" + set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex] + lassign [split $payload {;}] height width + return [list width $width height $height] + } + + + + + + proc dec_get_mode_line_wrap {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[?7\$p" + set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex] + return $payload + } + #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #windows terminal defaults to LNM on, but wezterm on windows default to LNM off + #LNM on sends both and ?? + proc ansi_get_mode_LNM {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[20;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[20\$p" + set payload [punk::console::internal::get_ansi_response_payload -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 [ ? $ p + Where is an integer + formed from the supplied ${$I}mode${$NI} value. + + The terminal should respond with a sequence of the form: + ESC [ ? ; $ y + where 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 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 + -console -type list -minsize 2 -default {stdin stdout} + ${[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 [ ? h + Where is a colon delimited set of integers + formed from the supplied ${$I}mode${$NI} values. + } + @opts + -console -type list -minsize 2 -default {stdin stdout} + @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 [lindex $terminal 1] + 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 [ ? l + Where is a colon delimited set of integers + formed from the supplied ${$I}mode${$NI} values. + } + @opts + -console -type list -minsize 2 -default {stdin stdout} + @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 [lindex $terminal 1] + puts -nonewline $term_out "\x1b\[?${modes_string}l" + } + + variable dec_has_mode_cache + set dec_has_mode_cache [dict create] + 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 [ ? $ p + Where 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 + -console -type list -minsize 2 -default {stdin stdout} + ${[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_get_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" + } + } + variable dec_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" + if {$do_refresh} { + if {[dict exists $dec_has_mode_cache $cachekey $m]} { + dict unset dec_has_mode_cache $cachekey $m + } + } + + if {![dict exists $dec_has_mode_cache $cachekey $m]} { + 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 ""} { + dict set dec_has_mode_cache $cachekey $m $has_mode + set source "query" + } else { + #don't cache an empty/failed response - review + set has_mode 0 + set source "failedquery" + } + } else { + set has_mode [dict get $dec_has_mode_cache $cachekey $m] + 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 + -console -type list -minsize 2 -default {stdin stdout} + ${[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 + } + + variable ansi_has_mode_cache + set ansi_has_mode_cache [dict create] + 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 [ $ p${$N} + Where ${$B}${$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} + -console -type list -minsize 2 -default {stdin stdout} + -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]" + } + } + variable ansi_has_mode_cache + #make sure we cache on both console and passthrough + set cachekey "$console $passthrough" + if {$do_refresh} { + if {[dict exists $ansi_has_mode_cache $cachekey $m]} { + dict unset ansi_has_mode_cache $cachekey $m + } + } + + if {![dict exists $ansi_has_mode_cache $cachekey $m]} { + 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 ""} { + dict set ansi_has_mode_cache $cachekey $m $has_mode + set source "query" + } else { + #don't cache an empty/failed response - review + set has_mode 0 + set source "failedquery" + } + } else { + set has_mode [dict get $ansi_has_mode_cache $cachekey $m] + 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 [ h + Where is a colon delimited set of integers + formed from the supplied ${$I}mode${$NI} values. + } + @opts + -console -type list -minsize 2 -default {stdin stdout} + @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 [lindex $terminal 1] + 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 [ l + Where is a colon delimited set of integers + formed from the supplied ${$I}mode${$NI} values. + } + @opts + -console -type list -minsize 2 -default {stdin stdout} + @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 [lindex $terminal 1] + 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 [ $ p + Where is an integer + formed from the supplied ${$I}mode${$NI} value. + + The terminal should respond with a sequence of the form: + ESC [ ; $ y + where 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 is returned by the ansi_get_mode function. + } + @opts + -console -type list -minsize 2 -default {stdin stdout} + ${[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 + -console -type list -minsize 2 -default {stdin stdout} + ${[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 + -console -type list -minsize 2 -default {stdin stdout} + @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 + -console -type list -minsize 2 -default {stdin stdout} + @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 { } + 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 {