Browse Source
Multi-process mode previously execd bare test files with no environment (children died on their first package require) and misreported the crashes as missing-cleanupTests warnings with the stderr discarded. - testsupport/child_test_runner.tcl (new): per-file child bootstrap. Applies a runtests-generated environment payload (prefer latest, test tm paths, auto_path, modpod ifneeded defs, tcltest options; per-file -testdir computed child-side), warms 'clock format' before the module-path wipe (first script-level clock use loads msgcat from the runtime default paths, which the test paths do not supply), and mirrors the testinterp preload: package require shellrun plus one no-op runx -tcl call (runx execution pulls punk::lib; several suites depend on preloaded punk::* commands). - runtests.tcl: generate the payload per run; spawn children via plain exec with file-captured stdout/stderr and immediate-EOF stdin (mechanism reusable for future parallel -jobs scheduling); classify nonzero child exits as file-level failures with the stderr tail surfaced in all report styles (exit-0-no-summary remains the missing-cleanupTests warning); warn under kit executables (children boot with kit-stamped punk packages preloaded, shadowing src dev modules - prefer a native tclsh). - scriptlib/developer/runtests_parity.tcl (new): compares two '-report json' captures on result identity (per-file counts, failure/skip/warning identities; timings ignored), tolerating preamble noise and the ANSI SGR reset emitted on the JSON line. Verified on native tclsh 9.0.3: full suite singleproc vs multiproc PARITY ok (87 files, 989 tests, 973/15/1 with the documented exec-14.3 baseline as the sole failure); crash and warning classification exercised. Wall time ~5m50s in both modes. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
5 changed files with 583 additions and 32 deletions
@ -0,0 +1,326 @@
|
||||
#runtests_parity.tcl - compare two 'src/tests/runtests.tcl -report json' outputs for result parity. |
||||
#(agent-authored developer utility, 2026-07-18 - created for the -singleproc 0 multi-process |
||||
# runner completion: verifies per-file result parity between runner modes/interpreters/contexts) |
||||
# |
||||
#Usage: |
||||
# tclsh scriptlib/developer/runtests_parity.tcl <a.json> <b.json> |
||||
# |
||||
#Each input file is the captured stdout of a runtests.tcl run with -report json (or |
||||
#markdown+json): the last line starting with {"runner" is taken as the report, so preamble |
||||
#lines (argv echo, package-load warnings) and fenced markdown context are tolerated. |
||||
# |
||||
#Compared (deterministic result identity): |
||||
# - top-level status and total/passed/skipped/failed tallies |
||||
# - the set of test file paths |
||||
# - per file: status, total/passed/skipped/failed, failure identities (name+status), |
||||
# skip identities (name+reason), warning codes |
||||
#Ignored (expected to vary between runs/modes): microseconds, the slowest list, |
||||
#observed_* event counts. |
||||
# |
||||
#Exit codes: 0 = parity, 1 = differences found, 2 = usage or parse error. |
||||
#No package dependencies (runs under any tclsh 8.6+); contains a minimal JSON parser |
||||
#sufficient for the runner's machine-generated report format. |
||||
|
||||
namespace eval jsonlite { |
||||
variable str "" |
||||
variable pos 0 |
||||
variable len 0 |
||||
|
||||
proc parse {text} { |
||||
variable str $text |
||||
variable pos 0 |
||||
variable len [string length $text] |
||||
return [parse_value] |
||||
} |
||||
proc fail {msg} { |
||||
variable pos |
||||
return -code error "jsonlite parse error at offset $pos: $msg" |
||||
} |
||||
proc skip_ws {} { |
||||
variable str |
||||
variable pos |
||||
variable len |
||||
while {$pos < $len && [string index $str $pos] in [list " " \t \n \r]} { |
||||
incr pos |
||||
} |
||||
} |
||||
proc parse_value {} { |
||||
variable str |
||||
variable pos |
||||
variable len |
||||
skip_ws |
||||
if {$pos >= $len} { |
||||
fail "unexpected end of input" |
||||
} |
||||
switch -- [string index $str $pos] { |
||||
\{ {return [parse_object]} |
||||
\[ {return [parse_array]} |
||||
\" {return [parse_string]} |
||||
t { |
||||
if {[string range $str $pos $pos+3] ne "true"} {fail "bad literal"} |
||||
incr pos 4 |
||||
return 1 |
||||
} |
||||
f { |
||||
if {[string range $str $pos $pos+4] ne "false"} {fail "bad literal"} |
||||
incr pos 5 |
||||
return 0 |
||||
} |
||||
n { |
||||
if {[string range $str $pos $pos+3] ne "null"} {fail "bad literal"} |
||||
incr pos 4 |
||||
return "" |
||||
} |
||||
default {return [parse_number]} |
||||
} |
||||
} |
||||
proc parse_object {} { |
||||
variable str |
||||
variable pos |
||||
incr pos ;#consume open brace |
||||
set d [dict create] |
||||
skip_ws |
||||
if {[string index $str $pos] eq "\}"} { |
||||
incr pos |
||||
return $d |
||||
} |
||||
while 1 { |
||||
skip_ws |
||||
if {[string index $str $pos] ne "\""} {fail "expected object key"} |
||||
set k [parse_string] |
||||
skip_ws |
||||
if {[string index $str $pos] ne ":"} {fail "expected : after object key"} |
||||
incr pos |
||||
dict set d $k [parse_value] |
||||
skip_ws |
||||
switch -- [string index $str $pos] { |
||||
, {incr pos} |
||||
\} {incr pos; return $d} |
||||
default {fail "expected , or \} in object"} |
||||
} |
||||
} |
||||
} |
||||
proc parse_array {} { |
||||
variable str |
||||
variable pos |
||||
incr pos ;#consume open bracket |
||||
set out [list] |
||||
skip_ws |
||||
if {[string index $str $pos] eq "\]"} { |
||||
incr pos |
||||
return $out |
||||
} |
||||
while 1 { |
||||
lappend out [parse_value] |
||||
skip_ws |
||||
switch -- [string index $str $pos] { |
||||
, {incr pos} |
||||
\] {incr pos; return $out} |
||||
default {fail "expected , or \] in array"} |
||||
} |
||||
} |
||||
} |
||||
proc parse_string {} { |
||||
variable str |
||||
variable pos |
||||
variable len |
||||
incr pos ;#consume opening quote |
||||
set out "" |
||||
while {$pos < $len} { |
||||
set q [string first "\"" $str $pos] |
||||
set b [string first "\\" $str $pos] |
||||
if {$q < 0} { |
||||
fail "unterminated string" |
||||
} |
||||
if {$b < 0 || $q < $b} { |
||||
append out [string range $str $pos [expr {$q - 1}]] |
||||
set pos [expr {$q + 1}] |
||||
return $out |
||||
} |
||||
append out [string range $str $pos [expr {$b - 1}]] |
||||
set pos [expr {$b + 1}] |
||||
set e [string index $str $pos] |
||||
switch -- $e { |
||||
\" {append out \"} |
||||
\\ {append out \\} |
||||
/ {append out /} |
||||
b {append out \b} |
||||
f {append out \f} |
||||
n {append out \n} |
||||
r {append out \r} |
||||
t {append out \t} |
||||
u { |
||||
set hex [string range $str $pos+1 $pos+4] |
||||
if {[string length $hex] != 4 || ![string is xdigit -strict $hex]} { |
||||
fail "bad unicode escape" |
||||
} |
||||
scan $hex %x cp |
||||
append out [format %c $cp] |
||||
incr pos 4 |
||||
} |
||||
default {fail "bad escape sequence \\$e"} |
||||
} |
||||
incr pos |
||||
} |
||||
fail "unterminated string" |
||||
} |
||||
proc parse_number {} { |
||||
variable str |
||||
variable pos |
||||
variable len |
||||
set start $pos |
||||
while {$pos < $len && [string index $str $pos] in [list - + . e E 0 1 2 3 4 5 6 7 8 9]} { |
||||
incr pos |
||||
} |
||||
set numtext [string range $str $start [expr {$pos - 1}]] |
||||
if {$numtext eq "" || ![string is double -strict $numtext]} { |
||||
fail "bad number '$numtext'" |
||||
} |
||||
return $numtext |
||||
} |
||||
} |
||||
|
||||
proc load_report {filename} { |
||||
if {![file exists $filename]} { |
||||
puts stderr "runtests_parity: file not found: $filename" |
||||
exit 2 |
||||
} |
||||
set fd [open $filename r] |
||||
set data [read $fd] |
||||
close $fd |
||||
#the report is the last line containing the open-brace+"runner": marker. The marker may |
||||
#not be at line start: the runner's punk ANSI output stack can emit an SGR reset sequence |
||||
#on the same line immediately before the JSON, and other preamble/noise lines may precede it. |
||||
set marker "\{\"runner\":" |
||||
set report_line "" |
||||
foreach ln [split $data \n] { |
||||
set idx [string first $marker $ln] |
||||
if {$idx >= 0} { |
||||
set report_line [string trimright [string range $ln $idx end] \r] |
||||
} |
||||
} |
||||
if {$report_line eq ""} { |
||||
puts stderr "runtests_parity: no runtests JSON report line (containing \{\"runner\":) found in $filename" |
||||
exit 2 |
||||
} |
||||
if {[catch {jsonlite::parse $report_line} report]} { |
||||
puts stderr "runtests_parity: could not parse JSON report in $filename: $report" |
||||
exit 2 |
||||
} |
||||
return $report |
||||
} |
||||
|
||||
proc filemap {report} { |
||||
set m [dict create] |
||||
foreach tf [dict get $report testfiles] { |
||||
dict set m [dict get $tf path] $tf |
||||
} |
||||
return $m |
||||
} |
||||
|
||||
proc failure_sigs {tf} { |
||||
set sigs [list] |
||||
foreach f [dict get $tf failures] { |
||||
lappend sigs "[dict get $f name] status=[dict get $f status]" |
||||
} |
||||
return [lsort $sigs] |
||||
} |
||||
|
||||
proc skip_sigs {tf} { |
||||
set sigs [list] |
||||
foreach s [dict get $tf skips] { |
||||
lappend sigs "[dict get $s name] reason=[dict get $s reason]" |
||||
} |
||||
return [lsort $sigs] |
||||
} |
||||
|
||||
proc warning_sigs {tf} { |
||||
set sigs [list] |
||||
foreach w [dict get $tf warnings] { |
||||
lappend sigs [dict get $w code] |
||||
} |
||||
return [lsort $sigs] |
||||
} |
||||
|
||||
proc list_diff_lines {label lista listb} { |
||||
set lines [list] |
||||
foreach item $lista { |
||||
if {$item ni $listb} { |
||||
lappend lines " $label only in A: $item" |
||||
} |
||||
} |
||||
foreach item $listb { |
||||
if {$item ni $lista} { |
||||
lappend lines " $label only in B: $item" |
||||
} |
||||
} |
||||
return $lines |
||||
} |
||||
|
||||
lassign $argv filea fileb |
||||
if {$filea eq "" || $fileb eq "" || [llength $argv] != 2} { |
||||
puts stderr "usage: tclsh runtests_parity.tcl <a.json> <b.json>" |
||||
puts stderr " where each file is captured stdout of: <tclsh> src/tests/runtests.tcl -report json ..." |
||||
exit 2 |
||||
} |
||||
|
||||
set ra [load_report $filea] |
||||
set rb [load_report $fileb] |
||||
|
||||
set diffs [list] |
||||
foreach k {status total passed skipped failed} { |
||||
set va [dict get $ra $k] |
||||
set vb [dict get $rb $k] |
||||
if {$va ne $vb} { |
||||
lappend diffs "top-level $k: A=$va B=$vb" |
||||
} |
||||
} |
||||
|
||||
set ma [filemap $ra] |
||||
set mb [filemap $rb] |
||||
foreach path [dict keys $ma] { |
||||
if {![dict exists $mb $path]} { |
||||
lappend diffs "file only in A: $path" |
||||
} |
||||
} |
||||
foreach path [dict keys $mb] { |
||||
if {![dict exists $ma $path]} { |
||||
lappend diffs "file only in B: $path" |
||||
} |
||||
} |
||||
|
||||
foreach path [dict keys $ma] { |
||||
if {![dict exists $mb $path]} { |
||||
continue |
||||
} |
||||
set tfa [dict get $ma $path] |
||||
set tfb [dict get $mb $path] |
||||
set flines [list] |
||||
foreach k {status total passed skipped failed} { |
||||
set va [dict get $tfa $k] |
||||
set vb [dict get $tfb $k] |
||||
if {$va ne $vb} { |
||||
lappend flines " $k: A=$va B=$vb" |
||||
} |
||||
} |
||||
lappend flines {*}[list_diff_lines failure [failure_sigs $tfa] [failure_sigs $tfb]] |
||||
lappend flines {*}[list_diff_lines skip [skip_sigs $tfa] [skip_sigs $tfb]] |
||||
lappend flines {*}[list_diff_lines warning [warning_sigs $tfa] [warning_sigs $tfb]] |
||||
if {[llength $flines]} { |
||||
lappend diffs "file $path:" |
||||
lappend diffs {*}$flines |
||||
} |
||||
} |
||||
|
||||
puts "runtests parity comparison" |
||||
puts "A: $filea" |
||||
puts "B: $fileb" |
||||
if {[llength $diffs] == 0} { |
||||
puts "PARITY: ok (files=[llength [dict keys $ma]] total=[dict get $ra total] passed=[dict get $ra passed] skipped=[dict get $ra skipped] failed=[dict get $ra failed])" |
||||
exit 0 |
||||
} |
||||
foreach d $diffs { |
||||
puts "- $d" |
||||
} |
||||
puts "PARITY: DIFFERS ([llength $diffs] difference lines)" |
||||
exit 1 |
||||
@ -0,0 +1,82 @@
|
||||
#child_test_runner.tcl - child-process bootstrap for src/tests/runtests.tcl multi-process mode |
||||
#(-tcltestoptions {-singleproc 0}). |
||||
#Invoked as: <tcl_interpreter> child_test_runner.tcl <payloadfile> <testfile> ?<childtmpdir>? |
||||
#The payload file is generated per run by runtests.tcl and applies the parent-computed test |
||||
#environment in the singleproc-testinterp order: package prefer latest, tcl::tm test paths, |
||||
#auto_path, modpod 'package ifneeded' definitions, and the base tcltest options in |
||||
#::runtests_child_tcltestoptions. |
||||
#The optional childtmpdir argument overrides tcltest -tmpdir per child (parallel scheduling); |
||||
#empty/absent means the shared -tmpdir carried in the payload options is used. |
||||
#Exit codes: 0 = test file ran to completion (tcltest failures are reported via the tcltest |
||||
#output stream, not the exit code - matching tcltest single-file semantics); nonzero = the test |
||||
#file (or this bootstrap) died, which runtests.tcl classifies as a file-level failure with the |
||||
#stderr tail surfaced; 98 = bootstrap usage/environment error. |
||||
#Not a test suite: runtests.tcl discovery excludes *.tcl under src/tests. |
||||
|
||||
#Initialize process-level clock/timezone state while the DEFAULT module paths are still in place. |
||||
#The first script-level 'clock format' pulls in msgcat (and tzdata) from the runtime's own module |
||||
#paths; the payload wipes those paths and nothing under the test module paths supplies msgcat. |
||||
#The singleproc testinterp is shielded from this only because the runtests parent process uses |
||||
#'clock format' under default paths before running test files (process-wide C-level caches) - a |
||||
#fresh child process must warm up explicitly or e.g zipper.test fails with |
||||
#"can't find package msgcat" out of clock format. |
||||
clock format [clock seconds] |
||||
|
||||
lassign $argv payloadfile testfile childtmpdir |
||||
if {$payloadfile eq "" || ![file exists $payloadfile]} { |
||||
puts stderr "child_test_runner.tcl: payload file not found: '$payloadfile'" |
||||
exit 98 |
||||
} |
||||
if {$testfile eq ""} { |
||||
puts stderr "child_test_runner.tcl: no test file supplied" |
||||
exit 98 |
||||
} |
||||
set testfile [file normalize $testfile] |
||||
if {![file exists $testfile]} { |
||||
puts stderr "child_test_runner.tcl: test file not found: '$testfile'" |
||||
exit 98 |
||||
} |
||||
|
||||
source $payloadfile |
||||
|
||||
if {![info exists ::runtests_child_tcltestoptions]} { |
||||
puts stderr "child_test_runner.tcl: payload did not define ::runtests_child_tcltestoptions" |
||||
exit 98 |
||||
} |
||||
set tcltestoptions $::runtests_child_tcltestoptions |
||||
#-testdir is per test file (mirrors the per-file -testdir the runtests loop sets in singleproc mode) |
||||
dict set tcltestoptions -testdir [file dirname $testfile] |
||||
if {$childtmpdir ne ""} { |
||||
dict set tcltestoptions -tmpdir $childtmpdir |
||||
} |
||||
|
||||
#mirror the singleproc testinterp setup: ::argv holds the tcltest options and tcltest is not |
||||
#package required until ::argv is in place (see the note at the bottom of runtests.tcl - |
||||
#tcltest examines ::argv itself). The explicit tcltest::configure call below also disarms |
||||
#tcltest's argv auto-processing traces, so the options cannot be double-applied. |
||||
set ::argv0 $testfile |
||||
set ::argv $tcltestoptions |
||||
set ::argc [llength $tcltestoptions] |
||||
package require tcltest |
||||
tcltest::configure {*}$tcltestoptions |
||||
|
||||
#mirror the singleproc testinterp preload: runtests.tcl package requires shellrun into the |
||||
#testinterp after tcltest configure, and several existing suites use punk::* commands without |
||||
#an explicit package require of their own - they depend on this preload supplying them |
||||
#(e.g punk::ansi::ansistrip in the modules/punk/ansi suites; 17 files / 97 tests error without |
||||
#it, verified 2026-07-18 with scriptlib/developer/runtests_parity.tcl). Keeping the child |
||||
#identical to the testinterp preserves result parity. Making suite dependencies explicit and |
||||
#dropping this preload for leaner/faster children is a candidate future cleanup - the parity |
||||
#tool is the check for it. |
||||
package require shellrun |
||||
#The testinterp sources each test file via 'shellrun::runx -tcl source <file>', and executing |
||||
#runx pulls in further runtime dependencies that plain 'package require shellrun' does not |
||||
#(currently punk::lib - without it 7 files / 31 tests error: the punk::lib suites plus |
||||
#punk::ansi::grepstr/untabify and punk::args examples rendering, which call punk::lib |
||||
#internally). Exercise one no-op runx -tcl call so the child acquires exactly whatever the |
||||
#testinterp's runx-driven load acquires, now and under future shellrun changes. |
||||
shellrun::runx -tcl set ::runtests_child_warmed 1 |
||||
|
||||
source $testfile |
||||
#natural end-of-script exit: code 0. An uncaught error from the test file propagates, prints |
||||
#errorInfo to stderr and exits nonzero - runtests.tcl reports that as a file-level failure. |
||||
Loading…
Reference in new issue