You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
125 lines
6.6 KiB
125 lines
6.6 KiB
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- |
|
|
|
#Tests for G-007 choke-point brokering: a terminal query (internal::get_ansi_response_payload |
|
#and every query proc layered above it) on the process-default console {stdin stdout} routes |
|
#to the console-owning thread when the caller is not the owner; an unregistered console, an |
|
#owner==caller console, and any non-default {in out} pair operate locally (non-std channel |
|
#names are thread-local, so a pair spec always names the calling thread's own console). |
|
#The routing decision is internal::console_route_owner; the transport is a synchronous |
|
#thread::send into the owning thread's main interp (the established vt52-alias property: |
|
#the owner services events while the caller blocks). |
|
|
|
namespace eval ::testspace { |
|
namespace import ::tcltest::* |
|
|
|
variable common { |
|
set result "" |
|
} |
|
|
|
test routing_decision {console_route_owner: local for unregistered/self-owned/non-default/dead-owner; owner tid only for the default console owned by another live thread}\ |
|
-setup [string cat $common { |
|
set workertid [thread::create {thread::wait}] |
|
}]\ |
|
-body { |
|
#unregistered default console - operate locally |
|
lappend result [punk::console::internal::console_route_owner {stdin stdout}] |
|
#caller is the owner - local fast path |
|
punk::console::console_owner_register {stdin stdout} |
|
lappend result [punk::console::internal::console_route_owner {stdin stdout}] |
|
punk::console::console_owner_forget {stdin stdout} |
|
#another live thread owns the default console - route to it |
|
punk::console::console_owner_register {stdin stdout} $workertid |
|
lappend result [expr {[punk::console::internal::console_route_owner {stdin stdout}] eq $workertid}] |
|
#non-default pair never routes, even with a registry entry (the entry qualifies |
|
#the shared fact store; the pair names the calling thread's own channels) |
|
punk::console::console_owner_register {chanx chany} $workertid |
|
lappend result [punk::console::internal::console_route_owner {chanx chany}] |
|
punk::console::console_owner_forget {chanx chany} |
|
#dead owner - consult-time liveness validation clears the entry, operate locally |
|
thread::release $workertid |
|
set deadline [expr {[clock milliseconds] + 2000}] |
|
while {[thread::exists $workertid] && [clock milliseconds] < $deadline} { |
|
after 10 |
|
} |
|
lappend result [punk::console::internal::console_route_owner {stdin stdout}] |
|
}\ |
|
-cleanup { |
|
catch {punk::console::console_owner_forget {stdin stdout}} |
|
catch {punk::console::console_owner_forget {chanx chany}} |
|
catch {thread::release $workertid} |
|
}\ |
|
-result [list\ |
|
{}\ |
|
{}\ |
|
1\ |
|
{}\ |
|
{}\ |
|
] |
|
|
|
test routing_query_forwarded_to_owner {a query on the owned default console executes in the owning thread with opts/values intact; query procs above the choke point inherit the routing; owner-side errors propagate with routing context}\ |
|
-setup [string cat $common { |
|
set workertid [thread::create {thread::wait}] |
|
#the worker loads punk::console from the same module paths as the testinterp |
|
thread::send $workertid [list set ::tmpaths [tcl::tm::list]] |
|
thread::send $workertid [list set ::auto_path $::auto_path] |
|
thread::send $workertid { |
|
foreach p $::tmpaths {tcl::tm::path add $p} |
|
package prefer latest |
|
package require punk::console 999999.0a1.0- |
|
#replace the real query primitive with a recorder: no real terminal is |
|
#available under runtests, and the transport - not the terminal I/O - is |
|
#what this test exercises |
|
rename ::punk::console::internal::get_ansi_response_payload ::punk::console::internal::get_ansi_response_payload.real |
|
set ::routingtest_mode ok |
|
proc ::punk::console::internal::get_ansi_response_payload {args} { |
|
set ::routingtest_seen [list [thread::id] $args] |
|
if {$::routingtest_mode eq "error"} { |
|
error "recorder-failure" |
|
} |
|
return "5;7" |
|
} |
|
} |
|
punk::console::console_owner_register {stdin stdout} $workertid |
|
}]\ |
|
-body { |
|
#direct call on the choke point routes and returns the owner-side result |
|
set payload [punk::console::internal::get_ansi_response_payload -console {stdin stdout} -expected_ms 123 "\x1b\[6n" {(.*)(\x1b\[([0-9]+;[0-9]+)R)$}] |
|
lappend result $payload |
|
lassign [thread::send $workertid {set ::routingtest_seen}] seentid seenargs |
|
#the call executed in the owning thread |
|
lappend result [expr {$seentid eq $workertid}] |
|
#opts and values arrived intact (values are the trailing pair; opts precede them) |
|
lappend result [lrange $seenargs end-1 end] |
|
set seenopts [lrange $seenargs 0 end-2] |
|
lappend result [dict get $seenopts -console] |
|
lappend result [dict get $seenopts -expected_ms] |
|
#a query proc layered above the choke point inherits the routing (get_cursor_pos |
|
#returns the payload unchanged) |
|
lappend result [punk::console::get_cursor_pos] |
|
#an error raised in the owning thread propagates to the caller with routing context |
|
thread::send $workertid {set ::routingtest_mode error} |
|
lappend result [expr {[catch {punk::console::internal::get_ansi_response_payload -console {stdin stdout} "\x1b\[6n" {(.*)(\x1b\[([0-9]+;[0-9]+)R)$}} errM] |
|
&& [string match "*routed to console-owning thread*recorder-failure*" $errM]}] |
|
}\ |
|
-cleanup { |
|
catch {punk::console::console_owner_forget {stdin stdout}} |
|
catch {thread::release $workertid} |
|
}\ |
|
-result [list\ |
|
{5;7}\ |
|
1\ |
|
[list "\x1b\[6n" {(.*)(\x1b\[([0-9]+;[0-9]+)R)$}]\ |
|
{stdin stdout}\ |
|
123\ |
|
{5;7}\ |
|
1\ |
|
] |
|
|
|
} |
|
tcltest::cleanupTests ;#needed to produce test summary.
|
|
|