Browse Source

punk::console 0.5.0: -console migration complete - remaining query procs converted to hybrid pattern

Migration plan phase 4 (final phase):
- get_cursor_pos, get_cursor_pos_list, get_checksum_rect,
  get_device_status, get_device_attributes,
  get_device_attributes_tertiary, get_terminal_id, get_tabstops,
  get_tabstop_apparent_width, get_dimensions, get_xterm_size,
  get_xterm_pixels, dec_get_mode_line_wrap and ansi_get_mode_LNM
  accept -console <consolespec> (any spec form) or the legacy
  trailing positional, parsed by new internal::hybrid_console_spec;
  each carries a PUNKARGS definition (@leaders per the Argument
  Order rule)
- get_size refactored onto internal::hybrid_console_spec
  (behaviour unchanged)
- documentation-only PUNKARGS for input_at_eof,
  is_input_console_or_tty, size_via_query_mechanisms,
  console_size_provider and the get_size_using_* mechanism helpers
  (signatures unchanged - internal size mechanisms remain
  canonical-pair only, per the updated AGENTS.md contract)

AGENTS.md migration bullet rewritten from 'incrementally migrating'
to the completed-state contract. New queryprocs.test (6 tests,
fed-response coverage for every converted proc across spec forms);
full console suite 58/58 on Tcl 9.0.3.

Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
Julian Noble 1 week ago
parent
commit
e2e142faa2
  1. 2
      src/modules/punk/AGENTS.md
  2. 367
      src/modules/punk/console-999999.0a1.0.tm
  3. 5
      src/modules/punk/console-buildversion.txt
  4. 154
      src/tests/modules/punk/console/testsuites/console/queryprocs.test

2
src/modules/punk/AGENTS.md

@ -28,7 +28,7 @@ Source of truth for all modules under the `punk::*` namespace. This is the prima
## Work Guidance
- New modules under `punk::*` should be created as `<subpath>/<modulename>-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. PUNKARGS definitions include the `-console` option via the shared fragments `::punk::console::argdoc::console_opts` (query/set functions) or `::punk::console::argdoc::console_emit_opts` (emit functions) rather than duplicating the option text; never re-add a `-minsize 2` constraint to `-console` (it rejects instance-name specs).
- punk::console uses the documented `-console` convention throughout: 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`). Query functions use the hybrid pattern (legacy trailing positional spec also accepted, parsed by `punk::console::internal::hybrid_console_spec`) - new query procs must follow it, with tests (see `src/tests/modules/punk/console/testsuites/console/queryprocs.test`). PUNKARGS definitions include the `-console` option via the shared fragments `::punk::console::argdoc::console_opts` (query/set functions) or `::punk::console::argdoc::console_emit_opts` (emit functions) rather than duplicating the option text; never re-add a `-minsize 2` constraint to `-console` (it rejects instance-name specs). The internal `get_size_using_*` size mechanisms deliberately remain canonical-pair positional (always fed by `get_size`).
- 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 <consolespec>` 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.

367
src/modules/punk/console-999999.0a1.0.tm

@ -402,6 +402,38 @@ namespace eval punk::console {
}
return $channels
}
punk::args::define {
@id -id ::punk::console::internal::hybrid_console_spec
@cmd -name punk::console::internal::hybrid_console_spec -summary\
"Resolve a get_size-style hybrid args-tail (?consolespec? or -console <consolespec>) to the console specification."\
-help\
"Used by the query functions that accept the legacy trailing positional
console specification as well as the -console option form. Returns the
spec unresolved (callers pass it downstream or resolve as needed);
{stdin stdout} for an empty tail."
@leaders
argstail -type list
procname -type string -help\
"caller name for error messages"
@values -min 0 -max 0
}
proc hybrid_console_spec {argstail procname} {
#see PUNKARGS id ::punk::console::internal::hybrid_console_spec
switch -exact -- [llength $argstail] {
0 {
return {stdin stdout}
}
1 {
return [lindex $argstail 0] ;#legacy positional - accepts any console spec form
}
2 {
if {[lindex $argstail 0] eq "-console"} {
return [lindex $argstail 1]
}
}
}
error "$procname: expected ?consolespec? or -console <consolespec> - got '$argstail'"
}
proc abort_if_loop {{failmsg ""}} {
#obsolete
@ -1241,10 +1273,24 @@ namespace eval punk::console {
# -- --- --- --- --- --- ---
#get_ansi_response functions
#review - can these functions sensibly be used on channels not attached to the local console?
#ie can we default to {stdin stdout} but allow other channel pairs?
#These accept the get_size-style hybrid tail: an optional legacy positional console
#specification, or -console <consolespec> (see internal::hybrid_console_spec).
# -- --- --- --- --- --- ---
proc get_cursor_pos {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_cursor_pos
@cmd -name punk::console::get_cursor_pos -summary\
"Query cursor position (CSI 6n) - returns the raw 'row;col' payload."\
-help\
"NOTE: argument parsing is manual for performance - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_cursor_pos {args} {
#see PUNKARGS id ::punk::console::get_cursor_pos
set inoutchannels [internal::hybrid_console_spec $args get_cursor_pos]
if {[console_fact_get $inoutchannels is_vt52]} {
error "vt52 can't perform get_cursor_pos"
}
@ -1265,7 +1311,28 @@ namespace eval punk::console {
proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_checksum_rect
@cmd -name punk::console::get_checksum_rect -summary\
"Query rectangular area checksum (DECRQCRA)."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@leaders
id -type integer -help "request id (echoed in the response)"
page -type integer
t -type integer -help "top row"
l -type integer -help "left column"
b -type integer -help "bottom row"
r -type integer -help "right column"
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_checksum_rect {id page t l b r args} {
#see PUNKARGS id ::punk::console::get_checksum_rect
set inoutchannels [internal::hybrid_console_spec $args get_checksum_rect]
#e.g \x1b\[P44!~E797\x1b\\
#re e.g {(.*)(\x1b\[P44!~([[:alnum:]])\x1b\[\\)$}
set capturingregex [string map [list %id% $id] {(.*)(\x1bP%id%!~([[:alnum:]]+)\x1b\\)$}]
@ -1273,7 +1340,21 @@ namespace eval punk::console {
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]
return $payload
}
proc get_device_status {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_device_status
@cmd -name punk::console::get_device_status -summary\
"Query device status (DSR 5n) - a 0 payload indicates OK."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_device_status {args} {
#see PUNKARGS id ::punk::console::get_device_status
set inoutchannels [internal::hybrid_console_spec $args get_device_status]
set capturingregex {(.*)(\x1b\[([0-9]+)n)$} ;#must capture prefix,entire-response,response-payload
set request "\x1b\[5n"
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]
@ -1302,7 +1383,21 @@ namespace eval punk::console {
#https://vt100.net/docs/vt510-rm/DA1.html
#
proc get_device_attributes {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_device_attributes
@cmd -name punk::console::get_device_attributes -summary\
"Query primary device attributes (DA1) - the payload is recorded as the console's last_da1_result fact."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_device_attributes {args} {
#see PUNKARGS id ::punk::console::get_device_attributes
set inoutchannels [internal::hybrid_console_spec $args get_device_attributes]
#Note the vt52 rough equivalen \x1bZ - commonly supported but probably best considered obsolete as it collides with ECMA 48 SCI Single Character Introducer
#DA1
#first element in result is the terminal's architectural class 61,62,63,64.. ?
@ -1606,19 +1701,60 @@ namespace eval punk::console {
set parsed [classify_device_attributes_secondary $da2_response]
return $parsed
}
proc get_device_attributes_tertiary {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_device_attributes_tertiary
@cmd -name punk::console::get_device_attributes_tertiary -summary\
"Query tertiary device attributes (DA3) - terminal unit id."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_device_attributes_tertiary {args} {
#see PUNKARGS id ::punk::console::get_device_attributes_tertiary
set inoutchannels [internal::hybrid_console_spec $args get_device_attributes_tertiary]
#DA3
set capturingregex {(.*)(\x1bP!\|([0-9]{8})\x1b\\)$} ;#must capture prefix,entire-response,response-payload
set request "\x1b\[=c"
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]
return $payload
}
proc get_terminal_id {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_terminal_id
@cmd -name punk::console::get_terminal_id -summary\
"Alias for get_device_attributes_tertiary (DA3)."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_terminal_id {args} {
#see PUNKARGS id ::punk::console::get_terminal_id
#DA3 - alias
get_device_attributes_tertiary $inoutchannels
get_device_attributes_tertiary {*}$args
}
proc get_tabstops {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_tabstops
@cmd -name punk::console::get_tabstops -summary\
"Query tabstop columns (DECTABSR) - returns the list of tabstop column numbers."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_tabstops {args} {
#see PUNKARGS id ::punk::console::get_tabstops
set inoutchannels [internal::hybrid_console_spec $args get_tabstops]
#DECTABSR \x1b\[2\$w
#response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b)
#set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)}
@ -1634,7 +1770,21 @@ namespace eval punk::console {
#It's known this isn't always the case - but things like textutil::untabify2 take only a single value
#on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower
#we will use test_char_width as a fallback
proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_tabstop_apparent_width
@cmd -name punk::console::get_tabstop_apparent_width -summary\
"Determine apparent tabstop spacing (DECTABSR, falling back to test_char_width, then 8)."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_tabstop_apparent_width {args} {
#see PUNKARGS id ::punk::console::get_tabstop_apparent_width
set inoutchannels [internal::hybrid_console_spec $args get_tabstop_apparent_width]
set tslist [get_tabstops $inoutchannels]
if {![llength $tslist]} {
#either terminal failed to report - or none set.
@ -1704,8 +1854,21 @@ namespace eval punk::console {
}
proc get_cursor_pos_list {{inoutchannels {stdin stdout}}} {
return [split [get_cursor_pos $inoutchannels] ";"]
lappend PUNKARGS [list {
@id -id ::punk::console::get_cursor_pos_list
@cmd -name punk::console::get_cursor_pos_list -summary\
"Query cursor position (CSI 6n) - returns {row col}."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_cursor_pos_list {args} {
#see PUNKARGS id ::punk::console::get_cursor_pos_list
return [split [get_cursor_pos {*}$args] ";"]
}
#todo - work out how to query terminal and set cell size in pixels
@ -1799,7 +1962,18 @@ namespace eval punk::console {
#until a read is attempted - so for pipe-like channels a non-blocking 1-byte probe read is performed.
#Any byte consumed by the probe is preserved in ::punk::console::input_chunks_waiting($input) for
#cooperating readers (repl etc).
lappend PUNKARGS [list {
@id -id ::punk::console::input_at_eof
@cmd -name punk::console::input_at_eof -summary\
"Determine with certainty whether an input channel is closed/at eof (probe read for deferred pipe eof; probed bytes preserved in input_chunks_waiting)."\
-help\
"NOTE: plain positional signature - this definition is documentation."
@values -min 0 -max 1
input -type string -default stdin -optional 1 -help\
"Input channel name."
}]
proc input_at_eof {{input stdin}} {
#see PUNKARGS id ::punk::console::input_at_eof
if {[catch {chan eof $input} is_eof]} {
return 1 ;#closed/invalid channel - unusable
}
@ -1839,7 +2013,18 @@ namespace eval punk::console {
#(MSYSTEM, TERM_PROGRAM) are used to avoid false negatives there, at the cost of false positives in
#environments that inherit such vars with genuinely piped (but still open) input - those paths still
#rely on the ANSI query timeout mechanisms rather than hanging indefinitely.
lappend PUNKARGS [list {
@id -id ::punk::console::is_input_console_or_tty
@cmd -name punk::console::is_input_console_or_tty -summary\
"Best-effort test whether an input channel could be a terminal able to answer ANSI queries (0 only when reasonably certain it cannot)."\
-help\
"NOTE: plain positional signature - this definition is documentation."
@values -min 0 -max 1
input -type string -default stdin -optional 1 -help\
"Input channel name."
}]
proc is_input_console_or_tty {{input stdin}} {
#see PUNKARGS id ::punk::console::is_input_console_or_tty
if {[catch {chan configure $input} conf]} {
return 0
}
@ -2151,23 +2336,7 @@ namespace eval punk::console {
}
proc get_size {args} {
#manual argument parsing - performance sensitive path (see PUNKARGS id ::punk::console::get_size for documentation)
switch -exact -- [llength $args] {
0 {
set consolespec {stdin stdout}
}
1 {
set consolespec [lindex $args 0] ;#legacy positional inoutchannels - accepts any console spec form
}
2 {
if {[lindex $args 0] ne "-console"} {
error "get_size: expected ?consolespec? or -console <consolespec> - got '$args'"
}
set consolespec [lindex $args 1]
}
default {
error "get_size: expected ?consolespec? or -console <consolespec> - got '$args'"
}
}
set consolespec [internal::hybrid_console_spec $args get_size]
set cinfo [console_spec_resolve $consolespec]
set in [dict get $cinfo in]
set out [dict get $cinfo out]
@ -2225,7 +2394,19 @@ namespace eval punk::console {
#{columns <int> rows <int>} or an empty dict when size cannot be determined.
#Used by the legacy get_size channel path and (as console_size_provider) by the base
#::opunk::Console::size method via the pluggable ::opunk::console::size_query_provider hook.
lappend PUNKARGS [list {
@id -id ::punk::console::size_via_query_mechanisms
@cmd -name punk::console::size_via_query_mechanisms -summary\
"ANSI/tput size mechanisms with per-console-pair timing cache - {columns <c> rows <r>} or empty dict when undetermined."\
-help\
"Internal mechanism dispatcher used by get_size and (as console_size_provider) by the
::opunk::Console::size method. Callers supply a canonical {in out} channel pair."
@values -min 1 -max 1
inoutchannels -type list -help\
"Canonical {in out} channel pair."
}]
proc size_via_query_mechanisms {inoutchannels} {
#see PUNKARGS id ::punk::console::size_via_query_mechanisms
if {[console_fact_get $inoutchannels is_vt52]} {
#vt52 doesn't support cursor save/restore or cursor position reports.
if {![catch {get_size_using_tput $inoutchannels} sizedict]} {
@ -2289,7 +2470,16 @@ namespace eval punk::console {
#Registered as the ::opunk::console::size_query_provider (see ensure_object_integration):
#gives the base ::opunk::Console::size method access to the ANSI query mechanisms without the
#class depending on punk::console.
lappend PUNKARGS [list {
@id -id ::punk::console::console_size_provider
@cmd -name punk::console::console_size_provider -summary\
"Registered as ::opunk::console::size_query_provider - gives the base Console::size method the ANSI size mechanisms."
@values -min 1 -max 1
obj -type list -help\
"::opunk::Console (or subclass) object value."
}]
proc console_size_provider {obj} {
#see PUNKARGS id ::punk::console::console_size_provider
size_via_query_mechanisms [::opunk::Console::channels $obj]
}
@ -2314,7 +2504,16 @@ namespace eval punk::console {
set object_integration_done 1
}
lappend PUNKARGS [list {
@id -id ::punk::console::get_size_using_chanconfigure
@cmd -name punk::console::get_size_using_chanconfigure -summary\
"Console size from 'chan configure -winsize' on the output channel - errors when unsupported."
@values -min 0 -max 1
inoutchannels -type list -default {stdin stdout} -optional 1 -help\
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)."
}]
proc get_size_using_chanconfigure {{inoutchannels {stdin stdout}}} {
#see PUNKARGS id ::punk::console::get_size_using_chanconfigure
set out [lindex $inoutchannels 1]
set outconf [chan configure $out]
if {[dict exists $outconf -winsize]} {
@ -2329,7 +2528,16 @@ namespace eval punk::console {
error "chan configure method of getting console size not supported or failed to get valid size info"
}
lappend PUNKARGS [list {
@id -id ::punk::console::get_size_using_tput
@cmd -name punk::console::get_size_using_tput -summary\
"Console size via the external tput utility (process terminal) - errors when tput is unavailable."
@values -min 0 -max 1
inoutchannels -type list -default {stdin stdout} -optional 1 -help\
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)."
}]
proc get_size_using_tput {{inoutchannels {stdin stdout}}} {
#see PUNKARGS id ::punk::console::get_size_using_tput
set tputcmd [auto_execok tput]
if {$tputcmd eq ""} {
error "tput command not found - cannot use tput method to get console size"
@ -2338,7 +2546,16 @@ namespace eval punk::console {
return [dict create columns $cols rows $lines]
}
lappend PUNKARGS [list {
@id -id ::punk::console::get_size_using_cursormove
@cmd -name punk::console::get_size_using_cursormove -summary\
"Console size via big cursor move + position report (no cursor save/restore)."
@values -min 0 -max 1
inoutchannels -type list -default {stdin stdout} -optional 1 -help\
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)."
}]
proc get_size_using_cursormove {{inoutchannels {stdin stdout}}} {
#see PUNKARGS id ::punk::console::get_size_using_cursormove
set out [lindex $inoutchannels 1]
#we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810
#chan eof is faster whether chan exists or not than
@ -2368,7 +2585,16 @@ namespace eval punk::console {
}
#faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore
lappend PUNKARGS [list {
@id -id ::punk::console::get_size_using_cursorrestore
@cmd -name punk::console::get_size_using_cursorrestore -summary\
"Console size via big cursor move + position report, bracketed by DEC cursor save/restore."
@values -min 0 -max 1
inoutchannels -type list -default {stdin stdout} -optional 1 -help\
"Canonical {in out} channel pair (internal size mechanism - not spec-form aware)."
}]
proc get_size_using_cursorrestore {{inoutchannels {stdin stdout}}} {
#see PUNKARGS id ::punk::console::get_size_using_cursorrestore
lassign $inoutchannels in out
set outconf [chan configure $out]
#don't use shortcut mechanisms - this function is intended to specificall use the cursor_save/restore method
@ -2398,22 +2624,63 @@ namespace eval punk::console {
}
proc get_dimensions {{inoutchannels {stdin stdout}}} {
lassign [get_size $inoutchannels] _c cols _l lines
lappend PUNKARGS [list {
@id -id ::punk::console::get_dimensions
@cmd -name punk::console::get_dimensions -summary\
"Console size as a WxH string (see get_size)."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_dimensions {args} {
#see PUNKARGS id ::punk::console::get_dimensions
lassign [get_size {*}$args] _c cols _l lines
return "${cols}x${lines}"
}
#the (xterm?) CSI 18t query is supported by *some* terminals
proc get_xterm_size {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_xterm_size
@cmd -name punk::console::get_xterm_size -summary\
"Query text-area size via xterm CSI 18t - returns {columns <c> rows <r>}."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_xterm_size {args} {
#see PUNKARGS id ::punk::console::get_xterm_size
set inoutchannels [internal::hybrid_console_spec $args get_xterm_size]
set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload
set request "\x1b\[18t"
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]
lassign [split $payload {;}] rows cols
return [list columns $cols rows $rows]
}
proc get_xterm_pixels {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::get_xterm_pixels
@cmd -name punk::console::get_xterm_pixels -summary\
"Query text-area pixel size via xterm CSI 14t - returns {width <w> height <h>}."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc get_xterm_pixels {args} {
#see PUNKARGS id ::punk::console::get_xterm_pixels
set inoutchannels [internal::hybrid_console_spec $args get_xterm_pixels]
set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload
set request "\x1b\[14t"
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]
@ -2425,7 +2692,21 @@ namespace eval punk::console {
proc dec_get_mode_line_wrap {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::dec_get_mode_line_wrap
@cmd -name punk::console::dec_get_mode_line_wrap -summary\
"Query DEC autowrap mode (DECAWM, mode 7) state via DECRQM."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc dec_get_mode_line_wrap {args} {
#see PUNKARGS id ::punk::console::dec_get_mode_line_wrap
set inoutchannels [internal::hybrid_console_spec $args dec_get_mode_line_wrap]
set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?7\$p"
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]
@ -2434,7 +2715,21 @@ namespace eval punk::console {
#Terminals generally default to LNM being reset (off) ie enter key sends a lone <cr>
#windows terminal defaults to LNM on, but wezterm on windows default to LNM off
#LNM on sends both <cr> and <lf> ??
proc ansi_get_mode_LNM {{inoutchannels {stdin stdout}}} {
lappend PUNKARGS [list {
@id -id ::punk::console::ansi_get_mode_LNM
@cmd -name punk::console::ansi_get_mode_LNM -summary\
"Query ANSI linefeed/newline mode (LNM, mode 20) state via DECRQM."\
-help\
"NOTE: argument parsing is manual - this definition is documentation."
@opts
${[punk::args::resolved_def -types opts ::punk::console::argdoc::console_opts -console]}
@values -min 0 -max 1
inoutchannels -type list -optional 1 -help\
"Legacy positional console specification (same forms accepted as -console)."
}]
proc ansi_get_mode_LNM {args} {
#see PUNKARGS id ::punk::console::ansi_get_mode_LNM
set inoutchannels [internal::hybrid_console_spec $args ansi_get_mode_LNM]
set capturingregex {(.*)(\x1b\[20;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload
set request "\x1b\[20\$p"
set payload [punk::console::internal::get_ansi_response_payload -console $inoutchannels $request $capturingregex]

5
src/modules/punk/console-buildversion.txt

@ -1,6 +1,9 @@
0.4.0
0.5.0
#First line must be a semantic version number
#all other lines are ignored.
#0.5.0 - migration complete: the remaining trailing-positional query functions (get_cursor_pos, get_cursor_pos_list, get_checksum_rect, get_device_status, get_device_attributes, get_device_attributes_tertiary, get_terminal_id, get_tabstops, get_tabstop_apparent_width, get_dimensions, get_xterm_size, get_xterm_pixels, dec_get_mode_line_wrap, ansi_get_mode_LNM) converted to the get_size hybrid pattern via new internal::hybrid_console_spec - each accepts the legacy positional console spec or -console <consolespec> (any spec form), with PUNKARGS documentation
#0.5.0 - get_size refactored onto internal::hybrid_console_spec (behaviour unchanged)
#0.5.0 - documentation-only PUNKARGS added for input_at_eof, is_input_console_or_tty, size_via_query_mechanisms, console_size_provider and the get_size_using_* mechanism helpers (signatures unchanged - internal size mechanisms remain canonical-pair only)
#0.4.0 - mode setters (dec_set_mode/dec_unset_mode/ansi_set_mode/ansi_unset_mode) and cursor_style resolve their -console spec via console_spec_resolve instead of '[lindex $terminal 1]' - anchored instance names and ::opunk::Console object values now work (previously silently wrote to the wrong target)
#0.4.0 - the fourteen '-console -type list -minsize 2' declarations replaced with shared fragment ::punk::console::argdoc::console_opts (the -minsize 2 constraint rejected 1-element instance-name specs at parse time); show_input_response and cell_size -console docs unified on the fragment
#0.4.0 - dec_has_mode/ansi_has_mode cache on the canonical {in out} pair - all spec forms addressing the same console share one cache entry (previously keyed on the raw spec string)

154
src/tests/modules/punk/console/testsuites/console/queryprocs.test

@ -0,0 +1,154 @@
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 hybrid-converted query functions (migration plan phase 4): each accepts an
#optional legacy positional console specification or '-console <consolespec>' (any spec form),
#parsed via punk::console::internal::hybrid_console_spec. Terminal responses are fed on the
#'input' pipe after each query is emitted, as a real terminal would.
namespace eval ::testspace {
namespace import ::tcltest::*
#in/out pipe pairs: rdi/wri feeds the console 'input', wro/rdo captures 'output'
variable pipes_setup {
set result ""
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
}
variable pipes_cleanup {
foreach c [list $wri $rdi $wro $rdo] {
catch {chan close $c}
}
array unset ::punk::console::input_chunks_waiting $rdi
}
#deliver a terminal response after the query has been emitted (fires inside the
#query's vwait - simulating a real terminal's response timing)
proc feed {wchan data} {
after 40 [list apply [list {w d} {
puts -nonewline $w $d
flush $w
}] $wchan $data]
}
test qp_cursor_pos_forms {get_cursor_pos/get_cursor_pos_list accept positional, -console and instance-name spec forms}\
-setup $pipes_setup -body {
feed $wri "\x1b\[10;5R"
lappend result [punk::console::get_cursor_pos [list $rdi $wro]]
feed $wri "\x1b\[11;6R"
lappend result [punk::console::get_cursor_pos -console [list $rdi $wro]]
opunk::console::create qptest1 $rdi $wro
#pre-settle capability - an unsettled anchored instance would trigger first-use
#settling, which (correctly) settles 0 on a hint-less pipe pair and refuses to query
upvar #0 [opunk::console::instancevar qptest1] qpobj
::opunk::Console::set.o_can_respond qpobj 1
feed $wri "\x1b\[12;7R"
lappend result [punk::console::get_cursor_pos_list -console qptest1]
#bad tails error without emitting
lappend result [catch {punk::console::get_cursor_pos -notanoption x}]
lappend result [catch {punk::console::get_cursor_pos a b c}]
}\
-cleanup [string cat {
catch {opunk::console::forget qptest1}
} $pipes_cleanup]\
-result [list\
{10;5}\
{11;6}\
{12 7}\
1\
1\
]
test qp_device_queries {get_device_status, DA3 and get_terminal_id parse fed responses}\
-setup $pipes_setup -body {
set spec [list $rdi $wro]
feed $wri "\x1b\[0n"
lappend result [punk::console::get_device_status -console $spec]
feed $wri "\x1bP!|00010203\x1b\\"
lappend result [punk::console::get_device_attributes_tertiary -console $spec]
feed $wri "\x1bP!|00010203\x1b\\"
lappend result [punk::console::get_terminal_id $spec]
}\
-cleanup $pipes_cleanup\
-result [list\
0\
00010203\
00010203\
]
test qp_tabstops {get_tabstops and get_tabstop_apparent_width parse DECTABSR responses}\
-setup $pipes_setup -body {
set spec [list $rdi $wro]
feed $wri "\x1bP2\$u9/17/25\x1b\\"
lappend result [punk::console::get_tabstops -console $spec]
#tabstop at column 1 present: apparent width is next stop minus 1
feed $wri "\x1bP2\$u1/9\x1b\\"
lappend result [punk::console::get_tabstop_apparent_width -console $spec]
}\
-cleanup $pipes_cleanup\
-result [list\
{9 17 25}\
8\
]
test qp_xterm_size_pixels {get_xterm_size and get_xterm_pixels parse CSI t reports}\
-setup $pipes_setup -body {
set spec [list $rdi $wro]
feed $wri "\x1b\[8;24;80t"
lappend result [punk::console::get_xterm_size -console $spec]
feed $wri "\x1b\[4;480;640t"
lappend result [punk::console::get_xterm_pixels -console $spec]
}\
-cleanup $pipes_cleanup\
-result [list\
{columns 80 rows 24}\
{width 640 height 480}\
]
test qp_mode_shortcuts_and_checksum {dec_get_mode_line_wrap, ansi_get_mode_LNM and get_checksum_rect parse fed responses}\
-setup $pipes_setup -body {
set spec [list $rdi $wro]
feed $wri "\x1b\[?7;1\$y"
lappend result [punk::console::dec_get_mode_line_wrap -console $spec]
feed $wri "\x1b\[20;2\$y"
lappend result [punk::console::ansi_get_mode_LNM -console $spec]
feed $wri "\x1bP1!~ABCD\x1b\\"
lappend result [punk::console::get_checksum_rect 1 1 1 1 10 10 -console $spec]
}\
-cleanup $pipes_cleanup\
-result [list\
1\
2\
ABCD\
]
test qp_get_dimensions_passthrough {get_dimensions delegates its spec to get_size (settled object supplies default size)}\
-setup {
set result ""
lassign [chan pipe] rd wr
}\
-body {
set obj [::opunk::Console::new.args -o_in $rd -o_out $wr -o_default_size {columns 132 rows 50}]
::opunk::Console::set.o_can_respond obj 0
lappend result [punk::console::get_dimensions -console $obj]
lappend result [punk::console::get_dimensions $obj]
}\
-cleanup {
catch {chan close $wr}
catch {chan close $rd}
}\
-result [list\
132x50\
132x50\
]
}
tcltest::cleanupTests ;#needed to produce test summary.
Loading…
Cancel
Save