Browse Source
- new punkexe suite (17 tests): dispatch contract (script-arg argv0/argv/ info-script state, honest exit codes, piped no-arg eval, stock arg forms, lib: refusal) plus the piperepl launch-state contract on patched kits (istty/dorepl/evalinput published, piped script-arg state all-zero, unconsumed-piped-input safety default, evalinput opt-in ordering, script consuming stdin itself) and the unpatched degraded-mode notice - hang rule baked in: no test or fixture may set ::tclsh(dorepl) (the console-reopen path blocks under a piped harness; G-106-recipe territory) - patched-kit resolution: env PUNK_PIPEREPL_TEST_EXE, else the punkexe if it probes patched, else bin/punk9_beta.exe / punk9bi_beta.exe - encoding coverage is byte-level (utf-8 vs iso8859-1 fixture; [format %c 233] keeps the .test file pure ascii, runner-encoding-proof) - patches/README.md: corrected the tcl_interactive divergence note (console script-arg runs READ 1 where stock reads 0 - piped launches identical; the early link stays load-bearing for the piped prompt opt-in) and recorded the '? reopen stdin from console' stdout residue as known - shell/AGENTS.md: tclshcmd bullet; stale runtime.bash names corrected to punk-runtime.bash/punk-runtime.cmd Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
3 changed files with 398 additions and 4 deletions
@ -0,0 +1,386 @@ |
|||||||
|
package require tcltest |
||||||
|
|
||||||
|
#Tests for the built punk executable's 'tclsh' subcommand (punk_main.tcl dispatch). |
||||||
|
#Covers two layers: |
||||||
|
# - dispatch contract (any punk kit): script-file sourcing with argv0/argv/info-script |
||||||
|
# state, piped-stdin evaluation when no script argument is given, honest exit codes |
||||||
|
# (script error, explicit exit code, piped-input error), stock tclsh argument forms |
||||||
|
# (leading '-' arg means no script - all args stay in ::argv; '-encoding name file' |
||||||
|
# sources with the named encoding; incomplete -encoding forms fall through to argv), |
||||||
|
# and the lib: refusal (scriptlib resolution is a punk facility - the subcommand keeps |
||||||
|
# plain tclsh semantics and points at the 'script' subcommand, exit 1). |
||||||
|
# - piperepl launch-state contract (kits built on a TCLSH_PIPEREPL-patched runtime, |
||||||
|
# G-096/G-103 - see src/buildsuites/suite_tcl90/patches/README.md): ::tclsh(istty) |
||||||
|
# published as the launch-time stdin-tty fact, script-arg piped launch state |
||||||
|
# (istty 0, tcl_interactive 0, dorepl 0, evalinput 0), unconsumed piped input NOT |
||||||
|
# evaluated by default (safety default), ::tclsh(evalinput) opt-in evaluating |
||||||
|
# leftover input after the script, and the script's right to consume stdin itself. |
||||||
|
# |
||||||
|
#HANG SAFETY: no test or fixture ever sets ::tclsh(dorepl) - that is the console-reopen |
||||||
|
#path (stdin reopened from CONIN$ at eof), which blocks on a real console and cannot be |
||||||
|
#driven by this piped harness (needs the hidden-console/WriteConsoleInput recipe, G-106). |
||||||
|
#All children here terminate at stdin EOF by construction; punk_run force-kills on |
||||||
|
#timeout regardless. |
||||||
|
# |
||||||
|
#Dispatch tests target the standard punkexe: env(PUNK_SHELL_TEST_EXE), else |
||||||
|
#<projectroot>/bin/punk902z.exe, else <projectroot>/bin/punkshell902 (constraint |
||||||
|
#punkexeavailable). Piperepl tests target a patched kit: env(PUNK_PIPEREPL_TEST_EXE) |
||||||
|
#if it probes as patched, else the punkexe if patched, else the first patched candidate |
||||||
|
#of bin/punk9_beta.exe, bin/punk9bi_beta.exe (constraint pipereplkitavailable; probe = |
||||||
|
#piped no-arg run checking [info exists ::tclsh(istty)], the G-103 family_check |
||||||
|
#discriminator). Constraint pipereplmissing covers the degraded-mode notice on kits |
||||||
|
#whose runtime lacks the patch. |
||||||
|
# |
||||||
|
#NOTE: exercises BUILT executables - after changing the tclsh dispatch in |
||||||
|
#src/vfs/_config/punk_main.tcl, rebuild the kit under test ('make.tcl project' for the |
||||||
|
#standard punkexe; family kits like punk9_beta come from src/buildsuites wrap runs) or |
||||||
|
#these tests run against a stale binary. |
||||||
|
|
||||||
|
namespace eval ::testspace { |
||||||
|
namespace import ::tcltest::* |
||||||
|
|
||||||
|
variable testdir [file dirname [file normalize [info script]]] |
||||||
|
#<projectroot>/src/tests/shell/testsuites/punkexe -> 5 levels up to <projectroot> |
||||||
|
variable projectroot [file normalize [file join $testdir .. .. .. .. ..]] |
||||||
|
|
||||||
|
variable punkexe "" |
||||||
|
if {[info exists ::env(PUNK_SHELL_TEST_EXE)] && $::env(PUNK_SHELL_TEST_EXE) ne ""} { |
||||||
|
set punkexe [file normalize $::env(PUNK_SHELL_TEST_EXE)] |
||||||
|
} else { |
||||||
|
foreach candidate [list [file join $projectroot bin punk902z.exe] [file join $projectroot bin punkshell902]] { |
||||||
|
if {[file exists $candidate]} { |
||||||
|
set punkexe $candidate |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
testConstraint punkexeavailable [expr {$punkexe ne "" && [file exists $punkexe]}] |
||||||
|
|
||||||
|
variable punk_run_timeout_ms 15000 |
||||||
|
|
||||||
|
variable runstate |
||||||
|
array set runstate {} |
||||||
|
|
||||||
|
proc punk_run_read {chan} { |
||||||
|
variable runstate |
||||||
|
append runstate(output) [read $chan] |
||||||
|
if {[chan eof $chan]} { |
||||||
|
chan event $chan readable {} |
||||||
|
set runstate(done) eof |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#Run the target executable with args, feed stdin_data via pipe then half-close (EOF). |
||||||
|
#Returns dict: timedout 0|1, exitcode <int|kill-info|"">, output <combined stdout+stderr>. |
||||||
|
#On timeout the process (and any pipeline members) are forcibly killed so the suite cannot hang. |
||||||
|
#No PUNK_PIPE_EOF here - the tclsh subcommand has no eof-policy env; children terminate at |
||||||
|
#stdin EOF because nothing in this suite sets ::tclsh(dorepl) (see HANG SAFETY above). |
||||||
|
proc punk_run {exe cmdargs stdin_data} { |
||||||
|
variable runstate |
||||||
|
variable punk_run_timeout_ms |
||||||
|
array unset runstate |
||||||
|
set runstate(output) "" |
||||||
|
set runstate(done) "" |
||||||
|
|
||||||
|
set chan [open |[list $exe {*}$cmdargs 2>@1] r+] |
||||||
|
set pids [pid $chan] |
||||||
|
chan configure $chan -blocking 0 -translation binary |
||||||
|
catch { |
||||||
|
puts -nonewline $chan $stdin_data |
||||||
|
flush $chan |
||||||
|
chan close $chan write ;#half-close - child sees EOF on stdin |
||||||
|
} |
||||||
|
set timerid [after $punk_run_timeout_ms [list set [namespace current]::runstate(done) timeout]] |
||||||
|
chan event $chan readable [list [namespace current]::punk_run_read $chan] |
||||||
|
while {$runstate(done) eq ""} { |
||||||
|
vwait [namespace current]::runstate(done) |
||||||
|
} |
||||||
|
after cancel $timerid |
||||||
|
chan event $chan readable {} |
||||||
|
|
||||||
|
set timedout [expr {$runstate(done) eq "timeout"}] |
||||||
|
set exitcode "" |
||||||
|
if {$timedout} { |
||||||
|
foreach p $pids { |
||||||
|
if {$::tcl_platform(platform) eq "windows"} { |
||||||
|
catch {exec {*}[auto_execok taskkill] /F /PID $p} |
||||||
|
} else { |
||||||
|
catch {exec kill -9 $p} |
||||||
|
} |
||||||
|
} |
||||||
|
catch {close $chan} |
||||||
|
} else { |
||||||
|
catch {chan configure $chan -blocking 1} |
||||||
|
if {[catch {close $chan} errmsg erropts]} { |
||||||
|
set ecode [dict get $erropts -errorcode] |
||||||
|
switch -- [lindex $ecode 0] { |
||||||
|
CHILDSTATUS { set exitcode [lindex $ecode 2] } |
||||||
|
default { set exitcode $ecode } |
||||||
|
} |
||||||
|
} else { |
||||||
|
set exitcode 0 |
||||||
|
} |
||||||
|
} |
||||||
|
return [dict create timedout $timedout exitcode $exitcode output $runstate(output)] |
||||||
|
} |
||||||
|
|
||||||
|
#Classify a kit's tclsh subcommand via a piped no-arg run (terminates at EOF on every |
||||||
|
#known dispatch version; never sets dorepl): |
||||||
|
# machinery - piperepl-patched runtime, ::tclsh machinery published |
||||||
|
# evalok - unpatched runtime, but piped no-arg stdin evaluation works |
||||||
|
# noeval - piped stdin was not evaluated (pre-else-branch kit or launch failure) |
||||||
|
variable piperepl_probe_script [string cat {puts [list PRPROBE [info exists ::tclsh(istty)]]} \n] |
||||||
|
proc piperepl_probe {exe} { |
||||||
|
variable piperepl_probe_script |
||||||
|
set rd [punk_run $exe [list tclsh] $piperepl_probe_script] |
||||||
|
if {[dict get $rd timedout]} { |
||||||
|
return noeval |
||||||
|
} |
||||||
|
if {[string first "PRPROBE 1" [dict get $rd output]] >= 0} { |
||||||
|
return machinery |
||||||
|
} |
||||||
|
if {[string first "PRPROBE 0" [dict get $rd output]] >= 0} { |
||||||
|
return evalok |
||||||
|
} |
||||||
|
return noeval |
||||||
|
} |
||||||
|
|
||||||
|
variable punkexe_probe noeval |
||||||
|
if {[testConstraint punkexeavailable]} { |
||||||
|
set punkexe_probe [piperepl_probe $punkexe] |
||||||
|
} |
||||||
|
|
||||||
|
variable pipereplexe "" |
||||||
|
if {[info exists ::env(PUNK_PIPEREPL_TEST_EXE)] && $::env(PUNK_PIPEREPL_TEST_EXE) ne ""} { |
||||||
|
set cand [file normalize $::env(PUNK_PIPEREPL_TEST_EXE)] |
||||||
|
if {[file exists $cand] && [piperepl_probe $cand] eq "machinery"} { |
||||||
|
set pipereplexe $cand |
||||||
|
} |
||||||
|
} elseif {$punkexe_probe eq "machinery"} { |
||||||
|
set pipereplexe $punkexe |
||||||
|
} else { |
||||||
|
foreach cand [list [file join $projectroot bin punk9_beta.exe] [file join $projectroot bin punk9bi_beta.exe]] { |
||||||
|
if {[file exists $cand] && [piperepl_probe $cand] eq "machinery"} { |
||||||
|
set pipereplexe $cand |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
testConstraint pipereplkitavailable [expr {$pipereplexe ne ""}] |
||||||
|
testConstraint pipereplmissing [expr {[testConstraint punkexeavailable] && $punkexe_probe eq "evalok"}] |
||||||
|
|
||||||
|
#fixture scripts (tcltest -tmpdir; forward-slash paths - kit script args need them) |
||||||
|
variable fx_dispatch_argv [makeFile {puts [list TARGS argv0tail [file tail $::argv0] argv $::argv scripttail [file tail [info script]] tcli $::tcl_interactive]} dispatch_argv.tcl] |
||||||
|
variable fx_dispatch_err [makeFile {puts TCLSHF-BEFORE-ERR |
||||||
|
error tclshfile-boom} dispatch_err.tcl] |
||||||
|
variable fx_dispatch_exit5 [makeFile {puts TCLSHF-EXIT5-MARK |
||||||
|
exit 5} dispatch_exit5.tcl] |
||||||
|
variable fx_pr_state [makeFile {puts [list PRSCRIPT istty $::tclsh(istty) tcli $::tcl_interactive dorepl $::tclsh(dorepl) evalinput $::tclsh(evalinput)]} pr_state.tcl] |
||||||
|
variable fx_pr_noconsume [makeFile {puts PRNOCON-MARKER} pr_noconsume.tcl] |
||||||
|
variable fx_pr_optin [makeFile {puts PROPTIN-MARKER |
||||||
|
set ::tclsh(evalinput) 1} pr_optin.tcl] |
||||||
|
variable fx_pr_consume [makeFile {set d [read stdin] |
||||||
|
puts "PRGOT:[string trim $d]"} pr_consume.tcl] |
||||||
|
#encoding fixture written with explicit utf-8 control (runner-encoding-proof): a single |
||||||
|
#U+00E9 char as raw utf-8 bytes (0xC3 0xA9) - 1 char sourced via utf-8, 2 via iso8859-1. |
||||||
|
#the char is built with [format %c 233] so this .test file stays pure ascii (immune to |
||||||
|
#the runner's source encoding). |
||||||
|
variable fx_enc_utf8 [file join [temporaryDirectory] enc_utf8.tcl] |
||||||
|
apply {{path} { |
||||||
|
set fd [open $path w] |
||||||
|
chan configure $fd -encoding utf-8 |
||||||
|
puts $fd "puts ENCLEN=\[string length \"[format %c 233]\"\]" |
||||||
|
close $fd |
||||||
|
}} $fx_enc_utf8 |
||||||
|
|
||||||
|
variable common { |
||||||
|
set result "" |
||||||
|
} |
||||||
|
|
||||||
|
# -- dispatch contract (any punk kit) ---------------------------------------------------------- |
||||||
|
|
||||||
|
#added 2026-07-23 (agent) - tclsh subcommand dispatch contract (script-arg sourcing, piped eval, exit codes) |
||||||
|
test tclsh_piped_eval {piped no-arg 'tclsh' evaluates stdin and terminates, exitcode 0}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh] "puts TCLSHPIPE-M1\nputs TCLSHPIPE-M2\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "TCLSHPIPE-M1" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [expr {[string first "TCLSHPIPE-M2" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1 0] |
||||||
|
|
||||||
|
test tclsh_piped_error_exitcode {piped no-arg 'tclsh' input error: error text on output, exitcode 1, no hang}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh] "error tclshpipe-boom\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "tclshpipe-boom" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1] |
||||||
|
|
||||||
|
test tclsh_piped_not_interactive {piped no-arg 'tclsh' runs with tcl_interactive 0}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh] "puts \[list TSTATE \$::tcl_interactive\]\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "TSTATE 0" [dict get $rd output]] >= 0}] |
||||||
|
} -result [list 0 1] |
||||||
|
|
||||||
|
test tclsh_script_file_argv {'tclsh <file> a b': argv0/info script = file, argv = remaining args, tcl_interactive 0 (piped launch)}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
variable fx_dispatch_argv |
||||||
|
set rd [punk_run $punkexe [list tclsh $fx_dispatch_argv alpha beta] ""] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first {TARGS argv0tail dispatch_argv.tcl argv {alpha beta} scripttail dispatch_argv.tcl tcli 0} [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
test tclsh_script_error_exitcode {'tclsh <file>' script error: prior output present, error text on output, exitcode 1}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
variable fx_dispatch_err |
||||||
|
set rd [punk_run $punkexe [list tclsh $fx_dispatch_err] ""] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "TCLSHF-BEFORE-ERR" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [expr {[string first "tclshfile-boom" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1 1] |
||||||
|
|
||||||
|
test tclsh_script_exitcode {'tclsh <file>' explicit 'exit 5' propagates exitcode 5}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
variable fx_dispatch_exit5 |
||||||
|
set rd [punk_run $punkexe [list tclsh $fx_dispatch_exit5] ""] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "TCLSHF-EXIT5-MARK" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 5] |
||||||
|
|
||||||
|
# -- stock argument forms: leading dash, -encoding, lib: refusal ------------------------------- |
||||||
|
|
||||||
|
#added 2026-07-23 (agent) - stock leading-dash/-encoding argument forms + lib: pointer refusal (tclsh subcommand) |
||||||
|
test tclsh_dash_args_to_argv {leading '-' arg is not a script: all args stay in ::argv, stdin evaluated (stock parity)}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh - hmm etc blah] "puts \[list DASHARGS \$::argv\]\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "DASHARGS {- hmm etc blah}" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
test tclsh_encoding_applied {'-encoding name file' form: the named encoding is honoured when sourcing}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
variable fx_enc_utf8 |
||||||
|
set a [punk_run $punkexe [list tclsh -encoding utf-8 $fx_enc_utf8] ""] |
||||||
|
set b [punk_run $punkexe [list tclsh -encoding iso8859-1 $fx_enc_utf8] ""] |
||||||
|
lappend result [expr {[string first "ENCLEN=1" [dict get $a output]] >= 0}] |
||||||
|
lappend result [expr {[string first "ENCLEN=2" [dict get $b output]] >= 0}] |
||||||
|
lappend result [dict get $a exitcode] |
||||||
|
lappend result [dict get $b exitcode] |
||||||
|
} -result [list 1 1 0 0] |
||||||
|
|
||||||
|
test tclsh_encoding_args_passed {'-encoding name file a b': script argv0/argv state as with the plain file form}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
variable fx_dispatch_argv |
||||||
|
set rd [punk_run $punkexe [list tclsh -encoding utf-8 $fx_dispatch_argv alpha beta] ""] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first {TARGS argv0tail dispatch_argv.tcl argv {alpha beta} scripttail dispatch_argv.tcl tcli 0} [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
test tclsh_encoding_incomplete_form {'-encoding name' with no script name following: all args stay in ::argv (stock parity)}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh -encoding utf-8] "puts \[list ENCARGV \$::argv\]\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "ENCARGV {-encoding utf-8}" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
test tclsh_lib_pointer {'tclsh lib:...' refuses with a pointer to the script subcommand, exit 1, nothing sourced}\ |
||||||
|
-constraints punkexeavailable -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh lib:_punktest/echo alpha] ""] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "not supported by the tclsh subcommand" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [expr {[string first "script lib:_punktest/echo" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [expr {[string first "PUNKTEST_ECHO" [dict get $rd output]] < 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1 1 1] |
||||||
|
|
||||||
|
# -- piperepl launch-state contract (patched runtime kits) ------------------------------------- |
||||||
|
|
||||||
|
#added 2026-07-23 (agent) - piperepl ::tclsh launch-state contract via the tclsh subcommand (G-096/G-103 patched kits) |
||||||
|
test tclsh_pr_noarg_machinery {piped no-arg run publishes ::tclsh machinery: istty 0, dorepl 0, evalinput 0}\ |
||||||
|
-constraints pipereplkitavailable -setup $common -body { |
||||||
|
variable pipereplexe |
||||||
|
set rd [punk_run $pipereplexe [list tclsh] "puts \[list PRSTATE \[info exists ::tclsh(istty)\] \$::tclsh(istty) \$::tclsh(dorepl) \$::tclsh(evalinput)\]\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "PRSTATE 1 0 0 0" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
test tclsh_pr_scriptarg_state {piped 'tclsh <file>' launch state: istty 0, tcl_interactive 0, dorepl 0, evalinput 0}\ |
||||||
|
-constraints pipereplkitavailable -setup $common -body { |
||||||
|
variable pipereplexe |
||||||
|
variable fx_pr_state |
||||||
|
set rd [punk_run $pipereplexe [list tclsh $fx_pr_state] ""] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "PRSCRIPT istty 0 tcli 0 dorepl 0 evalinput 0" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
test tclsh_pr_unconsumed_not_evald {piped input a script did not consume is NOT evaluated by default (safety default)}\ |
||||||
|
-constraints pipereplkitavailable -setup $common -body { |
||||||
|
variable pipereplexe |
||||||
|
variable fx_pr_noconsume |
||||||
|
set rd [punk_run $pipereplexe [list tclsh $fx_pr_noconsume] "puts PRSHOULDNOTEVAL\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "PRNOCON-MARKER" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [expr {[string first "PRSHOULDNOTEVAL" [dict get $rd output]] < 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1 0] |
||||||
|
|
||||||
|
test tclsh_pr_evalinput_optin {script setting ::tclsh(evalinput) 1: leftover piped input evaluated after the script}\ |
||||||
|
-constraints pipereplkitavailable -setup $common -body { |
||||||
|
variable pipereplexe |
||||||
|
variable fx_pr_optin |
||||||
|
set rd [punk_run $pipereplexe [list tclsh $fx_pr_optin] "puts PREVALLED\n"] |
||||||
|
set out [dict get $rd output] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "PROPTIN-MARKER" $out] >= 0}] |
||||||
|
lappend result [expr {[string first "PREVALLED" $out] >= 0}] |
||||||
|
#leftover input runs AFTER the script completes |
||||||
|
lappend result [expr {[string first "PROPTIN-MARKER" $out] < [string first "PREVALLED" $out]}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1 1 0] |
||||||
|
|
||||||
|
test tclsh_pr_script_consumes_stdin {the script may read piped stdin itself; consumed data is not evaluated}\ |
||||||
|
-constraints pipereplkitavailable -setup $common -body { |
||||||
|
variable pipereplexe |
||||||
|
variable fx_pr_consume |
||||||
|
set rd [punk_run $pipereplexe [list tclsh $fx_pr_consume] "pr-hello-data\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "PRGOT:pr-hello-data" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 0] |
||||||
|
|
||||||
|
# -- degraded mode (kit runtime without the piperepl patch) ------------------------------------ |
||||||
|
|
||||||
|
#added 2026-07-23 (agent) - degraded-mode contract: unpatched runtime still evaluates piped input, with a patch-missing notice |
||||||
|
test tclsh_unpatched_notice_and_eval {unpatched runtime: piped no-arg eval still works, with a piperepl notice on stderr}\ |
||||||
|
-constraints pipereplmissing -setup $common -body { |
||||||
|
variable punkexe |
||||||
|
set rd [punk_run $punkexe [list tclsh] "puts TCLSHUNP-MARK\n"] |
||||||
|
lappend result [dict get $rd timedout] |
||||||
|
lappend result [expr {[string first "TCLSHUNP-MARK" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [expr {[string first "piperepl" [dict get $rd output]] >= 0}] |
||||||
|
lappend result [dict get $rd exitcode] |
||||||
|
} -result [list 0 1 1 0] |
||||||
|
|
||||||
|
} |
||||||
|
tcltest::cleanupTests ;#needed to produce test summary. |
||||||
Loading…
Reference in new issue