From bf8aa4c80df7e7d7a654c100bcfc30f0dd1b9b71 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 4 Jul 2026 20:35:34 +1000 Subject: [PATCH] punk::console 0.3.0: emit-side -console targeting + per-console facts 0.2.0 (emit-side console targeting, migration plan phase 2): - punk::console::ansi::* emit functions, mouse/paste toggles, start_application_mode, vt52, set_tabstop_width, titleset, top-level move, test_char_width and test_string_cursor accept an optional trailing '-console ' (channel pair, anchored opunk::console instance name, or ::opunk::Console object value), parsed by new internal::opt_console_out/opt_console_channels helpers (+_var variants for triple-tail procs); documentation via shared PUNKARGS fragment ::punk::console::argdoc::console_emit_opts - fallback chains keep the console spec (get_tabstop_apparent_width -> test_char_width; set_tabstop_width -> get_size) - move_call_return now actually emits its cursor moves (previously discarded the string-returning ansi::move results) - get_size_using_cursorrestore uses string-returning punk::ansi::cursor_on (was emitting to stdout mid-sequence) 0.3.0 (per-console facts, migration plan phase 3): - is_vt52, tabwidth, cell_size, last_da1_result, grapheme_cluster_support and check::has_bug_* keyed by canonical {in out} pair via console_fact_get/console_fact_set; the default console {stdin stdout} stores facts in the legacy namespace variables so external readers (punk::repl, textblock, overtype, punk::ansi, punk::ns) are unaffected - vt52 state, size_via_query_mechanisms, get_cursor_pos and all vt52-aware emit wrappers consult the spec'd console's is_vt52 fact - grapheme_cluster_support and check::has_bug_* accept -console; TERM_PROGRAM shortcut restricted to the default console - check::has_bug_zwsp: cached-true path no longer errors; query verdicts are now actually cached - ansi_wanted/colour_disabled, ansi_available and raw-mode state deliberately remain process-global (documented at the store) PUNKARGS definitions follow the new Argument Order rule (@leaders for leading positionals); internal helpers carry documentation-only definitions. New suites: emitconsole.test (13) + consolefacts.test (9); full console suite 49/49 on Tcl 9.0.3. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com --- src/modules/punk/AGENTS.md | 2 + src/modules/punk/console-999999.0a1.0.tm | 1213 ++++++++++++++--- src/modules/punk/console-buildversion.txt | 13 +- .../testsuites/console/consolefacts.test | 272 ++++ .../testsuites/console/emitconsole.test | 321 +++++ 5 files changed, 1594 insertions(+), 227 deletions(-) create mode 100644 src/tests/modules/punk/console/testsuites/console/consolefacts.test create mode 100644 src/tests/modules/punk/console/testsuites/console/emitconsole.test diff --git a/src/modules/punk/AGENTS.md b/src/modules/punk/AGENTS.md index 218de5f7..954b260d 100644 --- a/src/modules/punk/AGENTS.md +++ b/src/modules/punk/AGENTS.md @@ -29,6 +29,8 @@ Source of truth for all modules under the `punk::*` namespace. This is the prima - New modules under `punk::*` should be created as `/-999999.0a1.0.tm` following the namespace-to-path convention. - punk::console is incrementally migrating positional `inoutchannels` arguments to the documented `-console` convention. A `-console` value may be a 2-element {in out} channel list, an anchored `opunk::console` instance name, or an `::opunk::Console` object value (resolved via `punk::console::console_spec_resolve`). Converted procs accept the legacy leading positional channel-pair during the transition; convert remaining positional procs opportunistically when touched, with tests. +- punk::console emit-side functions (the `punk::console::ansi::*` emit wrappers, mouse/paste toggles, `vt52`, `set_tabstop_width`, `titleset`, top-level `move`, and the width-test probes) accept an optional trailing `-console ` pair, parsed manually for performance by `punk::console::internal::opt_console_out`/`opt_console_channels` (`_var` variants for procs whose args-tail also carries row/col/data triples). Each carries a documentation-only PUNKARGS definition that includes the shared `::punk::console::argdoc::console_emit_opts` fragment via `punk::args::resolved_def`; keep manual parsing and PUNKARGS synchronized. New emit procs must follow this pattern. Tests live in `src/tests/modules/punk/console/testsuites/console/emitconsole.test`. +- punk::console terminal-property facts (is_vt52, tabwidth, cell_size, last_da1_result, grapheme_cluster_support, check::has_bug_*) are per-console: read/write them via `punk::console::console_fact_get`/`console_fact_set`, keyed by canonical {in out} channel pair. The process-default console `{stdin stdout}` stores its facts in the legacy namespace variables (`::punk::console::is_vt52`, `tabwidth`, ...) so existing external readers keep working - do not bypass the helpers for non-default consoles. `ansi_wanted`/`colour_disabled` (string-generation gates), `ansi_available` and raw-mode state are deliberately process-global (rationale documented at the `console_facts` store in the module). Tests live in `src/tests/modules/punk/console/testsuites/console/consolefacts.test`. - Use `punk::args::parse` with `@id` references in `argdoc` namespaces for public API procs. - Private helpers go in `namespace eval private { ... }` blocks. - Keep `namespace export` lists alphabetized. diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 375577a5..d1e5eeb8 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -148,45 +148,115 @@ namespace eval punk::console { interp alias "" ::overtype::example "" ::punk::args::helpers::example } + #Shared option-definition fragment for the emit-side console functions. + #Not a command - referenced from PUNKARGS definitions via: + # ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + punk::args::define { + @id -id ::punk::console::argdoc::console_emit_opts + @cmd -name punk::console::argdoc::console_emit_opts -help\ + "Definition fragment (not a command). + Provides the -console option documentation for the emit-side console functions." + @opts + -console -type list -default {stdin stdout} -help\ + "Console specification: a 2-element {in out} channel list, an anchored + opunk::console instance name, or an ::opunk::Console object value. + Emitted output is written to the resolved console's output channel." + } + #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 + lappend PUNKARGS [list { + @id -id ::punk::console::enable_mouse + @cmd -name punk::console::enable_mouse -summary "Emit sequences enabling terminal mouse reporting." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc enable_mouse {args} { + #see PUNKARGS id ::punk::console::enable_mouse + set out [internal::opt_console_out $args] + puts -nonewline $out \x1b\[?1000h\x1b\[?1003h\x1b\[?1015h\x1b\[?1006h + flush $out } - 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 + lappend PUNKARGS [list { + @id -id ::punk::console::disable_mouse + @cmd -name punk::console::disable_mouse -summary "Emit sequences disabling terminal mouse reporting." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc disable_mouse {args} { + #see PUNKARGS id ::punk::console::disable_mouse + set out [internal::opt_console_out $args] + puts -nonewline $out \x1b\[?1000l\x1b\[?1003l\x1b\[?1015l\x1b\[?1006l + flush $out } - proc enable_mouse_sgr {} { - puts -nonewline stdout \x1b\[?1000h\x1b\[?1003h\x1b\[?1016h - flush stdout + lappend PUNKARGS [list { + @id -id ::punk::console::enable_mouse_sgr + @cmd -name punk::console::enable_mouse_sgr -summary "Emit sequences enabling SGR-encoded mouse reporting." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc enable_mouse_sgr {args} { + #see PUNKARGS id ::punk::console::enable_mouse_sgr + set out [internal::opt_console_out $args] + puts -nonewline $out \x1b\[?1000h\x1b\[?1003h\x1b\[?1016h + flush $out } - proc disable_mouse_sgr {} { - puts -nonewline stdout \x1b\[?1000l\x1b\[?1003l\x1b\[?1016l - flush stdout + lappend PUNKARGS [list { + @id -id ::punk::console::disable_mouse_sgr + @cmd -name punk::console::disable_mouse_sgr -summary "Emit sequences disabling SGR-encoded mouse reporting." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc disable_mouse_sgr {args} { + #see PUNKARGS id ::punk::console::disable_mouse_sgr + set out [internal::opt_console_out $args] + puts -nonewline $out \x1b\[?1000l\x1b\[?1003l\x1b\[?1016l + flush $out } - proc enable_bracketed_paste {} { - puts -nonewline stdout \x1b\[?2004h + lappend PUNKARGS [list { + @id -id ::punk::console::enable_bracketed_paste + @cmd -name punk::console::enable_bracketed_paste -summary "Emit sequence enabling bracketed paste mode." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc enable_bracketed_paste {args} { + #see PUNKARGS id ::punk::console::enable_bracketed_paste + puts -nonewline [internal::opt_console_out $args] \x1b\[?2004h } - proc disable_bracketed_paste {} { - puts -nonewline stdout \x1b\[?2004l + lappend PUNKARGS [list { + @id -id ::punk::console::disable_bracketed_paste + @cmd -name punk::console::disable_bracketed_paste -summary "Emit sequence disabling bracketed paste mode." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc disable_bracketed_paste {args} { + #see PUNKARGS id ::punk::console::disable_bracketed_paste + puts -nonewline [internal::opt_console_out $args] \x1b\[?2004l } - proc start_application_mode {} { + lappend PUNKARGS [list { + @id -id ::punk::console::start_application_mode + @cmd -name punk::console::start_application_mode -summary "Emit sequences entering alt-screen application mode with mouse and bracketed paste." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc start_application_mode {args} { + #see PUNKARGS id ::punk::console::start_application_mode #need loop to read events? - 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 + set out [internal::opt_console_out $args] + puts -nonewline $out \x1b\[?1049h ;#alt screen + enable_mouse {*}$args + #puts -nonewline $out \x1b\[?25l ;#hide cursor + puts -nonewline $out \x1b\[?1003h\n + enable_bracketed_paste {*}$args } #todo stop_application_mode {} {} @@ -227,6 +297,100 @@ namespace eval punk::console { namespace eval internal { + #The emit-side console functions accept an optional trailing '-console ' + #pair, parsed manually for performance (their PUNKARGS definitions are documentation-only). + #opt_console_out_var/opt_console_channels_var strip that pair from the caller's args + #variable if present, returning the resolved output channel or canonical {in out} pair. + #(safe for tails that otherwise hold row/col/data triples - a well-formed triple never has + #the literal '-console' in its 2nd-last position) + #The non-var forms additionally require that nothing else remains in the tail. + punk::args::define { + @id -id ::punk::console::internal::opt_console_out_var + @cmd -name punk::console::internal::opt_console_out_var -summary\ + "Strip a trailing '-console ' pair from the named args variable, returning the resolved output channel."\ + -help\ + "The variable named by argsvar in the caller's frame is modified in place (the + -console pair is removed if present; other content such as row/col/data triples + is left alone). Returns stdout when no -console pair is present." + @leaders + argsvar -type string -help\ + "Name of an args-tail list variable in the caller's frame." + @values -min 0 -max 0 + } + proc opt_console_out_var {argsvar} { + #see PUNKARGS id ::punk::console::internal::opt_console_out_var + upvar 1 $argsvar tail + if {[llength $tail] >= 2 && [lindex $tail end-1] eq "-console"} { + set out [dict get [punk::console::console_spec_resolve [lindex $tail end]] out] + set tail [lrange $tail 0 end-2] + return $out + } + return stdout + } + punk::args::define { + @id -id ::punk::console::internal::opt_console_channels_var + @cmd -name punk::console::internal::opt_console_channels_var -summary\ + "Strip a trailing '-console ' pair from the named args variable, returning the canonical {in out} channel pair."\ + -help\ + "The variable named by argsvar in the caller's frame is modified in place (the + -console pair is removed if present; other content such as row/col/data triples + is left alone). Returns {stdin stdout} when no -console pair is present." + @leaders + argsvar -type string -help\ + "Name of an args-tail list variable in the caller's frame." + @values -min 0 -max 0 + } + proc opt_console_channels_var {argsvar} { + #see PUNKARGS id ::punk::console::internal::opt_console_channels_var + upvar 1 $argsvar tail + if {[llength $tail] >= 2 && [lindex $tail end-1] eq "-console"} { + set cinfo [punk::console::console_spec_resolve [lindex $tail end]] + set tail [lrange $tail 0 end-2] + return [list [dict get $cinfo in] [dict get $cinfo out]] + } + return {stdin stdout} + } + punk::args::define { + @id -id ::punk::console::internal::opt_console_out + @cmd -name punk::console::internal::opt_console_out -summary\ + "Resolve an emit-function args-tail (empty or exactly '-console ') to an output channel."\ + -help\ + "Errors if the tail contains anything other than a single optional -console pair. + Returns stdout for an empty tail." + @leaders + argstail -type list -help\ + "The args-tail value: {} or {-console }." + @values -min 0 -max 0 + } + proc opt_console_out {argstail} { + #see PUNKARGS id ::punk::console::internal::opt_console_out + set out [opt_console_out_var argstail] + if {[llength $argstail]} { + error "expected optional trailing '-console ' - got '$argstail'" + } + return $out + } + punk::args::define { + @id -id ::punk::console::internal::opt_console_channels + @cmd -name punk::console::internal::opt_console_channels -summary\ + "Resolve an emit-function args-tail (empty or exactly '-console ') to a canonical {in out} channel pair."\ + -help\ + "Errors if the tail contains anything other than a single optional -console pair. + Returns {stdin stdout} for an empty tail." + @leaders + argstail -type list -help\ + "The args-tail value: {} or {-console }." + @values -min 0 -max 0 + } + proc opt_console_channels {argstail} { + #see PUNKARGS id ::punk::console::internal::opt_console_channels + set channels [opt_console_channels_var argstail] + if {[llength $argstail]} { + error "expected optional trailing '-console ' - got '$argstail'" + } + return $channels + } + proc abort_if_loop {{failmsg ""}} { #obsolete #puts "il1 [info level 1]" @@ -812,6 +976,7 @@ namespace eval punk::console { return } #tailcall punk::ansi::a {*}$args + #string generation has no console context - reads the default console's vt52 fact (legacy variable) variable is_vt52 if {$is_vt52} { return @@ -890,10 +1055,30 @@ namespace eval punk::console { #test - find a better place to set terminal type variable is_vt52 0 - proc vt52 {{onoff {}}} { + lappend PUNKARGS [list { + @id -id ::punk::console::vt52 + @cmd -name punk::console::vt52 -summary "Query or set vt52 terminal mode." + @leaders + onoff -type boolean -optional 1 -help\ + "Omit to query the current vt52 state. + The vt52 state is a per-console fact (see console_fact_get); the process-default + console's state is mirrored in the legacy ::punk::console::is_vt52 variable." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc vt52 {args} { + #see PUNKARGS id ::punk::console::vt52 #todo - return to colour state beforehand?. support 0-15 vt52 colours? (ATARI and some emulators - not original vt52) #we shouldn't have to turn off colour to enter vt52 - we should make punk::console emit correct codes - variable is_vt52 + set onoff "" + if {[llength $args] % 2 == 1} { + set onoff [lindex $args 0] + set args [lrange $args 1 end] + } + set inout [internal::opt_console_channels $args] + set out [lindex $inout 1] + set is_vt52 [console_fact_get $inout is_vt52] if {$onoff eq ""} { return $is_vt52 } @@ -902,21 +1087,21 @@ namespace eval punk::console { } if {$is_vt52} { if {!$onoff} { - puts -nonewline "\x1b<" - set is_vt52 0 - colour on + puts -nonewline $out "\x1b<" + console_fact_set $inout is_vt52 0 + colour on ;#colour state is process-global (gates string generation) - review } } else { if {$onoff} { - dec_unset_mode DECANM - set is_vt52 1 - colour off + dec_unset_mode -console $inout DECANM + console_fact_set $inout is_vt52 1 + colour off ;#colour state is process-global (gates string generation) - review } else { - puts -nonewline "\x1b<" + puts -nonewline $out "\x1b<" #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ } } - return $is_vt52 + return [console_fact_get $inout is_vt52] } namespace eval local { @@ -1049,7 +1234,7 @@ namespace eval punk::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} { + if {[console_fact_get $inoutchannels is_vt52]} { error "vt52 can't perform get_cursor_pos" } #response from terminal @@ -1109,7 +1294,6 @@ namespace eval punk::console { 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" @@ -1118,7 +1302,7 @@ namespace eval punk::console { 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 + console_fact_set $inoutchannels last_da1_result $payload return $payload } @@ -1443,7 +1627,7 @@ namespace eval punk::console { set tslist [get_tabstops $inoutchannels] if {![llength $tslist]} { #either terminal failed to report - or none set. - set testw [test_char_width \t] + set testw [test_char_width \t -console $inoutchannels] if {[string is integer -strict $testw]} { return $testw } @@ -1453,7 +1637,7 @@ namespace eval punk::console { #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] + set testw [test_char_width \t -console $inoutchannels] if {[string is integer -strict $testw]} { return $testw } @@ -1472,8 +1656,28 @@ namespace eval punk::console { } } #default to 8 just because it seems to be most common default in terminals - proc set_tabstop_width {{w 8}} { - set tsize [get_size] + lappend PUNKARGS [list { + @id -id ::punk::console::set_tabstop_width + @cmd -name punk::console::set_tabstop_width -summary "Emit sequences setting evenly spaced terminal tabstops." + @leaders + w -type integer -default 8 -optional 1 -help\ + "Tabstop spacing in character cells. + The tabwidth record is a per-console fact (see console_fact_get); the process-default + console's record is mirrored in the legacy ::punk::console::tabwidth variable." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc set_tabstop_width {args} { + #see PUNKARGS id ::punk::console::set_tabstop_width + set w 8 + if {[llength $args] % 2 == 1} { + set w [lindex $args 0] + set args [lrange $args 1 end] + } + set inout [internal::opt_console_channels $args] + set out [lindex $inout 1] + set tsize [get_size $inout] set width [dict get $tsize columns] set mod [expr {$width % $w}] set max [expr {$width - $mod}] @@ -1483,9 +1687,9 @@ namespace eval punk::console { 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. + console_fact_set $inout tabwidth $w ;#we also attempt to read terminal's tabstops and set tabwidth to the apparent spacing of first non-1 value in tabstops list. #catch {textutil::tabify::untabify2 "" $w} ;#textutil tabify can end up uninitialised and raise errors like "can't read Spaces().." 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" + puts -nonewline $out "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstop_ansi" } @@ -1514,7 +1718,11 @@ namespace eval punk::console { set terminal [dict get $argd opts -console] set newsize [dict get $argd values newsize] - variable cell_size + #cell_size is a per-console fact (the default console's record is mirrored in the legacy + #::punk::console::cell_size variable via console_fact_set) + set cinfo [console_spec_resolve $terminal] + set inout [list [dict get $cinfo in] [dict get $cinfo out]] + set cell_size [console_fact_get $inout cell_size] if {$newsize eq ""} { #query existing setting if {$cell_size eq ""} { @@ -1527,9 +1735,11 @@ namespace eval punk::console { set w [expr {$sw / $columns}] set h [expr {$sh / $rows}] set cell_size ${w}x${h} + console_fact_set $inout cell_size $cell_size return $cell_size } else { set cell_size $::punk::console::cell_size_fallback + console_fact_set $inout cell_size $cell_size puts stderr "punk::console::cell_size unable to query terminal for pixel data - using default $cell_size" return $cell_size } @@ -1541,7 +1751,7 @@ namespace eval punk::console { if {![string is integer -strict $w] || ![string is integer -strict $h] || $w < 1 || $h < 1} { error "punk::console::cell_size error - expected format WxH where W and H are positive integers - got '$newsize'" } - set cell_size ${w}x${h} + console_fact_set $inout cell_size ${w}x${h} } punk::args::define { @id -id ::punk::console::test_is_vt52 @@ -1706,6 +1916,98 @@ namespace eval punk::console { return default } + # -- --- --- --- --- --- --- + #Per-console facts (interim store for the multi-console goals G-001/G-002). + #Facts that are properties of a particular terminal (vt52 mode, tabwidth, cell size, quirk + #test results, DA1 response) are keyed by the console's canonical {in out} channel pair. + #The process-default console {stdin stdout} keeps the legacy namespace variables + #(::punk::console::is_vt52, tabwidth, cell_size, last_da1_result, grapheme_cluster_support, + #::punk::console::check::has_bug_*) as its storage, so external readers of those variables + #(punk::repl, textblock, overtype, punk::ansi, punk::ns) continue to see current values. + #Deliberately NOT stored here (process-global): + # - ansi_wanted/colour_disabled - they gate string *generation* (code_a+ etc) where the + # eventual output console is unknown + # - ansi_available - determined via the real process console (twapi); object consoles carry + # their own settled can_respond capability instead + # - tsv console is_raw and the enableRaw/disableRaw family - raw mode is a property of the + # real attached console; get_ansi_response_payload already guards against cycling it for + # non-console channels + variable console_facts + if {![info exists console_facts]} { + set console_facts [dict create] + } + variable console_fact_info + set console_fact_info [dict create {*}{ + is_vt52 {legacyvar ::punk::console::is_vt52 default 0} + tabwidth {legacyvar ::punk::console::tabwidth default 8} + cell_size {legacyvar ::punk::console::cell_size default ""} + last_da1_result {legacyvar ::punk::console::last_da1_result default ""} + grapheme_cluster_support {legacyvar ::punk::console::grapheme_cluster_support default {}} + has_bug_legacysymbolwidth {legacyvar ::punk::console::check::has_bug_legacysymbolwidth default -1} + has_bug_zwsp {legacyvar ::punk::console::check::has_bug_zwsp default -1} + }] + lappend PUNKARGS [list { + @id -id ::punk::console::console_fact_get + @cmd -name punk::console::console_fact_get -summary\ + "Read a per-console fact for the specified console."\ + -help\ + "Facts for the process-default console {stdin stdout} are stored in the legacy + namespace variables; other consoles use a store keyed by canonical channel pair. + Returns the fact's default when nothing has been recorded for the console." + @values -min 2 -max 2 + consolespec -type list -help\ + "Console specification: {in out} channel pair, anchored opunk::console instance + name, or ::opunk::Console object value." + key -type string -choices {is_vt52 tabwidth cell_size last_da1_result grapheme_cluster_support has_bug_legacysymbolwidth has_bug_zwsp} + }] + proc console_fact_get {consolespec key} { + #see PUNKARGS id ::punk::console::console_fact_get + variable console_fact_info + if {[llength $consolespec] != 2} { + set cinfo [console_spec_resolve $consolespec] + set consolespec [list [dict get $cinfo in] [dict get $cinfo out]] + } + if {[lindex $consolespec 0] eq "stdin" && [lindex $consolespec 1] eq "stdout"} { + return [set [dict get $console_fact_info $key legacyvar]] + } + variable console_facts + if {[dict exists $console_facts $consolespec $key]} { + return [dict get $console_facts $consolespec $key] + } + return [dict get $console_fact_info $key default] + } + lappend PUNKARGS [list { + @id -id ::punk::console::console_fact_set + @cmd -name punk::console::console_fact_set -summary\ + "Record a per-console fact for the specified console."\ + -help\ + "Facts for the process-default console {stdin stdout} are stored in the legacy + namespace variables (visible to their external readers); other consoles use a + store keyed by canonical channel pair. Returns the value." + @values -min 3 -max 3 + consolespec -type list -help\ + "Console specification: {in out} channel pair, anchored opunk::console instance + name, or ::opunk::Console object value." + key -type string -choices {is_vt52 tabwidth cell_size last_da1_result grapheme_cluster_support has_bug_legacysymbolwidth has_bug_zwsp} + value -type any + }] + proc console_fact_set {consolespec key value} { + #see PUNKARGS id ::punk::console::console_fact_set + variable console_fact_info + if {[llength $consolespec] != 2} { + set cinfo [console_spec_resolve $consolespec] + set consolespec [list [dict get $cinfo in] [dict get $cinfo out]] + } + if {[lindex $consolespec 0] eq "stdin" && [lindex $consolespec 1] eq "stdout"} { + set [dict get $console_fact_info $key legacyvar] $value + } else { + variable console_facts + dict set console_facts $consolespec $key $value + } + return $value + } + # -- --- --- --- --- --- --- + #default timeout for the active can_respond settling probe (see settle_can_respond) #short enough not to stall first use badly on non-responding consoles - long enough for real #terminals (incl. moderate ssh latency) to answer a cursor position report. @@ -1913,8 +2215,7 @@ namespace eval punk::console { #Used by the legacy get_size channel path and (as console_size_provider) by the base #::opunk::Console::size method via the pluggable ::opunk::console::size_query_provider hook. proc size_via_query_mechanisms {inoutchannels} { - variable is_vt52 - if {$is_vt52} { + if {[console_fact_get $inoutchannels is_vt52]} { #vt52 doesn't support cursor save/restore or cursor position reports. if {![catch {get_size_using_tput $inoutchannels} sizedict]} { return $sizedict @@ -2074,7 +2375,7 @@ namespace eval punk::console { #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 + puts -nonewline $out [punk::ansi::cursor_restore][punk::ansi::cursor_on];flush $out set result [dict create columns $cols rows $lines] } errM]} { puts -nonewline $out [punk::ansi::cursor_restore_dec] @@ -3224,7 +3525,19 @@ namespace eval punk::console { #todo - determine if these anomalies are independent of font #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) - proc test_char_width {char_or_string {emit 0}} { + lappend PUNKARGS [list { + @id -id ::punk::console::test_char_width + @cmd -name punk::console::test_char_width -summary "Measure a string's rendered width via cursor position reports." + @leaders + char_or_string -type string + emit -type boolean -default 0 -optional 1 -help\ + "Leave the test string visible instead of erasing the line around the test." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc test_char_width {char_or_string args} { + #see PUNKARGS id ::punk::console::test_char_width #return 1 #JMN #puts stderr "cwtest" @@ -3233,13 +3546,20 @@ namespace eval punk::console { puts stderr "No ansi - cannot test char_width of '$char_or_string' returning [string length $char_or_string]" return [string length $char_or_string] } + set emit 0 + if {[llength $args] % 2 == 1} { + set emit [lindex $args 0] + set args [lrange $args 1 end] + } + set inoutchannels [internal::opt_console_channels $args] + set out [lindex $inoutchannels 1] if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 + puts -nonewline $out \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 } set response "" if {[catch { - set response [punk::console::get_cursor_pos] + set response [punk::console::get_cursor_pos $inoutchannels] } errM]} { puts stderr "Cannot test_char_width for '[punk::ansi::ansistring VIEW $char_or_string]' - may be no console? Error message from get_cursor_pos: $errM" return @@ -3254,12 +3574,12 @@ namespace eval punk::console { #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error #e.g contains surrogate pair if {[catch { - puts -nonewline stdout $char_or_string + puts -nonewline $out $char_or_string } errM]} { puts stderr "test_char_width couldn't emit this string - \nerror: $errM" } - set response [punk::console::get_cursor_pos] + set response [punk::console::get_cursor_pos $inoutchannels] lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { puts stderr "test_char_width could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" @@ -3268,9 +3588,9 @@ namespace eval punk::console { } if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G + puts -nonewline $out \033\[2K\033\[1G } - flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. + flush $out;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. return [expr {$col2 - $col1}] } @@ -3282,20 +3602,39 @@ namespace eval punk::console { #When cursor is already at bottom of screen, scrolling will occur so rowoffset will be zero #we either need to move cursor up before test - or use alt screen ( or scroll_up then scroll_down?) #for now we will use alt screen to reduce scrolling effects - REVIEW - proc test_string_cursor {teststring {emit 0}} { + lappend PUNKARGS [list { + @id -id ::punk::console::test_string_cursor + @cmd -name punk::console::test_string_cursor -summary "Report cursor row/column offsets produced by emitting a string (uses alt screen)." + @leaders + teststring -type string + emit -type boolean -default 0 -optional 1 -help\ + "Leave the test string visible instead of erasing the line around the test." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc test_string_cursor {teststring args} { + #see PUNKARGS id ::punk::console::test_string_cursor variable ansi_available if {!$ansi_available} { puts stderr "No ansi - cannot test char_width of '$teststring' returning [string length $teststring]" return [string length $teststring] } - punk::console::enable_alt_screen - punk::console::move 0 0 + set emit 0 + if {[llength $args] % 2 == 1} { + set emit [lindex $args 0] + set args [lrange $args 1 end] + } + set inoutchannels [internal::opt_console_channels $args] + set out [lindex $inoutchannels 1] + punk::console::enable_alt_screen -console $inoutchannels + punk::console::move 0 0 -console $inoutchannels if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 + puts -nonewline $out \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 } set response "" if {[catch { - set response [punk::console::get_cursor_pos] + set response [punk::console::get_cursor_pos $inoutchannels] } errM]} { puts stderr "Cannot test_string_cursor for '[punk::ansi::ansistring VIEW $teststring]' - may be no console? Error message from get_cursor_pos: $errM" return @@ -3307,9 +3646,9 @@ namespace eval punk::console { return } - puts -nonewline stdout $teststring - flush stdout - set response [punk::console::get_cursor_pos] + puts -nonewline $out $teststring + flush $out + set response [punk::console::get_cursor_pos $inoutchannels] lassign [split $response ";"] row2 col2 if {![string is integer -strict $col2] || ![string is integer -strict $row2]} { puts stderr "test_string_cursor could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" @@ -3318,10 +3657,10 @@ namespace eval punk::console { } if {!$emit} { - puts -nonewline stdout \033\[2K\033\[1G + puts -nonewline $out \033\[2K\033\[1G } - flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. - punk::console::disable_alt_screen + flush $out;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. + punk::console::disable_alt_screen -console $inoutchannels return [list rowoffset [expr {$row2 - $row1}] columnoffset [expr {$col2 - $col1}]] } @@ -3377,15 +3716,30 @@ namespace eval punk::console { } - variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested + variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested (per-console fact storage for the default console) #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) - proc grapheme_cluster_support {} { - variable grapheme_cluster_support - if {[dict size $grapheme_cluster_support]} { - return $grapheme_cluster_support + lappend PUNKARGS [list { + @id -id ::punk::console::grapheme_cluster_support + @cmd -name punk::console::grapheme_cluster_support -summary\ + "Determine terminal grapheme cluster support (decmode 2027), as a dict with keys available and mode."\ + -help\ + "Returns a pre-recorded per-console fact if one exists (see console_fact_get/console_fact_set) + - otherwise queries the console each call (the query result is not auto-recorded as the mode + may change during a session)." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc grapheme_cluster_support {args} { + #see PUNKARGS id ::punk::console::grapheme_cluster_support + set inout [internal::opt_console_channels $args] + set recorded [console_fact_get $inout grapheme_cluster_support] + if {[dict size $recorded]} { + return $recorded } - if {[info exists ::env(TERM_PROGRAM)]} { + if {[lindex $inout 0] eq "stdin" && [lindex $inout 1] eq "stdout" && [info exists ::env(TERM_PROGRAM)]} { + #env hints describe the process's own terminal - only trust them for the default console #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) (2025-12 update - 2027 request works) # iterm and apple terminal also set TERM_PROGRAM @@ -3395,7 +3749,7 @@ namespace eval punk::console { } } #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - set state [dec_get_mode grapheme_clusters] ;#decmode 2027 extension + set state [dec_get_mode -console $inout grapheme_clusters] ;#decmode 2027 extension set is_available 0 switch -- $state { 0 { @@ -3511,53 +3865,132 @@ namespace eval punk::console { #proc a? {args} { # puts -nonewline stdout [::punk::ansi::a? {*}$args] #} - proc clear {} { - puts -nonewline stdout [punk::ansi::clear] + #The emit functions in this namespace accept an optional trailing '-console ' + #pair (see PUNKARGS id ::punk::console::argdoc::console_emit_opts), parsed manually for + #performance via ::punk::console::internal::opt_console_out and friends. Each proc's + #PUNKARGS definition is documentation-only and must be kept synchronized with the parsing. + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::clear + @cmd -name punk::console::ansi::clear -summary "Emit clear-display sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc clear {args} { + #see PUNKARGS id ::punk::console::ansi::clear + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear] } - proc clear_above {} { - puts -nonewline stdout [punk::ansi::clear_above] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::clear_above + @cmd -name punk::console::ansi::clear_above -summary "Emit clear-above-cursor sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc clear_above {args} { + #see PUNKARGS id ::punk::console::ansi::clear_above + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear_above] } - proc clear_below {} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::clear_below] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::clear_below + @cmd -name punk::console::ansi::clear_below -summary "Emit clear-below-cursor sequence (ANSI or vt52)." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc clear_below {args} { + #see PUNKARGS id ::punk::console::ansi::clear_below + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::clear_below] } else { - puts -nonewline stdout [punk::ansi::vt52clear_below] + puts -nonewline $out [punk::ansi::vt52clear_below] } } - proc clear_all {} { - puts -nonewline stdout [punk::ansi::clear_all] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::clear_all + @cmd -name punk::console::ansi::clear_all -summary "Emit clear-all sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc clear_all {args} { + #see PUNKARGS id ::punk::console::ansi::clear_all + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear_all] } - proc clear_scrollback {} { - puts -nonewline stdout [punk::ansi::clear_scrollback] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::clear_scrollback + @cmd -name punk::console::ansi::clear_scrollback -summary "Emit clear-scrollback sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc clear_scrollback {args} { + #see PUNKARGS id ::punk::console::ansi::clear_scrollback + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::clear_scrollback] } - proc S8C1R {} { - puts -nonewline stdout [punk::ansi::S8C1R] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::S8C1R + @cmd -name punk::console::ansi::S8C1R -summary "Emit S8C1R (request 8-bit C1 response) sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc S8C1R {args} { + #see PUNKARGS id ::punk::console::ansi::S8C1R + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::S8C1R] } - proc reset {} { - puts -nonewline stdout [punk::ansi::reset] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::reset + @cmd -name punk::console::ansi::reset -summary "Emit terminal reset sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc reset {args} { + #see PUNKARGS id ::punk::console::ansi::reset + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::reset] } - proc cursor_on {} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::cursor_on] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursor_on + @cmd -name punk::console::ansi::cursor_on -summary "Emit cursor-visible sequence (ANSI or vt52)." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursor_on {args} { + #see PUNKARGS id ::punk::console::ansi::cursor_on + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::cursor_on] } else { - puts -nonewline stdout [punk::ansi::vt52cursor_on] + puts -nonewline $out [punk::ansi::vt52cursor_on] } } - proc cursor_off {} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::cursor_off] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursor_off + @cmd -name punk::console::ansi::cursor_off -summary "Emit cursor-hidden sequence (ANSI or vt52)." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursor_off {args} { + #see PUNKARGS id ::punk::console::ansi::cursor_off + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::cursor_off] } else { - puts -nonewline stdout [punk::ansi::vt52cursor_off] + puts -nonewline $out [punk::ansi::vt52cursor_off] } } lappend PUNKARGS [list { @id -id ::punk::console::ansi::move - @cmd -name punk::console::move -help\ + @cmd -name punk::console::ansi::move -help\ {Return an ANSI or vt52 sequence to move cursor to row,col (aka: cursor home) @@ -3585,75 +4018,176 @@ namespace eval punk::console { modes are supported. } - @values -min 2 -max 2 + @leaders row -type integer -help\ "row number - starting at 1" col -type integer -help\ "column number - starting at 1" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 }] - proc move {row col} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { + proc move {row col args} { + #see PUNKARGS id ::punk::console::ansi::move + #returns the sequence as a string - the -console spec selects ANSI vs vt52 encoding + #based on that console's is_vt52 fact (no emission occurs here) + set inout [::punk::console::internal::opt_console_channels $args] + if {![punk::console::console_fact_get $inout is_vt52]} { return [punk::ansi::move $row $col] } else { return [punk::ansi::vt52move $row $col] } } - proc move_forward {n} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::move_forward $n] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_forward + @cmd -name punk::console::ansi::move_forward -summary "Emit cursor-forward sequence (ANSI or vt52)." + @leaders + n -type integer -help "number of columns to move forward" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_forward {n args} { + #see PUNKARGS id ::punk::console::ansi::move_forward + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::move_forward $n] } else { - puts -nonewline stdout [punk::ansi::vt52move_forward $n] + puts -nonewline $out [punk::ansi::vt52move_forward $n] } } - proc move_back {n} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::move_back $n] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_back + @cmd -name punk::console::ansi::move_back -summary "Emit cursor-back sequence (ANSI or vt52)." + @leaders + n -type integer -help "number of columns to move back" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_back {n args} { + #see PUNKARGS id ::punk::console::ansi::move_back + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::move_back $n] } else { - puts -nonewline stdout [punk::ansi::vt52move_back $n] + puts -nonewline $out [punk::ansi::vt52move_back $n] } } - proc move_up {n} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::move_up $n] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_up + @cmd -name punk::console::ansi::move_up -summary "Emit cursor-up sequence (ANSI or vt52)." + @leaders + n -type integer -help "number of rows to move up" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_up {n args} { + #see PUNKARGS id ::punk::console::ansi::move_up + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::move_up $n] } else { - puts -nonewline stdout [punk::ansi::vt52move_up $n] + puts -nonewline $out [punk::ansi::vt52move_up $n] } } - proc move_down {n} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::move_down $n] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_down + @cmd -name punk::console::ansi::move_down -summary "Emit cursor-down sequence (ANSI or vt52)." + @leaders + n -type integer -help "number of rows to move down" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_down {n args} { + #see PUNKARGS id ::punk::console::ansi::move_down + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::move_down $n] } else { - puts -nonewline stdout [punk::ansi::vt52move_down $n] + puts -nonewline $out [punk::ansi::vt52move_down $n] } } - proc move_column {col} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::move_column $col] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_column + @cmd -name punk::console::ansi::move_column -summary "Emit move-to-column sequence (ANSI or vt52)." + @leaders + col -type integer -help "column number - starting at 1" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_column {col args} { + #see PUNKARGS id ::punk::console::ansi::move_column + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::move_column $col] } else { - puts -nonewline stdout [punk::ansi::vt52move_column $col] + puts -nonewline $out [punk::ansi::vt52move_column $col] } } - proc move_row {row} { - puts -nonewline stdout [punk::ansi::move_row $row] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_row + @cmd -name punk::console::ansi::move_row -summary "Emit move-to-row sequence." + @leaders + row -type integer -help "row number - starting at 1" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_row {row args} { + #see PUNKARGS id ::punk::console::ansi::move_row + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::move_row $row] } + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_emit + @cmd -name punk::console::ansi::move_emit -summary "Emit data at row,col (ANSI or vt52)." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + data -type string + triple -type any -optional 1 -multiple 1 -help\ + "additional row col data triples" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] proc move_emit {row col data args} { - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { - puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] + #see PUNKARGS id ::punk::console::ansi::move_emit + set inout [::punk::console::internal::opt_console_channels_var args] + set out [lindex $inout 1] + if {![punk::console::console_fact_get $inout is_vt52]} { + puts -nonewline $out [punk::ansi::move_emit $row $col $data {*}$args] } else { - puts -nonewline stdout [punk::ansi::vt52move_emit $row $col $data {*}$args] + puts -nonewline $out [punk::ansi::vt52move_emit $row $col $data {*}$args] } } + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_emit_return + @cmd -name punk::console::ansi::move_emit_return -summary "Emit data at row,col then return cursor to its previous position." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + data -type string + triple -type any -optional 1 -multiple 1 -help\ + "additional row col data triples" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] proc move_emit_return {row col data args} { + #see PUNKARGS id ::punk::console::ansi::move_emit_return #todo detect if in raw mode or not? set is_in_raw 0 - lassign [punk::console::get_cursor_pos_list] orig_row orig_col + set inout [::punk::console::internal::opt_console_channels_var args] + lassign [punk::console::get_cursor_pos_list $inout] orig_row orig_col set commands "" append commands [punk::ansi::move_emit $row $col $data] @@ -3664,11 +4198,24 @@ namespace eval punk::console { incr orig_row -1 } append commands [punk::ansi::move $orig_row $orig_col] - puts -nonewline stdout $commands + puts -nonewline [lindex $inout 1] $commands return "" } - proc move_emitblock_return {row col textblock} { - lassign [punk::console::get_cursor_pos_list] orig_row orig_col + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_emitblock_return + @cmd -name punk::console::ansi::move_emitblock_return -summary "Emit a multiline textblock at row,col then return cursor to its previous position." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + textblock -type string + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_emitblock_return {row col textblock args} { + #see PUNKARGS id ::punk::console::ansi::move_emitblock_return + set inout [::punk::console::internal::opt_console_channels $args] + lassign [punk::console::get_cursor_pos_list $inout] orig_row orig_col set commands [punk::ansi::move_emit $row $col $textblock] ;#move_emit can handle multiple line blocks. #set commands "" @@ -3677,16 +4224,31 @@ namespace eval punk::console { # incr row #} append commands [punk::ansi::move $orig_row $orig_col] - puts -nonewline $commands + puts -nonewline [lindex $inout 1] $commands return } #we can be (slightly?) faster and more efficient if we use the consoles cursor_save_dec command - but each savecursor overrides any previous one. #leave cursor_off/cursor_on to caller who can wrap more efficiently.. + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursorsave_move_emit_return + @cmd -name punk::console::ansi::cursorsave_move_emit_return -summary "Emit data at row,col bracketed by cursor save/restore (ANSI or vt52)." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + data -type string + triple -type any -optional 1 -multiple 1 -help\ + "additional row col data triples" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] proc cursorsave_move_emit_return {row col data args} { - upvar ::punk::console::is_vt52 is_vt52 + #see PUNKARGS id ::punk::console::ansi::cursorsave_move_emit_return + set inout [::punk::console::internal::opt_console_channels_var args] + set out [lindex $inout 1] #JMN set commands "" - if {!$is_vt52} { + if {![punk::console::console_fact_get $inout is_vt52]} { append commands [punk::ansi::cursor_save_dec] append commands [punk::ansi::move_emit $row $col $data] foreach {row col data} $args { @@ -3701,12 +4263,25 @@ namespace eval punk::console { } append commands [punk::ansi::vt52cursor_restore] } - puts -nonewline stdout $commands; flush stdout + puts -nonewline $out $commands; flush $out } - proc cursorsave_move_emitblock_return {row col textblock} { + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursorsave_move_emitblock_return + @cmd -name punk::console::ansi::cursorsave_move_emitblock_return -summary "Emit a multiline textblock at row,col bracketed by cursor save/restore (ANSI or vt52)." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + textblock -type string + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursorsave_move_emitblock_return {row col textblock args} { + #see PUNKARGS id ::punk::console::ansi::cursorsave_move_emitblock_return + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] set commands "" - upvar ::punk::console::is_vt52 is_vt52 - if {!$is_vt52} { + if {![punk::console::console_fact_get $inout is_vt52]} { append commands [punk::ansi::cursor_save_dec] foreach ln [split $textblock \n] { append commands [punk::ansi::move_emit $row $col $ln] @@ -3721,72 +4296,223 @@ namespace eval punk::console { } append commands [punk::ansi::vt52cursor_restore] } - puts -nonewline stdout $commands;flush stdout + puts -nonewline $out $commands;flush $out return } - proc move_call_return {row col script} { - lassign [punk::console::get_cursor_pos_list] orig_row orig_col - move $row $col + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::move_call_return + @cmd -name punk::console::ansi::move_call_return -summary "Move cursor to row,col, run script, then return cursor to its previous position." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + script -type string + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc move_call_return {row col script args} { + #see PUNKARGS id ::punk::console::ansi::move_call_return + set inout [::punk::console::internal::opt_console_channels $args] + set out [lindex $inout 1] + lassign [punk::console::get_cursor_pos_list $inout] orig_row orig_col + #move here is the string-returning ansi::move - emit its result explicitly + puts -nonewline $out [move $row $col -console $inout] uplevel 1 $script - move $orig_row $orig_col + puts -nonewline $out [move $orig_row $orig_col -console $inout] } - proc scroll_up {n} { - puts -nonewline stdout [punk::ansi::scroll_up $n] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::scroll_up + @cmd -name punk::console::ansi::scroll_up -summary "Emit scroll-up sequence." + @leaders + n -type integer -help "number of rows to scroll" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc scroll_up {n args} { + #see PUNKARGS id ::punk::console::ansi::scroll_up + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::scroll_up $n] } - proc scroll_down {n} { - puts -nonewline stdout [punk::ansi::scroll_down $n] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::scroll_down + @cmd -name punk::console::ansi::scroll_down -summary "Emit scroll-down sequence." + @leaders + n -type integer -help "number of rows to scroll" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc scroll_down {n args} { + #see PUNKARGS id ::punk::console::ansi::scroll_down + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::scroll_down $n] } - proc enable_alt_screen {} { - puts -nonewline stdout [punk::ansi::enable_alt_screen] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::enable_alt_screen + @cmd -name punk::console::ansi::enable_alt_screen -summary "Emit switch-to-alternate-screen sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc enable_alt_screen {args} { + #see PUNKARGS id ::punk::console::ansi::enable_alt_screen + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::enable_alt_screen] } - proc disable_alt_screen {} { - puts -nonewline stdout [punk::ansi::disable_alt_screen] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::disable_alt_screen + @cmd -name punk::console::ansi::disable_alt_screen -summary "Emit switch-to-main-screen sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc disable_alt_screen {args} { + #see PUNKARGS id ::punk::console::ansi::disable_alt_screen + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::disable_alt_screen] } #review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress. #caller should build as much as possible using the punk::ansi versions to avoid extra puts calls - proc cursor_save {} { + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursor_save + @cmd -name punk::console::ansi::cursor_save -summary "Emit SCOSC cursor-save sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursor_save {args} { + #see PUNKARGS id ::punk::console::ansi::cursor_save #*** !doctools #[call [fun cursor_save]] - puts -nonewline stdout \x1b\[s + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[s } - proc cursor_restore {} { + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursor_restore + @cmd -name punk::console::ansi::cursor_restore -summary "Emit SCORC cursor-restore sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursor_restore {args} { + #see PUNKARGS id ::punk::console::ansi::cursor_restore #*** !doctools #[call [fun cursor_restore]] - puts -nonewline stdout \x1b\[u + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[u } #DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? - proc cursor_save_dec {} { + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursor_save_dec + @cmd -name punk::console::ansi::cursor_save_dec -summary "Emit DECSC cursor-save sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursor_save_dec {args} { + #see PUNKARGS id ::punk::console::ansi::cursor_save_dec #*** !doctools #[call [fun cursor_save_dec]] - puts -nonewline \x1b7 + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b7 } - proc cursor_restore_dec {} { + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::cursor_restore_dec + @cmd -name punk::console::ansi::cursor_restore_dec -summary "Emit DECRC cursor-restore sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc cursor_restore_dec {args} { + #see PUNKARGS id ::punk::console::ansi::cursor_restore_dec #*** !doctools #[call [fun cursor_restore_dec]] - puts -nonewline \x1b8 + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b8 } - proc insert_spaces {count} { - puts -nonewline stdout \x1b\[${count}@ + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::insert_spaces + @cmd -name punk::console::ansi::insert_spaces -summary "Emit insert-spaces (ICH) sequence." + @leaders + count -type integer + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc insert_spaces {count args} { + #see PUNKARGS id ::punk::console::ansi::insert_spaces + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}@ } - proc delete_characters {count} { - puts -nonewline \x1b\[${count}P + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::delete_characters + @cmd -name punk::console::ansi::delete_characters -summary "Emit delete-characters (DCH) sequence." + @leaders + count -type integer + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc delete_characters {count args} { + #see PUNKARGS id ::punk::console::ansi::delete_characters + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}P } - proc erase_characters {count} { - puts -nonewline \x1b\[${count}X + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::erase_characters + @cmd -name punk::console::ansi::erase_characters -summary "Emit erase-characters (ECH) sequence." + @leaders + count -type integer + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc erase_characters {count args} { + #see PUNKARGS id ::punk::console::ansi::erase_characters + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}X } - proc insert_lines {count} { - puts -nonewline \x1b\[${count}L + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::insert_lines + @cmd -name punk::console::ansi::insert_lines -summary "Emit insert-lines (IL) sequence." + @leaders + count -type integer + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc insert_lines {count args} { + #see PUNKARGS id ::punk::console::ansi::insert_lines + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}L } - proc delete_lines {count} { - puts -nonewline \x1b\[${count}M + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::delete_lines + @cmd -name punk::console::ansi::delete_lines -summary "Emit delete-lines (DL) sequence." + @leaders + count -type integer + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc delete_lines {count args} { + #see PUNKARGS id ::punk::console::ansi::delete_lines + puts -nonewline [::punk::console::internal::opt_console_out $args] \x1b\[${count}M } - proc titleset {windowtitle} { - puts -nonewline stdout [punk::ansi::titleset $windowtitle] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::titleset + @cmd -name punk::console::ansi::titleset -summary "Emit window-title (OSC) sequence." + @leaders + windowtitle -type string + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc titleset {windowtitle args} { + #see PUNKARGS id ::punk::console::ansi::titleset + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::titleset $windowtitle] } - proc test_decaln {} { - puts -nonewline stdout [punk::ansi::test_decaln] + lappend PUNKARGS [list { + @id -id ::punk::console::ansi::test_decaln + @cmd -name punk::console::ansi::test_decaln -summary "Emit DECALN screen-alignment test pattern sequence." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc test_decaln {args} { + #see PUNKARGS id ::punk::console::ansi::test_decaln + puts -nonewline [::punk::console::internal::opt_console_out $args] [punk::ansi::test_decaln] } } if {[catch {namespace import ::punk::console::ansi::*} errm]} { @@ -3797,12 +4523,24 @@ namespace eval punk::console { } catch {rename titleset ""} #namespace import ansi::titleset - proc titleset {windowtitle} { + lappend PUNKARGS [list { + @id -id ::punk::console::titleset + @cmd -name punk::console::titleset -summary "Set the terminal window title (ANSI or local mechanism)." + @leaders + windowtitle -type string + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc titleset {windowtitle args} { + #see PUNKARGS id ::punk::console::titleset variable ansi_wanted if { $ansi_wanted <= 0} { + #local mechanism acts on the process console regardless of any -console argument + internal::opt_console_out $args ;#validate the tail even though the channel is unused punk::console::local::titleset $windowtitle } else { - ansi::titleset $windowtitle + ansi::titleset $windowtitle {*}$args } } #no known pure-ansi solution @@ -3810,24 +4548,21 @@ namespace eval punk::console { return [local::titleget] } - foreach ansicmd [list ::punk::console::ansi::move] { - set ctail [namespace tail $ansicmd] - set arglist [info args $ansicmd] - set argcall "" - if {[llength $arglist]} { - foreach a [lrange $arglist 0 end-1] { - append argcall "\$$a " - } - if {[lindex $arglist end] eq "args"} { - append argcall {{*}$args} - } else { - append argcall "\$[lindex $arglist end]" - } - } - catch {rename $ctail ""} - proc $ctail $arglist [string map [list %ansicmd% $ansicmd %argcall% $argcall] { - puts -nonewline [%ansicmd% %argcall%] - }] + #emitting counterpart of the string-returning ansi::move (the imported command is renamed away) + lappend PUNKARGS [list { + @id -id ::punk::console::move + @cmd -name punk::console::move -summary "Emit ANSI or vt52 sequence moving the cursor to row,col." + @leaders + row -type integer -help "row number - starting at 1" + col -type integer -help "column number - starting at 1" + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + catch {rename move ""} + proc move {row col args} { + #see PUNKARGS id ::punk::console::move + puts -nonewline [internal::opt_console_out $args] [ansi::move $row $col {*}$args] } @@ -4158,46 +4893,72 @@ namespace eval punk::console { } namespace eval punk::console::check { + variable PUNKARGS + #the has_bug_* results are per-console facts (see punk::console::console_fact_get); these + #namespace variables are the storage for the process-default console {stdin stdout} variable has_bug_legacysymbolwidth -1 ;#undetermined - proc has_bug_legacysymbolwidth {} { + lappend PUNKARGS [list { + @id -id ::punk::console::check::has_bug_legacysymbolwidth + @cmd -name punk::console::check::has_bug_legacysymbolwidth -summary\ + "Test (cached per console) whether the terminal miscounts legacy symbol widths." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc has_bug_legacysymbolwidth {args} { + #see PUNKARGS id ::punk::console::check::has_bug_legacysymbolwidth #some terminals (on windows as at 2024) miscount width of these single-width blocks internally #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) #This was fixed in windows-terminal based systems (2021) but persists in others. #https://github.com/microsoft/terminal/issues/11694 - variable has_bug_legacysymbolwidth - if {!$has_bug_legacysymbolwidth} { + set inout [::punk::console::internal::opt_console_channels $args] + set cached [punk::console::console_fact_get $inout has_bug_legacysymbolwidth] + if {!$cached} { return 0 } - if {$has_bug_legacysymbolwidth == -1} { + if {$cached == -1} { #run the test using ansi movement #we only test a specific character from the known problematic set - set w [punk::console::test_char_width \U1fb7d] + set w [punk::console::test_char_width \U1fb7d -console $inout] if {$w == 1} { - set has_bug_legacysymbolwidth 0 + set verdict 0 } else { #can return 2 on legacy window consoles for example - set has_bug_legacysymbolwidth 1 + set verdict 1 } - return $has_bug_legacysymbolwidth + punk::console::console_fact_set $inout has_bug_legacysymbolwidth $verdict + return $verdict } return 1 } variable has_bug_zwsp -1 ;#undetermined - proc has_bug_zwsp {} { + lappend PUNKARGS [list { + @id -id ::punk::console::check::has_bug_zwsp + @cmd -name punk::console::check::has_bug_zwsp -summary\ + "Test (cached per console) whether the terminal mishandles inline zero-width-space width." + @opts + ${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_emit_opts -console]} + @values -min 0 -max 0 + }] + proc has_bug_zwsp {args} { + #see PUNKARGS id ::punk::console::check::has_bug_zwsp #Note that some terminals behave differently regarding a leading zwsp vs one that is inline between other chars. #we are only testing the inline behaviour here. - variable has_bug_zwsp - if {!$has_bug_zwsp} { + set inout [::punk::console::internal::opt_console_channels $args] + set cached [punk::console::console_fact_get $inout has_bug_zwsp] + if {!$cached} { return 0 } - if {$has_bug_zwsp == -1} { - set w [punk::console::test_char_width X\u200bY] - } - if {$w == 2} { - return 0 - } else { - #may return 3 - but this gives no indication of whether terminal hides it or not. - return 1 + if {$cached == -1} { + set w [punk::console::test_char_width X\u200bY -console $inout] + if {$w == 2} { + set verdict 0 + } else { + #may return 3 - but this gives no indication of whether terminal hides it or not. + set verdict 1 + } + punk::console::console_fact_set $inout has_bug_zwsp $verdict + return $verdict } return 1 } @@ -4782,7 +5543,7 @@ namespace eval punk::console { namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::console ::punk::console::argdoc ::punk::console::internal ::punk::console::local ::punk::console::ansi + lappend ::punk::args::register::NAMESPACES ::punk::console ::punk::console::argdoc ::punk::console::internal ::punk::console::local ::punk::console::ansi ::punk::console::check } diff --git a/src/modules/punk/console-buildversion.txt b/src/modules/punk/console-buildversion.txt index 982309b3..cfda16fd 100644 --- a/src/modules/punk/console-buildversion.txt +++ b/src/modules/punk/console-buildversion.txt @@ -1,6 +1,17 @@ -0.1.8 +0.3.0 #First line must be a semantic version number #all other lines are ignored. +#0.3.0 - per-console facts (interim store for multi-console goals G-001/G-002): is_vt52, tabwidth, cell_size, last_da1_result, grapheme_cluster_support and check::has_bug_* are keyed by canonical {in out} pair via new console_fact_get/console_fact_set; the default console {stdin stdout} stores facts in the legacy namespace variables so external readers (punk::repl, textblock, overtype, punk::ansi, punk::ns) are unaffected +#0.3.0 - vt52 state, size_via_query_mechanisms, get_cursor_pos and all vt52-aware emit wrappers (incl. string-returning ansi::move) consult the spec'd console's is_vt52 fact instead of the process-global flag +#0.3.0 - grapheme_cluster_support and check::has_bug_legacysymbolwidth/has_bug_zwsp accept a trailing '-console '; the TERM_PROGRAM shortcut in grapheme_cluster_support only applies to the default console (env hints describe the process's own terminal) +#0.3.0 - check::has_bug_zwsp: cached-true path no longer errors on an undefined variable, and a query verdict is now actually cached (previously checked but never populated) +#0.3.0 - ansi_wanted/colour_disabled (gate string generation), ansi_available and raw-mode state deliberately remain process-global - documented at the console_facts store +#0.3.0 - PUNKARGS for the emit-side functions restructured per the Argument Order rule (leading positionals documented as @leaders before @opts so synopses match call-site order); internal opt_console_* helpers gained documentation-only definitions +#0.2.0 - emit-side console targeting: punk::console::ansi::* emit functions, mouse/paste toggles, start_application_mode, vt52, set_tabstop_width, titleset, top-level move, test_char_width and test_string_cursor accept an optional trailing '-console ' (channel pair, anchored opunk::console instance name, or ::opunk::Console object value) parsed via new internal::opt_console_out/opt_console_channels helpers (+_var variants for triple-tail procs); documentation via shared PUNKARGS fragment ::punk::console::argdoc::console_emit_opts +#0.2.0 - fallback chains keep the console spec: get_tabstop_apparent_width passes its spec to test_char_width; set_tabstop_width passes its spec to get_size (both previously queried the default console) +#0.2.0 - move_call_return now actually emits its cursor moves (previously discarded the string-returning ansi::move results - moves were no-ops) +#0.2.0 - get_size_using_cursorrestore uses string-returning punk::ansi::cursor_on (previously called the emitting punk::console::cursor_on which wrote to stdout mid-sequence) +#0.2.0 - top-level move wrapper is an explicit proc with -console support (replaces the generator loop) #0.1.8 - bug fixes: disableAnsi was defined as a duplicate enableAnsi in the windows no-twapi branch; get_size_using_cursormove flushed stdout instead of the supplied output channel; removed unreachable code after error in get_size_using_chanconfigure; cell_size query path now passes its -console spec to get_size and error message names punk::console (was punk::sixel); test_string_cursor undefined $test_string reference and swapped rowoffset/columnoffset return labels; ansi::move_emit vt52 branch called nonexistent v52move_emit (now vt52move_emit); move_emit_return no longer re-expands args inside its per-triple loop (duplicated emissions); dec_has_mode unknown-mode error named dec_get_mode #0.1.7 - get_size dispatches object-governed calls through the virtual ::opunk::Console::size method (subclass overrides honoured); ANSI/tput mechanisms factored into size_via_query_mechanisms and registered as the class size_query_provider via ensure_object_integration; legacy channel path returns 80x24 instead of erroring when undetermined #0.1.6 - get_ansi_response_payload performs first-use active settling (with recursion latch) so all query paths pay one probe instead of a timeout per call on unsettled ambiguous consoles; default_console unifies the opunk::console probe-byte store with input_chunks_waiting diff --git a/src/tests/modules/punk/console/testsuites/console/consolefacts.test b/src/tests/modules/punk/console/testsuites/console/consolefacts.test new file mode 100644 index 00000000..693bde09 --- /dev/null +++ b/src/tests/modules/punk/console/testsuites/console/consolefacts.test @@ -0,0 +1,272 @@ +package require tcltest +tcltest::configure {*}$::argv + +#min-version bounds document that these tests target the dev modules' API and protect against +#stable copies shadowing them if this file is sourced outside runtests.tcl (whose testinterp +#runs 'package prefer latest'). +package require punk::console 999999.0a1.0- +package require opunk::console 999999.0a1.0- + +#Tests for per-console facts (console_fact_get/console_fact_set): terminal-property facts +#(is_vt52, tabwidth, cell_size, last_da1_result, grapheme_cluster_support, has_bug_*) are keyed +#by canonical {in out} channel pair; the process-default console {stdin stdout} stores its facts +#in the legacy namespace variables so external readers (punk::repl, textblock, overtype, ...) +#keep working. + +namespace eval ::testspace { + namespace import ::tcltest::* + + variable common { + set result "" + } + variable pipe_setup { + set result "" + lassign [chan pipe] rd wr + chan configure $wr -buffering none -translation lf + chan configure $rd -blocking 0 -translation lf + } + variable pipe_cleanup { + catch {chan close $wr} + catch {chan close $rd} + array unset ::punk::console::input_chunks_waiting $rd + } + #see emitconsole.test - windows [chan pipe] reads race the background reader thread + proc read_emitted {chan {timeout_ms 2000}} { + set data "" + set deadline [expr {[clock milliseconds] + $timeout_ms}] + while {[clock milliseconds] < $deadline} { + append data [read $chan] + if {$data ne ""} { + after 20 + append data [read $chan] + return $data + } + after 5 + } + return $data + } + + test facts_default_legacy_sync {default console facts read/write the legacy namespace variables}\ + -setup [string cat $common { + set saved_tabwidth $::punk::console::tabwidth + }]\ + -body { + lappend result [expr {[punk::console::console_fact_get {stdin stdout} tabwidth] eq $::punk::console::tabwidth}] + punk::console::console_fact_set {stdin stdout} tabwidth 11 + lappend result $::punk::console::tabwidth + lappend result [punk::console::console_fact_get {stdin stdout} is_vt52] + }\ + -cleanup { + set ::punk::console::tabwidth $saved_tabwidth + }\ + -result [list\ + 1\ + 11\ + 0\ + ] + + test facts_nondefault_isolated {non-default console facts don't touch legacy variables; unknown consoles get defaults}\ + -setup [string cat $common { + set saved_tabwidth $::punk::console::tabwidth + }]\ + -body { + punk::console::console_fact_set {chanx chany} tabwidth 4 + lappend result [punk::console::console_fact_get {chanx chany} tabwidth] + lappend result [expr {$::punk::console::tabwidth eq $saved_tabwidth}] + #unseen console pair falls back to the fact default + lappend result [punk::console::console_fact_get {chanp chanq} tabwidth] + lappend result [punk::console::console_fact_get {chanp chanq} has_bug_zwsp] + }\ + -cleanup { + set ::punk::console::tabwidth $saved_tabwidth + set ::punk::console::console_facts [dict create] + }\ + -result [list\ + 4\ + 1\ + 8\ + -1\ + ] + + test facts_spec_forms_resolve {instance-name and object-value specs resolve to the same fact entry as the channel pair}\ + -setup $pipe_setup -body { + opunk::console::create facttest1 $rd $wr + punk::console::console_fact_set facttest1 tabwidth 5 + lappend result [punk::console::console_fact_get [list $rd $wr] tabwidth] + set obj [opunk::console::instance facttest1] + lappend result [punk::console::console_fact_get $obj tabwidth] + }\ + -cleanup [string cat { + catch {opunk::console::forget facttest1} + set ::punk::console::console_facts [dict create] + } $pipe_cleanup]\ + -result [list\ + 5\ + 5\ + ] + + test facts_vt52_per_console {vt52 mode set on a spec'd console doesn't affect the default console; emit wrappers honour it}\ + -setup [string cat $pipe_setup { + set saved_colour_disabled $::punk::console::colour_disabled + }]\ + -body { + set spec [list $rd $wr] + #query defaults to 0 + lappend result [punk::console::vt52 -console $spec] + #turn vt52 on for the pipe console - emits DECANM unset (DECRST 2) there + lappend result [punk::console::vt52 on -console $spec] + lappend result [expr {[read_emitted $rd] eq "\x1b\[?2l"}] + #default console's flag untouched + lappend result $::punk::console::is_vt52 + lappend result [punk::console::vt52] + #vt52-aware emit wrapper uses the per-console fact + punk::console::ansi::cursor_off -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::vt52cursor_off]}] + #string-returning ansi::move selects vt52 encoding for this console only + lappend result [expr {[punk::console::ansi::move 3 4 -console $spec] eq [punk::ansi::vt52move 3 4]}] + lappend result [expr {[punk::console::ansi::move 3 4] eq [punk::ansi::move 3 4]}] + #turn vt52 back off for the pipe console - emits ESC < + lappend result [punk::console::vt52 off -console $spec] + lappend result [expr {[read_emitted $rd] eq "\x1b<"}] + }\ + -cleanup [string cat { + #vt52 on/off toggles process-global colour state - restore + set ::punk::console::colour_disabled $saved_colour_disabled + set ::punk::console::console_facts [dict create] + } $pipe_cleanup]\ + -result [list\ + 0\ + 1\ + 1\ + 0\ + 0\ + 1\ + 1\ + 1\ + 0\ + 1\ + ] + + test facts_tabwidth_per_console {set_tabstop_width records tabwidth for the spec'd console only}\ + -setup [string cat $pipe_setup { + set saved_tabwidth $::punk::console::tabwidth + set saved_hints [dict create] + foreach ev {TERM_PROGRAM MSYSTEM} { + if {[info exists ::env($ev)]} { + dict set saved_hints $ev [set ::env($ev)] + unset ::env($ev) + } + } + }]\ + -body { + punk::console::set_tabstop_width 4 -console [list $rd $wr] + lappend result [expr {[read_emitted $rd] ne ""}] + lappend result [punk::console::console_fact_get [list $rd $wr] tabwidth] + lappend result [expr {$::punk::console::tabwidth eq $saved_tabwidth}] + }\ + -cleanup [string cat { + dict for {ev val} $saved_hints { + set ::env($ev) $val + } + set ::punk::console::tabwidth $saved_tabwidth + set ::punk::console::console_facts [dict create] + } $pipe_cleanup]\ + -result [list\ + 1\ + 4\ + 1\ + ] + + test facts_cell_size_per_console {cell_size set/query is per-console; default legacy variable untouched}\ + -setup $pipe_setup -body { + set spec [list $rd $wr] + punk::console::cell_size -console $spec 12x24 + lappend result [punk::console::cell_size -console $spec] + lappend result [expr {$::punk::console::cell_size eq ""}] + }\ + -cleanup [string cat { + set ::punk::console::console_facts [dict create] + } $pipe_cleanup]\ + -result [list\ + 12x24\ + 1\ + ] + + test facts_da1_per_console {get_device_attributes records last_da1_result for the queried console only}\ + -setup [string cat $common { + lassign [chan pipe] rdi wri + lassign [chan pipe] rdo wro + chan configure $wri -buffering none -translation lf + chan configure $wro -buffering none -translation lf + chan configure $rdo -blocking 0 -translation lf + set saved_da1 $::punk::console::last_da1_result + }]\ + -body { + after 40 [list apply [list {wchan} { + puts -nonewline $wchan "\x1b\[?1;2c" + flush $wchan + }] $wri] + set payload [punk::console::get_device_attributes [list $rdi $wro]] + lappend result $payload + lappend result [punk::console::console_fact_get [list $rdi $wro] last_da1_result] + lappend result [expr {$::punk::console::last_da1_result eq $saved_da1}] + }\ + -cleanup { + foreach c [list $wri $rdi $wro $rdo] { + catch {chan close $c} + } + array unset ::punk::console::input_chunks_waiting $rdi + set ::punk::console::console_facts [dict create] + }\ + -result [list\ + {1;2}\ + {1;2}\ + 1\ + ] + + test facts_has_bug_cached_paths {check::has_bug_* honour per-console recorded verdicts without re-testing (and without the old undefined-var error)}\ + -setup [string cat $common { + set saved_zwsp $::punk::console::check::has_bug_zwsp + }]\ + -body { + set spec {chanx chany} + #recorded true verdict - previously the cached-true path errored on an undefined variable + punk::console::console_fact_set $spec has_bug_zwsp 1 + lappend result [punk::console::check::has_bug_zwsp -console $spec] + punk::console::console_fact_set $spec has_bug_zwsp 0 + lappend result [punk::console::check::has_bug_zwsp -console $spec] + punk::console::console_fact_set $spec has_bug_legacysymbolwidth 1 + lappend result [punk::console::check::has_bug_legacysymbolwidth -console $spec] + #default console legacy variable is the storage for no-arg calls + set ::punk::console::check::has_bug_zwsp 0 + lappend result [punk::console::check::has_bug_zwsp] + }\ + -cleanup { + set ::punk::console::check::has_bug_zwsp $saved_zwsp + set ::punk::console::console_facts [dict create] + }\ + -result [list\ + 1\ + 0\ + 1\ + 0\ + ] + + test facts_grapheme_recorded_per_console {grapheme_cluster_support returns a recorded per-console fact without querying}\ + -setup $pipe_setup -body { + set spec [list $rd $wr] + punk::console::console_fact_set $spec grapheme_cluster_support {available 1 mode set} + lappend result [punk::console::grapheme_cluster_support -console $spec] + #no query emission may have occurred + lappend result [read $rd] + }\ + -cleanup [string cat { + set ::punk::console::console_facts [dict create] + } $pipe_cleanup]\ + -result [list\ + {available 1 mode set}\ + {}\ + ] + +} +tcltest::cleanupTests ;#needed to produce test summary. diff --git a/src/tests/modules/punk/console/testsuites/console/emitconsole.test b/src/tests/modules/punk/console/testsuites/console/emitconsole.test new file mode 100644 index 00000000..370d7e80 --- /dev/null +++ b/src/tests/modules/punk/console/testsuites/console/emitconsole.test @@ -0,0 +1,321 @@ +package require tcltest +tcltest::configure {*}$::argv + +#min-version bounds document that these tests target the dev modules' API and protect against +#stable copies shadowing them if this file is sourced outside runtests.tcl (whose testinterp +#runs 'package prefer latest'). +package require punk::console 999999.0a1.0- +package require opunk::console 999999.0a1.0- + +#Tests for the emit-side '-console' args-tail convention: emit functions (punk::console::ansi::*, +#mouse/paste toggles, vt52, set_tabstop_width, titleset, move, test probes) accept an optional +#trailing '-console ' pair parsed by punk::console::internal::opt_console_out and +#friends, writing to the resolved console's output channel instead of hardcoded stdout. + +namespace eval ::testspace { + namespace import ::tcltest::* + + variable common { + set result "" + } + #out-capture pipe pair: emit procs write to $wr, tests read from $rd. + #lf translation both ends so byte-compares survive windows crlf channel defaults. + variable pipe_setup { + set result "" + lassign [chan pipe] rd wr + chan configure $wr -buffering none -translation lf + chan configure $rd -blocking 0 -translation lf + } + variable pipe_cleanup { + catch {chan close $wr} + catch {chan close $rd} + array unset ::punk::console::input_chunks_waiting $rd + } + + #On windows, bytes written to one end of a [chan pipe] pair are moved to the read side by a + #background reader thread - an immediate non-blocking read can race it and see nothing. + #Poll with a deadline, then drain briefly so multi-write emissions arrive whole. + proc read_emitted {chan {timeout_ms 2000}} { + set data "" + set deadline [expr {[clock milliseconds] + $timeout_ms}] + while {[clock milliseconds] < $deadline} { + append data [read $chan] + if {$data ne ""} { + after 20 + append data [read $chan] + return $data + } + after 5 + } + return $data + } + + test emit_helper_forms {opt_console_out/opt_console_channels resolve tails; junk tails error}\ + -setup $common -body { + lappend result [punk::console::internal::opt_console_out {}] + lappend result [punk::console::internal::opt_console_out [list -console {chana chanb}]] + lappend result [punk::console::internal::opt_console_channels {}] + lappend result [punk::console::internal::opt_console_channels [list -console {chana chanb}]] + lappend result [catch {punk::console::internal::opt_console_out {junk}}] + lappend result [catch {punk::console::internal::opt_console_out {-console {a b} extra}}] + #var forms leave non-console tails alone + set tail [list 1 2 X] + lappend result [punk::console::internal::opt_console_out_var tail] + lappend result $tail + set tail [list 1 2 X -console {chana chanb}] + lappend result [punk::console::internal::opt_console_out_var tail] + lappend result $tail + }\ + -result [list\ + stdout\ + chanb\ + {stdin stdout}\ + {chana chanb}\ + 1\ + 1\ + stdout\ + {1 2 X}\ + chanb\ + {1 2 X}\ + ] + + test emit_clear_console_pair {ansi::clear writes to the spec'd console output channel}\ + -setup $pipe_setup -body { + punk::console::ansi::clear -console [list $rd $wr] + lappend result [expr {[read_emitted $rd] eq [punk::ansi::clear]}] + #imported alias in punk::console namespace takes the same tail + punk::console::clear -console [list $rd $wr] + lappend result [expr {[read_emitted $rd] eq [punk::ansi::clear]}] + }\ + -cleanup $pipe_cleanup\ + -result [list\ + 1\ + 1\ + ] + + test emit_sugar_bytes {one-line emit wrappers write expected sequences to the spec'd console}\ + -setup $pipe_setup -body { + set spec [list $rd $wr] + punk::console::ansi::move_forward 3 -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::move_forward 3]}] + punk::console::ansi::move_row 7 -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::move_row 7]}] + punk::console::ansi::insert_spaces 5 -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[5@"}] + punk::console::ansi::delete_lines 2 -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[2M"}] + punk::console::ansi::cursor_save_dec -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b7"}] + punk::console::ansi::cursor_restore_dec -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b8"}] + punk::console::ansi::scroll_up 4 -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::scroll_up 4]}] + punk::console::ansi::enable_alt_screen -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::enable_alt_screen]}] + punk::console::ansi::test_decaln -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::test_decaln]}] + }\ + -cleanup $pipe_cleanup\ + -result [list\ + 1\ + 1\ + 1\ + 1\ + 1\ + 1\ + 1\ + 1\ + 1\ + ] + + test emit_vt52_branch {vt52-aware wrappers emit vt52 sequences to the spec'd console when its per-console is_vt52 fact is set}\ + -setup $pipe_setup\ + -body { + set spec [list $rd $wr] + punk::console::console_fact_set $spec is_vt52 1 + punk::console::ansi::cursor_off -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::vt52cursor_off]}] + punk::console::ansi::move_up 2 -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::vt52move_up 2]}] + punk::console::console_fact_set $spec is_vt52 0 + punk::console::ansi::cursor_off -console $spec + lappend result [expr {[read_emitted $rd] eq [punk::ansi::cursor_off]}] + }\ + -cleanup [string cat { + set ::punk::console::console_facts [dict create] + } $pipe_cleanup]\ + -result [list\ + 1\ + 1\ + 1\ + ] + + test emit_move_toplevel {top-level punk::console::move emits the ansi::move sequence to the spec'd console}\ + -setup $pipe_setup -body { + punk::console::move 5 10 -console [list $rd $wr] + lappend result [expr {[read_emitted $rd] eq [punk::console::ansi::move 5 10]}] + }\ + -cleanup $pipe_cleanup\ + -result [list\ + 1\ + ] + + test emit_mouse_paste_toggles {mouse/paste toggles write their sequences to the spec'd console}\ + -setup $pipe_setup -body { + set spec [list $rd $wr] + punk::console::enable_mouse -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[?1000h\x1b\[?1003h\x1b\[?1015h\x1b\[?1006h"}] + punk::console::disable_mouse -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[?1000l\x1b\[?1003l\x1b\[?1015l\x1b\[?1006l"}] + punk::console::enable_mouse_sgr -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[?1000h\x1b\[?1003h\x1b\[?1016h"}] + punk::console::enable_bracketed_paste -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[?2004h"}] + punk::console::disable_bracketed_paste -console $spec + lappend result [expr {[read_emitted $rd] eq "\x1b\[?2004l"}] + }\ + -cleanup $pipe_cleanup\ + -result [list\ + 1\ + 1\ + 1\ + 1\ + 1\ + ] + + test emit_move_emit_triples {move_emit accepts extra row col data triples ahead of the -console tail}\ + -setup $pipe_setup -body { + punk::console::ansi::move_emit 1 1 A 2 2 B -console [list $rd $wr] + lappend result [expr {[read_emitted $rd] eq [punk::ansi::move_emit 1 1 A 2 2 B]}] + #no duplication of triples (regression check for the pre-0.1.8 args re-expansion class of bug) + punk::console::ansi::cursorsave_move_emit_return 3 4 C 5 6 D -console [list $rd $wr] + set expected [punk::ansi::cursor_save_dec][punk::ansi::move_emit 3 4 C][punk::ansi::move_emit 5 6 D][punk::ansi::cursor_restore_dec] + lappend result [expr {[read_emitted $rd] eq $expected}] + }\ + -cleanup $pipe_cleanup\ + -result [list\ + 1\ + 1\ + ] + + test emit_spec_instance_name {anchored opunk::console instance name works as an emit -console spec}\ + -setup $pipe_setup -body { + opunk::console::create emittest1 $rd $wr + punk::console::ansi::clear_all -console emittest1 + lappend result [expr {[read_emitted $rd] eq [punk::ansi::clear_all]}] + }\ + -cleanup [string cat { + catch {opunk::console::forget emittest1} + } $pipe_cleanup]\ + -result [list\ + 1\ + ] + + test emit_spec_object_value {::opunk::Console object value works as an emit -console spec}\ + -setup $pipe_setup -body { + set obj [::opunk::Console::new $rd $wr] + punk::console::ansi::clear_scrollback -console $obj + lappend result [expr {[read_emitted $rd] eq [punk::ansi::clear_scrollback]}] + }\ + -cleanup $pipe_cleanup\ + -result [list\ + 1\ + ] + + test emit_titleset {titleset routes through the ansi mechanism to the spec'd console}\ + -setup [string cat $pipe_setup { + set saved_ansi_wanted $::punk::console::ansi_wanted + set ::punk::console::ansi_wanted 2 + }]\ + -body { + punk::console::titleset "emit test title" -console [list $rd $wr] + lappend result [expr {[read_emitted $rd] eq [punk::ansi::titleset "emit test title"]}] + }\ + -cleanup [string cat { + set ::punk::console::ansi_wanted $saved_ansi_wanted + } $pipe_cleanup]\ + -result [list\ + 1\ + ] + + test emit_move_emit_return_query {move_emit_return queries cursor position on the spec'd console and emits there}\ + -setup [string cat $common { + #full in/out pipe pairs: rdi/wri feeds the console 'input', wro/rdo captures 'output' + lassign [chan pipe] rdi wri + lassign [chan pipe] rdo wro + chan configure $wri -buffering none -translation lf + chan configure $wro -buffering none -translation lf + chan configure $rdo -blocking 0 -translation lf + }]\ + -body { + #deliver a cursor position report after the query is emitted (as a real terminal would) + after 40 [list apply [list {wchan} { + puts -nonewline $wchan "\x1b\[10;5R" + flush $wchan + }] $wri] + punk::console::ansi::move_emit_return 2 3 X -console [list $rdi $wro] + set data [read_emitted $rdo] + #output: the CSI 6n cursor query, then the emit commands with return-move to 9;5 + #(orig_row decremented by 1 in the not-raw path) + set expected "\x1b\[6n[punk::ansi::move_emit 2 3 X][punk::ansi::move 9 5]" + lappend result [expr {$data eq $expected}] + }\ + -cleanup { + foreach c [list $wri $rdi $wro $rdo] { + catch {chan close $c} + } + array unset ::punk::console::input_chunks_waiting $rdi + }\ + -result [list\ + 1\ + ] + + #get_size consults env(TERM_PROGRAM)/env(MSYSTEM) as mintty-without-winpty hints - clear them + #so the pipe pair is treated as a non-terminal and no ANSI size queries land on the out pipe. + variable hints_save { + set saved_hints [dict create] + foreach ev {TERM_PROGRAM MSYSTEM} { + if {[info exists ::env($ev)]} { + dict set saved_hints $ev [set ::env($ev)] + unset ::env($ev) + } + } + } + variable hints_restore { + dict for {ev val} $saved_hints { + set ::env($ev) $val + } + } + + test emit_set_tabstop_width {set_tabstop_width emits tabstop sequences to the spec'd console}\ + -setup [string cat $pipe_setup $hints_save]\ + -body { + #get_size on a plain pipe pair falls back through tput to the 80x24 default - either + #way a clear_all_tabstops followed by at least one set_tabstop must land on the pipe + punk::console::set_tabstop_width 8 -console [list $rd $wr] + set data [read_emitted $rd] + lappend result [expr {[string first [punk::ansi::clear_all_tabstops] $data] == 0}] + lappend result [expr {[string first [punk::ansi::set_tabstop] $data] > 0}] + }\ + -cleanup [string cat $hints_restore $pipe_cleanup]\ + -result [list\ + 1\ + 1\ + ] + + test emit_error_tails {junk trailing arguments are rejected by the strict emit tails}\ + -setup $common -body { + lappend result [catch {punk::console::ansi::clear junk}] + lappend result [catch {punk::console::ansi::move_forward 3 junk}] + lappend result [catch {punk::console::enable_mouse -console}] + lappend result [catch {punk::console::vt52 notabool}] + }\ + -result [list\ + 1\ + 1\ + 1\ + 1\ + ] + +} +tcltest::cleanupTests ;#needed to produce test summary.