Browse Source
- three new backend modules under src/modules/opunk/console/, base ::opunk::Console and punk::console UNCHANGED (the G-001 acceptance constraint - verified diff-clean): * opunk::console::test / ::opunk::TestConsole - deterministic channel-pair test double: fixed size via -columns/-rows, is_console_or_tty/can_respond 1 (settled value wins), at_eof = plain chan eof with NO probe (pending bytes never consumed - pinned). The console seam identified by the G-044 repl characterization work * opunk::console::ssh / ::opunk::SshConsole - socket-carried terminal sessions: construction-time capability (detection is the wrong tool - per goal detail), chan-eof without byte-consuming probes, size via the registered ANSI size-query provider over the connection. Flagship test: a scripted remote terminal answers CSI 6n over a socket pair and size resolves 100x30 through punk::console machinery querying the socket * opunk::console::tk / ::opunk::TkConsole - Tk text widget as terminal: widget path in the inherited in/out slots (documented non-channel reuse), terminal_class tk-text, size from widget char dims, at_eof via backend marker (opunk::console::tk::set_eof) or widget destruction; no Tk require at module load. Verified live under punk91 src (the tk-loading experiment kit) - voo -extends subclassing pattern recorded in opunk/AGENTS.md: children inherit public accessors + field INDEX variables (not parent-private my.* accessors) - constructors initialise inherited private fields via index vars, method bodies use parent public accessor methods; virtual dispatch via the slot-0 tag needs no base changes - tests: modules/opunk/console backends.test (8 tests: dispatch, spec_resolve acceptance of subclass values, probe-free eof, settled-capability precedence, ssh capability/eof/size-over-socket/settled-0-no-emission, tk gated behind env PUNK_TEST_TK=1) - 7 green + tk skip on tcl 9.0.3 and 8.7; tk case verified standalone under punk91 - goal detail records progress + remaining work (repl -console launch wiring, output-channel parameterization, interactive acceptance verification); goal stays active Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
13 changed files with 678 additions and 2 deletions
@ -1,3 +1,3 @@
|
||||
[project] |
||||
name = "punkshell" |
||||
version = "0.8.2" |
||||
version = "0.9.0" |
||||
|
||||
@ -0,0 +1,111 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console::ssh 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
package require Tcl 8.6- |
||||
package require voo |
||||
package require opunk::console |
||||
|
||||
#opunk::SshConsole - an ::opunk::Console backend for terminal sessions carried over a |
||||
#socket-like channel pair (G-001) - the ssh-channel case: a remote user's terminal is on |
||||
#the other end of the connection, but the local channel is a plain socket exposing none |
||||
#of the signals terminal detection relies on (-inputmode/-mode, twapi handles, env hints). |
||||
# |
||||
#The backend is CONSTRUCTED knowing the far end is a terminal, so: |
||||
# - is_console_or_tty: always 1 (explicit construction-time knowledge, not detection) |
||||
# - can_respond: settled value if set, else 1 (the remote terminal answers ANSI |
||||
# queries carried over the connection) |
||||
# - at_eof: plain [chan eof] on the channel - deliberately NO base-class |
||||
# pipe-probe: probing a socket would consume a byte the protocol |
||||
# layer/reader needs (see goals/G-001 detail) |
||||
# - size: the registered ::opunk::console::size_query_provider when |
||||
# available (punk::console's ANSI cursor-report mechanisms operate |
||||
# over the channel pair like any other console), else the |
||||
# configured default size. No -winsize attempt (sockets have none). |
||||
# |
||||
#No edits to the base ::opunk::Console or punk::console are needed (G-001 acceptance). |
||||
|
||||
voo::class ::opunk::SshConsole -extends ::opunk::Console { |
||||
public { |
||||
method is_console_or_tty {} { |
||||
return 1 |
||||
} |
||||
method can_respond {} { |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return 1 |
||||
} |
||||
method at_eof {} { |
||||
set in [::opunk::Console::in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
return $is_eof |
||||
} |
||||
method size {} { |
||||
if {![can_respond $this]} { |
||||
return [::opunk::Console::default_size $this] |
||||
} |
||||
if {$::opunk::console::size_query_provider ne ""} { |
||||
if {![catch {{*}$::opunk::console::size_query_provider $this} sized]} { |
||||
if {[dict size $sized] && [string is integer -strict [dict get $sized columns]] && [string is integer -strict [dict get $sized rows]]} { |
||||
return $sized |
||||
} |
||||
} |
||||
} |
||||
return [::opunk::Console::default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out} { |
||||
#in/out: the channel pair of the connection (a single socket channel may be |
||||
#passed for both). Parent fields are private - set via imported index variables. |
||||
variable o_in |
||||
variable o_out |
||||
set obj [new()] |
||||
lset obj $o_in $in |
||||
lset obj $o_out $out |
||||
return $obj |
||||
} |
||||
} |
||||
namespace eval ::opunk::SshConsole { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
tcl::namespace::eval ::opunk::console::ssh { |
||||
tcl::namespace::export {[a-z]*} |
||||
variable PUNKARGS |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console::ssh" |
||||
@package -name "opunk::console::ssh" -help\ |
||||
"voo class ::opunk::SshConsole - an ::opunk::Console backend for terminal sessions |
||||
carried over socket-like channels (e.g an ssh connection): constructed knowing the |
||||
far end is a terminal, eof via chan eof (no byte-consuming probe), size via the |
||||
registered ANSI size-query provider over the connection (G-001)." |
||||
}] |
||||
} |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console::ssh ::opunk::SshConsole |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console::ssh [tcl::namespace::eval ::opunk::console::ssh { |
||||
variable pkg opunk::console::ssh |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,4 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.1.0 - G-001: initial ::opunk::Console backend subclass |
||||
@ -0,0 +1,120 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console::test 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
package require Tcl 8.6- |
||||
package require voo |
||||
package require opunk::console |
||||
|
||||
#opunk::TestConsole - a scripted/deterministic ::opunk::Console backend (G-001). |
||||
# |
||||
#The first client of the pluggable-backend seam and the console TEST DOUBLE the repl |
||||
#characterization work needs (see goals/G-044 detail - class_editbuf and raw-mode |
||||
#behaviours are console-coupled and cannot be unit-tested against a live terminal). |
||||
# |
||||
#Wraps a caller-supplied channel pair (typically [chan pipe] ends or reflected channels |
||||
#owned by a test harness) and answers the capability/size questions DETERMINISTICALLY: |
||||
# - is_console_or_tty: always 1 (constructed knowing it plays the terminal role) |
||||
# - can_respond: settled value if set, else 1 |
||||
# - at_eof: plain [chan eof] on the input channel - NEVER probes (a probe |
||||
# would consume a byte the test harness scripted) |
||||
# - size: the configured size - no -winsize, no query emission, no |
||||
# size_query_provider consultation. Set at construction |
||||
# (-columns/-rows) and stored in the inherited o_default_size. |
||||
# |
||||
#No edits to the base ::opunk::Console or punk::console are needed (G-001 acceptance): |
||||
#values carry this class's namespace tag at slot 0 and existing holders (e.g |
||||
#punk::console::console_spec_resolve callers) dispatch to these overrides virtually. |
||||
|
||||
voo::class ::opunk::TestConsole -extends ::opunk::Console { |
||||
public { |
||||
method is_console_or_tty {} { |
||||
return 1 |
||||
} |
||||
method can_respond {} { |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return 1 |
||||
} |
||||
method at_eof {} { |
||||
set in [::opunk::Console::in $this] |
||||
if {[catch {chan eof $in} is_eof]} { |
||||
return 1 ;#closed/invalid channel - unusable |
||||
} |
||||
return $is_eof |
||||
} |
||||
method size {} { |
||||
return [::opunk::Console::default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {in out args} { |
||||
#args: optional -columns <int> -rows <int> (default 80x24 from the base field). |
||||
#Parent fields are private, so their imported INDEX variables are used to set |
||||
#slots on the child-tagged default value (the voo -extends pattern for |
||||
#initialising inherited private fields). |
||||
variable o_in |
||||
variable o_out |
||||
variable o_default_size |
||||
set obj [new()] |
||||
lset obj $o_in $in |
||||
lset obj $o_out $out |
||||
set size [lindex $obj $o_default_size] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-columns { |
||||
dict set size columns $v |
||||
} |
||||
-rows { |
||||
dict set size rows $v |
||||
} |
||||
default { |
||||
error "opunk::TestConsole::new unknown option '$k'. Known options: -columns -rows" |
||||
} |
||||
} |
||||
} |
||||
lset obj $o_default_size $size |
||||
return $obj |
||||
} |
||||
} |
||||
namespace eval ::opunk::TestConsole { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
tcl::namespace::eval ::opunk::console::test { |
||||
tcl::namespace::export {[a-z]*} |
||||
variable PUNKARGS |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console::test" |
||||
@package -name "opunk::console::test" -help\ |
||||
"voo class ::opunk::TestConsole - a scripted/deterministic ::opunk::Console backend |
||||
wrapping a caller-supplied channel pair (e.g chan pipe ends) with fixed capability |
||||
answers and a configured size. The console test double for harness-driven repl and |
||||
editbuf testing (G-001)." |
||||
}] |
||||
} |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console::test ::opunk::TestConsole |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console::test [tcl::namespace::eval ::opunk::console::test { |
||||
variable pkg opunk::console::test |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,4 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.1.0 - G-001: initial ::opunk::Console backend subclass |
||||
@ -0,0 +1,154 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application opunk::console::tk 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
package require Tcl 8.6- |
||||
package require voo |
||||
package require opunk::console |
||||
#NOTE: deliberately NO 'package require Tk' here - the class definition is loadable |
||||
#without Tk; construction errors usefully if the widget doesn't exist. This keeps the |
||||
#backend requirable in non-GUI processes (introspection, docs) and leaves Tk loading |
||||
#policy to the application (punk runtimes load Tk as an extension - punkbin convention). |
||||
|
||||
#opunk::TkConsole - an ::opunk::Console backend for a Tk text widget acting as a |
||||
#terminal (G-001). A widget is not a channel at all, so every channel-shaped base |
||||
#method is overridden - none of the channel/provider logic applies (the class comment |
||||
#in opunk/console anticipates exactly this subclass). |
||||
# |
||||
# - o_in/o_out carry the WIDGET PATH (documented reuse of the inherited channel slots - |
||||
# holders calling in/out/channels get the widget path; a non-channel consumer must |
||||
# know its backend, which is what is_console_or_tty/terminal_class are for) |
||||
# - is_console_or_tty: always 1 (constructed as a terminal) |
||||
# - can_respond: settled value if set, else 1 (the widget side can answer - |
||||
# whatever integrating layer renders to the widget also responds) |
||||
# - at_eof: a backend eof MARKER, not a channel eof: 1 when the widget no |
||||
# longer exists (winfo exists - requires Tk loaded) or when the |
||||
# integrating layer has flagged eof via ::opunk::console::tk::set_eof |
||||
# (e.g the user closed the console frame but the widget remains) |
||||
# - size: the widget's character dimensions ([$w cget -width/-height] - |
||||
# the text widget's requested size in chars), falling back to the |
||||
# inherited default size if the widget can't be queried. |
||||
# |
||||
#No edits to the base ::opunk::Console or punk::console are needed (G-001 acceptance). |
||||
|
||||
tcl::namespace::eval ::opunk::console::tk { |
||||
#backend eof markers keyed by widget path - set via set_eof, consulted by at_eof |
||||
variable eof_flags |
||||
if {![array exists eof_flags]} { |
||||
array set eof_flags {} |
||||
} |
||||
} |
||||
|
||||
voo::class ::opunk::TkConsole -extends ::opunk::Console { |
||||
public { |
||||
method is_console_or_tty {} { |
||||
return 1 |
||||
} |
||||
method can_respond {} { |
||||
set settled [get.o_can_respond $this] |
||||
if {$settled != -1} { |
||||
return $settled |
||||
} |
||||
return 1 |
||||
} |
||||
method at_eof {} { |
||||
set w [::opunk::Console::in $this] |
||||
if {[info exists ::opunk::console::tk::eof_flags($w)] && $::opunk::console::tk::eof_flags($w)} { |
||||
return 1 |
||||
} |
||||
if {[catch {winfo exists $w} exists]} { |
||||
#Tk not loaded (or not usable) in this interp - the widget cannot be |
||||
#driven from here; report eof rather than pretending liveness |
||||
return 1 |
||||
} |
||||
return [expr {!$exists}] |
||||
} |
||||
method size {} { |
||||
set w [::opunk::Console::in $this] |
||||
if {![catch {list [$w cget -width] [$w cget -height]} wh]} { |
||||
lassign $wh cols rows |
||||
if {[string is integer -strict $cols] && [string is integer -strict $rows] && $cols > 0 && $rows > 0} { |
||||
return [dict create columns $cols rows $rows] |
||||
} |
||||
} |
||||
return [::opunk::Console::default_size $this] |
||||
} |
||||
} |
||||
|
||||
constructor {widget} { |
||||
#widget: path of a Tk text widget playing the terminal role. Stored in both the |
||||
#inherited in/out slots (documented non-channel reuse). Parent fields are |
||||
#private - set via imported index variables. |
||||
variable o_in |
||||
variable o_out |
||||
variable o_terminal_class |
||||
set obj [new()] |
||||
lset obj $o_in $widget |
||||
lset obj $o_out $widget |
||||
lset obj $o_terminal_class tk-text |
||||
return $obj |
||||
} |
||||
} |
||||
namespace eval ::opunk::TkConsole { |
||||
namespace ensemble create |
||||
} |
||||
|
||||
tcl::namespace::eval ::opunk::console::tk { |
||||
tcl::namespace::export {[a-z]*} |
||||
variable PUNKARGS |
||||
|
||||
#flag (or clear) backend eof for a widget-backed console - e.g when the hosting |
||||
#frame/toplevel is being torn down but holders may still consult the console value |
||||
proc set_eof {widget {value 1}} { |
||||
variable eof_flags |
||||
set eof_flags($widget) [expr {bool($value)}] |
||||
return |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)opunk::console::tk" |
||||
@package -name "opunk::console::tk" -help\ |
||||
"voo class ::opunk::TkConsole - an ::opunk::Console backend wrapping a Tk text |
||||
widget acting as a terminal: size from the widget's character dimensions, eof via |
||||
a backend marker (::opunk::console::tk::set_eof) or widget destruction - a |
||||
non-channel subclass overriding all channel-shaped base methods (G-001)." |
||||
}] |
||||
lappend PUNKARGS [list { |
||||
@id -id ::opunk::console::tk::set_eof |
||||
@cmd -name opunk::console::tk::set_eof\ |
||||
-summary\ |
||||
"Flag or clear backend eof for a widget-backed console."\ |
||||
-help\ |
||||
"Sets the backend eof marker consulted by ::opunk::TkConsole at_eof. |
||||
Use when the hosting frame/toplevel is being torn down (or reopened) while |
||||
holders may still consult console values wrapping the widget." |
||||
@leaders -min 1 -max 1 |
||||
widget -type string -help\ |
||||
"Tk widget path the console wraps" |
||||
@values -min 0 -max 1 |
||||
value -type boolean -default 1 -optional 1 -help\ |
||||
"1 to flag eof (default), 0 to clear" |
||||
}] |
||||
} |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::opunk::console::tk ::opunk::TkConsole |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide opunk::console::tk [tcl::namespace::eval ::opunk::console::tk { |
||||
variable pkg opunk::console::tk |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,4 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.1.0 - G-001: initial ::opunk::Console backend subclass |
||||
@ -0,0 +1,224 @@
|
||||
package require tcltest |
||||
|
||||
package require opunk::console |
||||
package require opunk::console::test |
||||
package require opunk::console::ssh |
||||
package require opunk::console::tk |
||||
package require punk::console |
||||
|
||||
#G-001: pluggable ::opunk::Console backends. These tests verify the subclassing seam |
||||
#the base class was designed for: values carry the subclass namespace tag at slot 0 and |
||||
#existing holders (BASE-class method calls, punk::console::console_spec_resolve) dispatch |
||||
#to the subclass overrides - with the base ::opunk::Console and punk::console modules |
||||
#UNCHANGED (the G-001 acceptance constraint). |
||||
# |
||||
#Backends covered: |
||||
# - ::opunk::TestConsole (opunk::console::test) - deterministic test double over a |
||||
# caller-supplied channel pair; the console seam for repl/editbuf characterization |
||||
# - ::opunk::SshConsole (opunk::console::ssh) - socket-carried terminal sessions; |
||||
# includes the flagship test: size resolved by punk::console's ANSI cursor-report |
||||
# provider QUERYING OVER THE SOCKET, answered by a scripted "remote terminal" |
||||
# - ::opunk::TkConsole (opunk::console::tk) - Tk text widget as terminal (gated on Tk) |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#Tk-backed test is opt-in (env PUNK_TEST_TK=1): loading Tk into the shared runtests |
||||
#testinterp creates a main window and event-loop side effects that outlive this file |
||||
if {[info exists ::env(PUNK_TEST_TK)] && [string is true -strict $::env(PUNK_TEST_TK)] |
||||
&& ![catch {package require Tk}]} { |
||||
catch {wm withdraw .} |
||||
testConstraint tkavailable 1 |
||||
} else { |
||||
testConstraint tkavailable 0 |
||||
} |
||||
|
||||
proc socketpair {} { |
||||
#returns {localend farend} of a connected tcp pair |
||||
set srv [socket -server {apply {{ch args} {set ::testspace::accepted $ch}}} 0] |
||||
set port [lindex [chan configure $srv -sockname] 2] |
||||
set cli [socket 127.0.0.1 $port] |
||||
vwait ::testspace::accepted |
||||
set local $::testspace::accepted |
||||
unset ::testspace::accepted |
||||
close $srv |
||||
foreach ch [list $local $cli] { |
||||
chan configure $ch -translation binary -blocking 0 -buffering none |
||||
} |
||||
return [list $local $cli] |
||||
} |
||||
|
||||
test backends_testconsole_virtual_dispatch {TestConsole values dispatch base-class method calls to the subclass overrides}\ |
||||
-setup { |
||||
set result "" |
||||
lassign [chan pipe] rd wr |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::TestConsole::new $rd $wr -columns 100 -rows 30] |
||||
lappend result [lindex $obj 0] |
||||
lappend result [::opunk::Console::size $obj] |
||||
lappend result [::opunk::Console::is_console_or_tty $obj] |
||||
lappend result [::opunk::Console::can_respond $obj] |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
lappend result [expr {[::opunk::Console::channels $obj] eq [list $rd $wr]}] |
||||
}\ |
||||
-cleanup { |
||||
close $wr |
||||
close $rd |
||||
}\ |
||||
-result [list ::opunk::TestConsole {columns 100 rows 30} 1 1 0 1] |
||||
|
||||
test backends_testconsole_at_eof_never_probes {TestConsole at_eof does not consume pending input (no base-class pipe probe)}\ |
||||
-setup { |
||||
set result "" |
||||
lassign [chan pipe] rd wr |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::TestConsole::new $rd $wr] |
||||
puts -nonewline $wr "X" |
||||
flush $wr |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
chan configure $rd -blocking 0 |
||||
lappend result [read $rd 1] |
||||
close $wr |
||||
read $rd |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
}\ |
||||
-cleanup { |
||||
close $rd |
||||
}\ |
||||
-result [list 0 X 1] |
||||
|
||||
test backends_testconsole_settled_can_respond_wins {a settled o_can_respond overrides the TestConsole default of 1}\ |
||||
-setup { |
||||
set result "" |
||||
lassign [chan pipe] rd wr |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::TestConsole::new $rd $wr] |
||||
::opunk::Console::set.o_can_respond obj 0 |
||||
lappend result [::opunk::Console::can_respond $obj] |
||||
}\ |
||||
-cleanup { |
||||
close $wr |
||||
close $rd |
||||
}\ |
||||
-result [list 0] |
||||
|
||||
test backends_spec_resolve_accepts_subclass_values {punk::console::console_spec_resolve (unchanged by G-001) accepts subclass object values}\ |
||||
-setup { |
||||
set result "" |
||||
lassign [chan pipe] rd wr |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::TestConsole::new $rd $wr] |
||||
set resolved [punk::console::console_spec_resolve $obj] |
||||
lappend result [expr {[dict get $resolved in] eq $rd}] |
||||
lappend result [expr {[dict get $resolved out] eq $wr}] |
||||
lappend result [lindex [dict get $resolved object] 0] |
||||
}\ |
||||
-cleanup { |
||||
close $wr |
||||
close $rd |
||||
}\ |
||||
-result [list 1 1 ::opunk::TestConsole] |
||||
|
||||
test backends_sshconsole_capabilities_and_eof {SshConsole reports terminal capability by construction and eof via chan eof after far-end close}\ |
||||
-setup { |
||||
set result "" |
||||
lassign [socketpair] local far |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::SshConsole::new $local $local] |
||||
lappend result [lindex $obj 0] |
||||
lappend result [::opunk::Console::is_console_or_tty $obj] |
||||
lappend result [::opunk::Console::can_respond $obj] |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
close $far |
||||
read $local |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
}\ |
||||
-cleanup { |
||||
close $local |
||||
}\ |
||||
-result [list ::opunk::SshConsole 1 1 0 1] |
||||
|
||||
test backends_sshconsole_size_via_ansi_query_over_socket {SshConsole size is answered by punk::console's ANSI cursor-report provider querying over the socket - a scripted remote terminal replies}\ |
||||
-setup { |
||||
set result "" |
||||
punk::console::ensure_object_integration |
||||
lassign [socketpair] local far |
||||
#simulated remote terminal (100x30): answer any CSI 6n cursor-position |
||||
#request as if the cursor sits at row 30, col 100 (the provider's move-to- |
||||
#large-position size probe) |
||||
chan event $far readable [list apply {{ch} { |
||||
set data [read $ch] |
||||
if {[string first "\x1b\[6n" $data] >= 0} { |
||||
puts -nonewline $ch "\x1b\[30;100R" |
||||
flush $ch |
||||
} |
||||
}} $far] |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::SshConsole::new $local $local] |
||||
lappend result [::opunk::Console::size $obj] |
||||
}\ |
||||
-cleanup { |
||||
close $far |
||||
close $local |
||||
}\ |
||||
-result [list {columns 100 rows 30}] |
||||
|
||||
test backends_sshconsole_size_default_when_unanswered {SshConsole size falls back to the default size when the far end does not answer (and when can_respond is settled 0 no query is attempted)}\ |
||||
-setup { |
||||
set result "" |
||||
punk::console::ensure_object_integration |
||||
lassign [socketpair] local far |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::SshConsole::new $local $local] |
||||
#settled 0: no emission path at all - must return default immediately |
||||
::opunk::Console::set.o_can_respond obj 0 |
||||
set before [clock millis] |
||||
lappend result [::opunk::Console::size $obj] |
||||
lappend result [expr {([clock millis] - $before) < 400}] |
||||
}\ |
||||
-cleanup { |
||||
close $far |
||||
close $local |
||||
}\ |
||||
-result [list {columns 80 rows 24} 1] |
||||
|
||||
test backends_tkconsole_widget_size_and_eof {TkConsole reports widget character dimensions and backend/destroyed eof}\ |
||||
-constraints tkavailable\ |
||||
-setup { |
||||
set result "" |
||||
set w [text .g001_tkconsole_test -width 100 -height 30] |
||||
}\ |
||||
-body { |
||||
set obj [::opunk::TkConsole::new $w] |
||||
lappend result [lindex $obj 0] |
||||
lappend result [::opunk::Console::terminal_class $obj] |
||||
lappend result [::opunk::Console::size $obj] |
||||
lappend result [::opunk::Console::is_console_or_tty $obj] |
||||
lappend result [::opunk::Console::can_respond $obj] |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
#backend eof marker |
||||
::opunk::console::tk::set_eof $w |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
::opunk::console::tk::set_eof $w 0 |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
#widget destruction |
||||
destroy $w |
||||
lappend result [::opunk::Console::at_eof $obj] |
||||
}\ |
||||
-cleanup { |
||||
catch {destroy $w} |
||||
catch {unset ::opunk::console::tk::eof_flags($w)} |
||||
}\ |
||||
-result [list ::opunk::TkConsole tk-text {columns 100 rows 30} 1 1 0 1 0 1] |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
Loading…
Reference in new issue