#!tclsh #This script uses shellfilter::run calls under the hood lassign [split [info tclversion] .] tcl_major tcl_minor set test_base [file dirname [file normalize [info script]]] set test_base_parent [file dirname $test_base] if {[file tail $test_base_parent] eq "src"} { set project_root [file dirname $test_base_parent] } else { set msg "Error: test script is not under a src/ directory: $test_base" append msg \n "To run tests against the built modules, run src/make.tcl packages and then see the modules/test folder within this project" puts stderr $msg exit 2 } #------------------------------------ #For the toplevel script, use the bootsupport modules. set original_tmlist [tcl::tm::list] tcl::tm::remove {*}$original_tmlist tcl::tm::add [file normalize $project_root/src/bootsupport/modules] ;#ie /src/modules tcl::tm::add [file normalize $project_root/src/bootsupport/modules_tcl$tcl_major] tcl::tm::add {*}[lreverse $original_tmlist] package require platform set arch [platform::generic] set libdir [file normalize $project_root/src/bootsupport/lib] if {$libdir ni $::auto_path} { lappend ::auto_path $libdir } set libdir_arch [file normalize $project_root/src/bootsupport/lib/tcl$tcl_major/$arch] if {$libdir_arch ni $::auto_path} { lappend ::auto_path $libdir_arch } #------------------------------------ #Boot in two stages (G-093): discovery-time code needs only punk::args (argdoc/parse) and #punk::path (required by testsupport/discovery.tcl) - the heavy run-phase packages (punk, #Thread, shellrun, punk::tcltestrun) and the testinterp/child path assembly load after the #-discover-only early exit below, keeping 'runtests.tcl -discover-only 1' a fast targeting #inspection tool (boot ~1s instead of ~11s) for humans, agents and the runner-targeting #regression suite (runner/testsuites/discovery/pathdiscovery.test). #Minimum-version floors on the runner's own requires (punk::path has one in #testsupport/discovery.tcl already): their purpose is to REJECT fossilized kit-stamped copies. #Under a punk kit executable, the kit's boot registers its own (possibly ancient) package #versions - an unversioned require satisfiable by such a registration never fires package #unknown, so the freshly-added bootsupport tm path is never even scanned (observed: an old #punk86 kit's punk::args 0.1.0 won the require, then the versioned punk::path 0.4.0- pulled a #modern module whose load needs punk::args::define - invalid command name). A floored require #rejects the fossil and resolves the current bootsupport copy instead. The floors are #feature-era minimums for the runner's argdoc/parse usage, not latest-version pins. package require punk::args 0.12- if {[info commands ::lpop] eq ""} { #Native Tcl 8.6 interpreter: no builtin lpop, which punk::args::parse (and later runner code) #uses. punk::lib installs its validated forward-compat family (lpop, ledit, lremove, ...) as #global aliases whenever the builtins are absent - behavioural parity with the 8.7/9 builtins #is pinned by modules/punk/lib/testsuites/lib/compat.test. Guarded: on Tcl 8.7+/9 this never #runs, preserving the G-093 fast two-stage boot for -discover-only. #(0.5.1- = the parity-validated compat era; also a kit-fossil rejection floor per above.) package require punk::lib 0.5.1- } #test-file discovery + -include-paths/-exclude-paths filtering (G-093) - shared with the #runner-targeting regression suite source [file join $test_base testsupport discovery.tcl] proc runtests_json_string {text} { set text [string map [list \\ \\\\ \" \\\" \n \\n \r \\r \t \\t] $text] return "\"$text\"" } proc runtests_json_string_array {values} { set parts [list] foreach value $values { lappend parts [runtests_json_string $value] } return "\[[join $parts ,]\]" } proc runtests_json_testdict_array {testdicts} { set parts [list] foreach testdict $testdicts { set fields [list] foreach {key value} $testdict { if {[string is entier -strict $value] && $value eq [string trim $value]} { #string is entier accepts surrounding whitespace even with -strict: a #value like "0\n" must take the quoted-string path or the raw newline #lands inside the json line (broke a report when a failed test's #result_was carried a trailing newline - found 2026-07-20, G-093 work) lappend fields "[runtests_json_string $key]:$value" } else { lappend fields "[runtests_json_string $key]:[runtests_json_string $value]" } } lappend parts "{[join $fields ,]}" } return "\[[join $parts ,]\]" } proc runtests_count_dict_entries {value} { if {[llength $value] == 0} { return 0 } return [dict size $value] } proc runtests_dict_get_default {dictvalue key default} { if {[dict exists $dictvalue $key]} { return [dict get $dictvalue $key] } return $default } proc runtests_json_report {status tallydict file_summaries slowest_tests elapsed_seconds} { set files_failed [dict get $tallydict files_with_fails] set files_warned [dict get $tallydict files_with_warnings] set fields [list] lappend fields "\"runner\":\"src/tests/runtests.tcl\"" lappend fields "\"status\":[runtests_json_string $status]" lappend fields "\"elapsed_seconds\":$elapsed_seconds" lappend fields "\"total\":[dict get $tallydict total]" lappend fields "\"passed\":[dict get $tallydict passed]" lappend fields "\"skipped\":[dict get $tallydict skipped]" lappend fields "\"failed\":[dict get $tallydict failed]" lappend fields "\"warnings\":[llength $files_warned]" lappend fields "\"files\":{\"total\":[llength $file_summaries],\"failed\":[runtests_json_string_array $files_failed],\"warnings\":[runtests_json_string_array $files_warned]}" set file_parts [list] foreach file_summary $file_summaries { set file_fields [list] lappend file_fields "\"path\":[runtests_json_string [dict get $file_summary path]]" lappend file_fields "\"status\":[runtests_json_string [dict get $file_summary status]]" lappend file_fields "\"total\":[dict get $file_summary total]" lappend file_fields "\"passed\":[dict get $file_summary passed]" lappend file_fields "\"skipped\":[dict get $file_summary skipped]" lappend file_fields "\"failed\":[dict get $file_summary failed]" lappend file_fields "\"summaryline_detected\":[dict get $file_summary summaryline_detected]" lappend file_fields "\"observed_passes\":[dict get $file_summary observed_passes]" lappend file_fields "\"observed_skips\":[dict get $file_summary observed_skips]" lappend file_fields "\"observed_failures\":[dict get $file_summary observed_failures]" lappend file_fields "\"warnings\":[runtests_json_testdict_array [dict get $file_summary warnings]]" lappend file_fields "\"failures\":[runtests_json_testdict_array [dict get $file_summary failures]]" lappend file_fields "\"skips\":[runtests_json_testdict_array [dict get $file_summary skips]]" lappend file_parts "{[join $file_fields ,]}" } lappend fields "\"testfiles\":\[[join $file_parts ,]\]" lappend fields "\"slowest\":[runtests_json_testdict_array $slowest_tests]" return "{[join $fields ,]}" } proc runtests_status {tallydict} { if {[dict get $tallydict failed] > 0 || [llength [dict get $tallydict files_with_fails]] > 0} { return fail } if {[llength [dict get $tallydict files_with_warnings]] > 0} { return warn } return pass } proc runtests_emit_result_line {status tallydict file_summaries elapsed_seconds} { puts stdout "RUNTESTS_RESULT status=$status total=[dict get $tallydict total] passed=[dict get $tallydict passed] skipped=[dict get $tallydict skipped] failed=[dict get $tallydict failed] warnings=[llength [dict get $tallydict files_with_warnings]] files=[llength $file_summaries] files_failed=[llength [dict get $tallydict files_with_fails]] elapsed_seconds=$elapsed_seconds" } proc runtests_warning_summary {code message summaryline_detected} { return [dict create code $code message $message summaryline_detected $summaryline_detected] } proc runtests_print_file_warning {testfile_relative warning observed_passes observed_skips observed_failures} { puts stdout "### testfile warning for $testfile_relative" puts stdout "" puts stdout "- code: [dict get $warning code] " puts stdout " message: [dict get $warning message] " puts stdout " summaryline_detected: [dict get $warning summaryline_detected] " puts stdout " aggregate_counts: unavailable " puts stdout " observed_passes: $observed_passes " puts stdout " observed_skips: $observed_skips " puts stdout " observed_failures: $observed_failures " puts stdout "" } proc runtests_failure_summaries {resultdict} { set failures [list] dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_fails [dict create]] { set failure [dict create name $testname status [dict get $testdict test_status]] if {[dict exists $testdict errorcode]} { dict set failure errorcode [dict get $testdict errorcode] } if {[dict exists $testdict errorinfo] && [dict get $testdict errorinfo] ne ""} { dict set failure errorinfo [dict get $testdict errorinfo] } if {[dict exists $testdict result_was] && [dict get $testdict result_was] ne ""} { dict set failure result_was [dict get $testdict result_was] } if {[dict exists $testdict result_expected] && [dict get $testdict result_expected] ne ""} { dict set failure result_expected [dict get $testdict result_expected] } lappend failures $failure } return $failures } proc runtests_skip_summaries {resultdict} { set skips [list] dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_constraintskips [dict create]] { lappend skips [dict create name $testname reason [dict get $testdict reason]] } return $skips } proc runtests_pass_summaries {testfile_relative resultdict} { set passes [list] dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_passes [dict create]] { set pass [dict create file $testfile_relative name $testname] if {[dict exists $testdict microseconds]} { dict set pass microseconds [dict get $testdict microseconds] } lappend passes $pass } return $passes } proc runtests_print_failure_details {testfile_relative resultdict} { dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_fails [dict create]] { puts stdout "- testname: $testname " puts stdout " file : $testfile_relative " puts stdout " test_description: [dict get $testdict test_description] " puts stdout " test_body : " puts stdout " ```tcl" puts stdout " [dict get $testdict test_body]" puts stdout " ```" puts stdout " test_status : [dict get $testdict test_status] " if {[dict get $testdict test_status] eq "ERROR"} { puts stdout " returncode : [dict get $testdict returncode] " puts stdout " errorcode : [dict get $testdict errorcode] " if {[dict exists $testdict errorinfo] && [dict get $testdict errorinfo] ne ""} { puts stdout " errorInfo : " puts stdout " ```" puts stdout " [string trimright [dict get $testdict errorinfo]]" puts stdout " ```" } } elseif {[dict get $testdict test_status] eq "FAILED"} { if {[dict exists $testdict result_was] && [dict get $testdict result_was] ne ""} { puts stdout " result_was : " puts stdout " ```" puts stdout " [string trimright [dict get $testdict result_was]]" puts stdout " ```" } if {[dict exists $testdict result_expected] && [dict get $testdict result_expected] ne ""} { puts stdout " result_expected : " puts stdout " ```" puts stdout " [string trimright [dict get $testdict result_expected]]" puts stdout " ```" } } } } proc runtests_compare_microseconds_desc {left right} { set left_usec 0 set right_usec 0 if {[dict exists $left microseconds]} { set left_usec [dict get $left microseconds] } if {[dict exists $right microseconds]} { set right_usec [dict get $right microseconds] } if {$left_usec > $right_usec} { return -1 } if {$left_usec < $right_usec} { return 1 } return 0 } proc runtests_slowest_tests {passes count} { if {$count <= 0} { return [list] } set sorted [lsort -command runtests_compare_microseconds_desc $passes] return [lrange $sorted 0 [expr {$count - 1}]] } proc runtests_print_slowest_tests {slowest_tests show_timings} { puts stdout "### slowest passing tests" puts stdout "" foreach testdict $slowest_tests { set line "- `[dict get $testdict file]` [dict get $testdict name]" if {$show_timings && [dict exists $testdict microseconds]} { append line " microseconds=[dict get $testdict microseconds]" } puts stdout $line } puts stdout "" } proc runtests_text_tail {text maxchars} { #tail of captured child output for failure reports - whole trailing lines, bounded size set text [string trimright $text] if {[string length $text] <= $maxchars} { return $text } set text [string range $text end-[expr {$maxchars - 1}] end] #drop the leading partial line the cut probably produced (bounded scan so a single #enormous line can't defeat the truncation marker) set nl [string first \n $text] if {$nl >= 0 && $nl < 200} { set text [string range $text [expr {$nl + 1}] end] } return "...(truncated)...\n$text" } proc runtests_create_tempdir {nametag} { #'file tempdir' requires tcl 8.7+ - fall back to env temp + tagged pid subdir for 8.6 if {![catch {file tempdir} tdir]} { return $tdir } foreach evar {TMPDIR TEMP TMP} { if {[info exists ::env($evar)] && [file isdirectory $::env($evar)]} { set tdir [file join $::env($evar) ${nametag}_[pid]] file mkdir $tdir return $tdir } } return "" } proc runtests_write_child_payload {payloadfile test_tmlist test_auto_path ifneeded_script tcltestoptions} { #environment payload sourced by testsupport/child_test_runner.tcl in each child process. #Mirrors the singleproc testinterp setup order ('package prefer latest' before anything #that could package require). set fd [open $payloadfile w] puts $fd "#auto-generated by runtests.tcl - child test process environment (see testsupport/child_test_runner.tcl)" puts $fd {package prefer latest} puts $fd {tcl::tm::remove {*}[tcl::tm::list]} puts $fd [list tcl::tm::add {*}$test_tmlist] puts $fd [list set ::auto_path $test_auto_path] puts $fd $ifneeded_script puts $fd [list set ::runtests_child_tcltestoptions $tcltestoptions] close $fd } proc runtests_run_child_process {exe exemodeargs bootstrap payloadfile testfile outfile errfile childtmpdir} { #Run one test file in a child process, capturing stdout/stderr to files. Deliberately no #shellrun/shellfilter capture on the parent side: file capture avoids the parent-stdin/pipe #machinery, and -jobs parallel scheduling reuses the same mechanism (this proc is #replicated verbatim into tpool worker threads via info args/info body - keep it free of #package dependencies and namespace/global state, and keep every argument required). #exemodeargs: extra argv between exe and bootstrap ({} normally; {src} under a punk kit #so the child boots the project's src dev modules instead of kit-stamped packages). #childtmpdir overrides the child's tcltest -tmpdir when nonempty (mandatory per child #under -jobs so concurrent makeFile/makeDirectory helpers cannot collide); "" keeps the #shared -tmpdir carried in the payload options. #stdin is an immediate-EOF redirection so a misbehaving child can't hang on it. #Returns a dict shaped for punk::tcltestrun::parse_testrun: exitcode/stdout/stderr keys, #or error/errorCode/errorInfo keys if the child could not be launched at all. foreach f [list $outfile $errfile] { if {[file exists $f]} { file delete -force $f } } set exitcode 0 set wall_t0 [clock milliseconds] #Child spawn is background-exec plus a tcl::process status poll rather than a blocking #exec: concurrent blocking execs from -jobs tpool worker threads CONVOY on Windows - they #all return together when the longest-lived concurrent child exits (proven 2026-07-19 #with plain sleepers of 2-12s all walling at 12s; see the verification record in #goals/archive/G-091-runtests-parallel-jobs.md). #'exec ... &' returns at spawn and per-pid status polling is convoy-free. stdin comes #from the null device so a misbehaving child can't hang on it. if {$::tcl_platform(platform) eq "windows"} { set nulldev NUL } else { set nulldev /dev/null } if {[llength [info commands ::tcl::process]]} { #Disable the automatic detached-process reaping: Tcl_ReapDetachedProcs runs on every #exec call and purges finished background children PROCESS-WIDE, so a sibling #worker's next spawn could purge this child's status entry before we read it (the #cross-worker race behind nondeterministic 'key not known in dictionary' file #errors in early -jobs runs, 2026-07-19). With autopurge off each pid is purged #explicitly after its status is read. tcl::process autopurge false if {[catch {exec -- $exe {*}$exemodeargs $bootstrap $payloadfile $testfile $childtmpdir < $nulldev > $outfile 2> $errfile &} spawnresult errdict]} { #launch failure - no usable test run return [dict create error $spawnresult errorCode [dict get $errdict -errorcode] errorInfo [dict get $errdict -errorinfo]] } set pid [lindex $spawnresult 0] while {1} { set st [tcl::process status $pid] if {![dict exists $st $pid]} { #should be impossible with autopurge off - surface loudly rather than spin return [dict create error "child pid $pid disappeared from the tcl::process table before its status was read" errorCode {RUNTESTS PIDGONE} errorInfo "child pid $pid missing from tcl::process status result: $st"] } set pstatus [dict get $st $pid] if {$pstatus ne ""} { break } after 50 } catch {tcl::process purge $pid} #status shapes: "0" = clean exit; otherwise {1 } where errorcode #is usually {CHILDSTATUS } if {$pstatus ne "0"} { set ecode [lindex $pstatus 2] if {[lindex $ecode 0] eq "CHILDSTATUS"} { set exitcode [lindex $ecode 2] } else { return [dict create error [lindex $pstatus 1] errorCode $ecode errorInfo [lindex $pstatus 1]] } } } else { #blocking fallback for runtimes without tcl::process (tcl 8.6): correct sequentially; #concurrent use from -jobs workers re-convoys on Windows (documented in #src/tests/AGENTS.md) if {[catch {exec -- $exe {*}$exemodeargs $bootstrap $payloadfile $testfile $childtmpdir < $nulldev > $outfile 2> $errfile} emsg errdict]} { set ecode [dict get $errdict -errorcode] if {[lindex $ecode 0] eq "CHILDSTATUS"} { set exitcode [lindex $ecode 2] } else { #launch failure (or CHILDKILLED etc) - no usable test run return [dict create error $emsg errorCode $ecode errorInfo [dict get $errdict -errorinfo]] } } } set out "" set err "" if {[file exists $outfile]} { set fd [open $outfile r] set out [read $fd] close $fd } if {[file exists $errfile]} { set fd [open $errfile r] set err [read $fd] close $fd } #wall_ms = whole child-process wall time (boot + fixtures + tests) - per-test usec #timings miss file-level fixture cost, and this is what -jobs critical-path analysis #needs. parse_testrun routes the unknown key into its (unused) err text field - harmless. return [dict create exitcode $exitcode stdout $out stderr $err wall_ms [expr {[clock milliseconds] - $wall_t0}]] } proc runtests_colour_enabled {opt} { #opt: auto|on|off. auto = colour only when stdout is a real console - piped/redirected #output (agents, captures) must stay plain - and NO_COLOR is honoured. #Detection uses a twapi console handle probe (the reliable check on windows - see #punk::console usage); deliberately NOT punk::console colour state or a+/a, whose #process-global state proved context-sensitive under mixed tty-ness (2026-07-19 #console-run findings) - the runner's own indicators must be deterministic. switch -- $opt { on {return 1} off {return 0} } if {[info exists ::env(NO_COLOR)] && $::env(NO_COLOR) ne ""} { return 0 } if {$::tcl_platform(platform) eq "windows"} { #GetConsoleMode on the actual STD_OUTPUT handle is the isatty-equivalent: it errors #("handle is invalid") when stdout is a pipe/file. twapi::get_console_handle stdout #is NOT usable here - it succeeds whenever the process has an attached console, #which is true even for piped children of console shells (verified 2026-07-19). if {![catch {package require twapi}] && ![catch {twapi::GetConsoleMode [twapi::GetStdHandle -11]}]} { return 1 } return 0 } #non-windows: no reliable in-core tty test here - default off in auto (use -colour on) return 0 } proc runtests_clr {style text} { #wrap text in a status colour when colour is enabled (raw literal SGR - see #runtests_colour_enabled for why not a+/a) if {!$::runtests_do_colour} { return $text } switch -- $style { pass {return "\x1b\[32m$text\x1b\[0m"} fail - error {return "\x1b\[31;1m$text\x1b\[0m"} warn - warning {return "\x1b\[33;1m$text\x1b\[0m"} default {return $text} } } proc runtests_udptee_event {args} { #emit a runner lifecycle event to the 'runtests' log tag when the UDP tee is active. #Each event message is a well-formed tcl list: RUNTESTS-EVENT ?key value ...? if {$::runtests_udptee_target eq ""} { return } catch {::shellfilter::log::write runtests [list RUNTESTS-EVENT {*}$args]} } proc runtests_collect_child_result {testfile_relative jobresult} { #shared by the -jobs parallel collection loop and its serial tail: cache the child's #result dict for the main processing loop, emit the file-collected watch event, and #relay the captured output to the watch target (under -jobs, relay happens here in #completion order rather than in the discovery-order processing loop). set ::runtests_job_results($testfile_relative) $jobresult if {[dict exists $jobresult exitcode]} { set ecode [dict get $jobresult exitcode] } else { set ecode "launch-error" } runtests_udptee_event file-collected path $testfile_relative exitcode $ecode if {$::runtests_udptee_target ne ""} { if {[dict exists $jobresult stdout] && [dict get $jobresult stdout] ne ""} { catch {::shellfilter::log::write teststdout [dict get $jobresult stdout]} } if {[dict exists $jobresult stderr] && [dict get $jobresult stderr] ne ""} { catch {::shellfilter::log::write teststderr [dict get $jobresult stderr]} } } } #(the testinterp/child module path assembly - test_tmlist/test_auto_path/ifneeded_script - # runs below the -discover-only early exit as stage 2 of the G-093 two-stage boot) punk::args::define { @id -id (script)::runtests @cmd -name runtests\ -summary\ "Run the source test suites for this project."\ -help\ "Run the test suites for this project. By default, all test files under src/tests/ will be included - but you can specify particular test files or paths to include using the arguments below. These tests run against the unbuilt pure-tcl modules under development rather than any installed versions - so you can test the latest code without installing it. To run tests against the installed versions, see the modules/test folder within this project or package require the approprate test:: package and call its RUN function. " @opts -tcltestoptions -type dict -default {-singleproc 1 -verbose {body pass skip start error line usec}} -help\ "Pairs of flags/values that will be passed to tcltest::configure before running the tests. The supplied flags will be merged with the default flags. -singleproc is interpreted by this runner rather than by tcltest's runAllTests: 1 (default) sources each test file in a fresh child interp of this process. 0 runs each test file in a child process of the same executable via testsupport/child_test_runner.tcl, with the same module paths and tcltest options forwarded through a generated environment payload. A nonzero child exit is reported as a file-level failure with the stderr tail surfaced. Prefer a native tclsh for -singleproc 0: children of a kit executable boot with kit-stamped punk packages preloaded, which can shadow the src dev modules under test." -show-raw-output -type boolean -default 0 -help\ "If true, the raw stdout and stderr produced by tcltest from the test files will be shown in addition to the parsed results. This will be in markdown code blocks under headings: stdout from and stderr from " -include-paths -type list -default {**} -multiple 1 -help\ "List of directory glob patterns selecting which directories under the test base contribute test files. Patterns are relative to the test base, use forward slashes, and match the DIRECTORY containing a test file - the file-name axis belongs to the trailing file-tail globs (default *.test). Segment forms (punk::path pathglob syntax - deliberately separable): modules/punk files directly in modules/punk only modules/punk/* files in folders exactly one below modules/punk modules/punk/** files in subtrees strictly below modules/punk (NOT files directly in modules/punk) modules/punk/*** files in modules/punk and everything below it Use the X/*** form to run a whole subtree. Single-file targeting combines a directory pattern with a file tail: -include-paths modules/punk/args/testsuites/args dynamic.test The value is a space-separated list of patterns, and the flag may also be repeated, with all occurrences accumulating: -include-paths modules/punk/args/*** -include-paths modules/punk/ns/*** is equivalent to -include-paths {modules/punk/args/*** modules/punk/ns/***} A received pattern that contributes no files earns a stderr advisory (the common miss: X/** where X/*** was intended). Directories matching -exclude-paths are removed from the included set." -exclude-paths -type list -default {} -multiple 1 -help\ "List of directory glob patterns excluding directories from discovery - same syntax, relativity and accumulation semantics as -include-paths. Patterns whose final segment is ** or *** prune the matched subtree; other matches exclude only the files directly in the matching directory. Exclusion wins over inclusion for the same file. Gives broad runs a middle ground between full and targeted - e.g -exclude-paths shell/*** when no built kit is present, or excluding a heavy suite family unrelated to the change being tested." -discover-only -type boolean -default 0 -help\ "If true, print the discovered test file list and exit without running any tests. Always emits one machine-readable line 'RUNTESTS_FILES ...' (a well-formed tcl list with RUNTESTS_FILES as its first element), plus one path per line first in non-json report modes. No test report is produced. For inspecting -include-paths/-exclude-paths targeting." -report -type string -default markdown -choices {markdown compact json markdown+json} -help\ "Output report style. markdown preserves the detailed human-readable report. compact prints a short Markdown report with failures, warnings, and optional slow tests. json prints a machine-readable JSON summary. markdown+json prints the detailed Markdown report plus a fenced JSON summary." -show-passes -type boolean -default 1 -help\ "If true, include per-test pass lists in markdown reports. Use false for shorter agent-oriented output." -show-timings -type boolean -default 1 -help\ "If true, include microsecond timings where available." -slowest -type int -default 0 -help\ "Number of slowest passing tests to include in Markdown and JSON summaries. Use 0 to suppress." -strict-exit -type boolean -default 0 -help\ "If true, exit 1 when tests fail and exit 2 when files produce parser warnings." -jobs -type int -default 1 -help\ "Number of concurrent child processes for multi-process mode. 1 (default) runs test files sequentially. Values above 1 imply -singleproc 0 (multi-process mode): test files run through a worker pool of this many concurrent child processes, except files matching -serial-paths, which run sequentially after the parallel batch. Reports are unchanged and emitted in discovery order; per-test microsecond timings get noisier under CPU oversubscription. Conflicts with an explicit -tcltestoptions {-singleproc 1}." -colour -type string -default auto -choices {auto on off} -help\ "ANSI colour for the human-facing pass/fail/warning indicators in markdown and compact reports. auto (default) colours only when stdout is a real console (never piped/redirected output) and honours the NO_COLOR environment variable. Machine-facing output (the RUNTESTS_RESULT line, json reports) is never coloured." -serial-paths -type list -default {modules/punk/console/*** modules/opunk/console/***} -help\ "Directory glob patterns (relative to the test base, forward slashes - the same directory-oriented syntax as -include-paths) selecting test files that must NOT run concurrently when -jobs exceeds 1: a file is serial when the directory containing it matches any pattern. Matching files run sequentially after the parallel batch completes. The default covers the console-state suites (they emit to and query the shared terminal); pass an empty list to parallelise everything. Suites driven through piped-stdio child processes (shell/***, modules/punk/repl/***) are parallel by default - add them here if they prove flaky under a real console." @values -min 0 -max -1 glob -type string -multiple 1 -optional 1 -help\ "Names or glob patterns of test files to run. This matches against the file tail - so should not include path segments. The default if not supplied is a single *.test entry." } if {"-h" in $::argv || "--help" in $::argv || "-help" in $::argv} { puts stderr [punk::args::usage (script)::runtests] exit 0 } set ts_start [clock seconds] puts "argv : $::argv" puts "argv0: $::argv0" set argd [punk::args::parse $::argv withid (script)::runtests] lassign [dict values $argd] leaders opts values received set opt_tcltestoptions [dict get $opts -tcltestoptions] set default_tcltestoptions {-singleproc 1 -verbose {body pass skip start error line usec}} set opt_show_raw_output [dict get $opts -show-raw-output] set opt_report [dict get $opts -report] set opt_show_passes [dict get $opts -show-passes] set opt_show_timings [dict get $opts -show-timings] set opt_slowest [dict get $opts -slowest] set opt_strict_exit [dict get $opts -strict-exit] set opt_jobs [dict get $opts -jobs] set opt_serial_paths [dict get $opts -serial-paths] set runtests_do_colour [runtests_colour_enabled [dict get $opts -colour]] if {![string is integer -strict $opt_jobs] || $opt_jobs < 1} { puts stderr "runtests: invalid -jobs value '$opt_jobs' (expected an integer >= 1)" exit 2 } set report_detailed_markdown [expr {$opt_report in {markdown markdown+json}}] set report_compact [expr {$opt_report eq "compact"}] set report_json_only [expr {$opt_report eq "json"}] set report_emit_json [expr {$opt_report in {json markdown+json}}] #-include-paths/-exclude-paths are -multiple 1: each occurrence contributes a list of #patterns - flatten (unreceived defaults and single-occurrence usage flatten to themselves) set include_paths [concat {*}[dict get $opts -include-paths]] set exclude_paths [concat {*}[dict get $opts -exclude-paths]] set opt_discover_only [dict get $opts -discover-only] set tcltestoptions [dict merge $default_tcltestoptions $opt_tcltestoptions] #-jobs > 1 is a multi-process-mode feature: it implies -singleproc 0. An explicit #user-supplied -singleproc 1 alongside -jobs > 1 is a conflict. (Check against $received - #the unreceived -tcltestoptions default also carries -singleproc 1 and must not trigger this.) if {$opt_jobs > 1} { if {[dict exists $received -tcltestoptions] && [dict exists $opt_tcltestoptions -singleproc] && [dict get $opt_tcltestoptions -singleproc]} { puts stderr "runtests: -jobs $opt_jobs conflicts with -tcltestoptions {-singleproc 1} (parallel jobs require multi-process mode)" exit 2 } dict set tcltestoptions -singleproc 0 } if {[dict exists $tcltestoptions -file]} { set file_globs [dict get $tcltestoptions -file] } else { #set file_globs [list *.test] set file_globs [list] } if {[dict exists $received glob]} { #glob is -multiple 1: $values glob is a list of the supplied names - expand, #or multiple file tails collapse into one space-containing glob matching nothing lappend file_globs {*}[dict get $values glob] } #fall back to default if still empty if {[llength $file_globs] == 0} { set file_globs [list *.test] } dict set tcltestoptions -file $file_globs #Default tcltest's -tmpdir (makeFile/makeDirectory location) to a fresh directory under the system temp area. #Without this, tcltest helpers land in the working directory - aborted runs of e.g core exec.test littered #src/tests with untracked helper files (cat, echo, gorp.file ...). A user-supplied -tmpdir via -tcltestoptions wins. #Cleaned up (file delete -force) before exit; an aborted run leaves it in the OS temp area rather than the source tree. set runtests_tmpdir "" if {![dict exists $opt_tcltestoptions -tmpdir]} { set runtests_tmpdir [runtests_create_tempdir runtests_tmp] if {$runtests_tmpdir ne ""} { dict set tcltestoptions -tmpdir $runtests_tmpdir } } #puts "tcltestoptions: $tcltestoptions" #puts "file_globs: $file_globs" set thisexecutable [info nameofexecutable] if {!$report_json_only} { puts "" puts "# runtests.tcl started at [clock format $ts_start -format "%Y-%m-%d %H:%M:%S"]" puts "" puts "test_base: $test_base " puts "executable: $thisexecutable " puts "" } set exclude_files [list AGENTS.md *.tcl] set tallydict [dict create] dict set tallydict total 0 dict set tallydict passed 0 dict set tallydict skipped 0 dict set tallydict failed 0 dict set tallydict files_with_fails [list] dict set tallydict files_without_fails [list] dict set tallydict files_with_warnings [list] set file_summaries [list] set all_passes [list] #tailglobs is a -multiple 1 positional: each glob must be a separate argument, or multiple globs collapse into one #Discovery hands -include-paths/-exclude-paths to punk::path::treefilenames unchanged #(directory-oriented pathglob semantics, identical everywhere - see #testsupport/discovery.tcl for the contract and the G-093 history; punk::path 0.4.0's #*** zero-or-more-segments form makes X/*** the whole-subtree spelling). set testfiles [runtests_discovery::discover_testfiles $test_base $include_paths $exclude_paths $file_globs $exclude_files] #per-pattern zero-match advisory (G-093): a received include pattern that contributed no #files is usually the X/** spelling where X/*** was intended (X/** deliberately excludes #files directly in X). stderr only - results are unaffected. if {[dict exists $received -include-paths]} { foreach ip_pat $include_paths { set ip_hit 0 foreach tf $testfiles { if {[runtests_discovery::dir_matches_any [list $ip_pat] $tf]} { set ip_hit 1 break } } if {!$ip_hit} { puts stderr "runtests: -include-paths pattern '$ip_pat' matched no test files (note: X/** excludes files directly in X - use X/*** for a subtree including its base)" } } } if {$opt_discover_only} { #print the discovered relative paths and exit before any run machinery starts #(before the multi-process workdir and the UDP tee log workers are created; the #already-created default tcltest tmpdir is removed as at normal run end). #The RUNTESTS_FILES line is a well-formed tcl list (marker first element) so paths #survive machine parsing regardless of content; it is emitted last, mirroring the #RUNTESTS_RESULT end-of-output convention. if {!$report_json_only} { foreach tf $testfiles { puts $tf } } puts [list RUNTESTS_FILES {*}$testfiles] if {$runtests_tmpdir ne "" && [file isdirectory $runtests_tmpdir]} { catch {file delete -force $runtests_tmpdir} } exit 0 } #run-phase boot (stage 2 of the G-093 two-stage boot): the heavy run-phase packages and the #testinterp/child path assembly, deferred past the -discover-only early exit above. package require punk package require Thread package require shellrun package require punk::tcltestrun #------------------------------------ #for the tests running in child processes, #use the unbuilt modules/libraries under development in preference to the installed versions. #ORDERING NOTE (rules verified experimentally on Tcl 9.0.3, 2026-07-06 - identical results #under Tcl's standard 'package unknown' scanner and punk::libunknown): # - tcl::tm::add PREPENDS each of its arguments in turn, so a single call # 'tcl::tm::add {*}$test_tmlist' produces tcl::tm::list in REVERSED test_tmlist order # (the last element of test_tmlist ends up at the head of tcl::tm::list). # - For the SAME module name-version found under multiple tm paths, the copy under the # path nearest the HEAD of tcl::tm::list wins (first-scanned registration is kept). # - Net effect: the LAST element of test_tmlist wins same-version ties. #Different-version selection is unaffected by order: dev modules (999999.0a1.0) win via #'package prefer latest' wherever they sit. But bootsupport and vendormodules snapshots can #carry the SAME version of a module with different code (a version-bump-discipline failure in #the source project, but it happens - observed 2026-07-06 with a stale vendormodules #textblock 0.1.3 shadowing the fresh bootsupport copy and breaking shellfilter::run). #bootsupport is deliberately the LAST test_tmlist element so the punkshell-managed bootsupport #snapshot wins any same-version tie. set test_tmlist [list] set ifneeded_script "" lappend test_tmlist [file normalize $test_base/../modules] ;#ie /src/modules append ifneeded_script [punk::tcltestrun::tm_path_additional_ifneeded [file normalize $test_base/../modules] $project_root] lappend test_tmlist [file normalize $test_base/../modules_tcl$tcl_major] append ifneeded_script [punk::tcltestrun::tm_path_additional_ifneeded [file normalize $test_base/../modules_tcl$tcl_major] $project_root] #vendored module dependencies (e.g voo) must be resolvable by modules/tests using them lappend test_tmlist [file normalize $test_base/../vendormodules] if {[file isdirectory $test_base/../vendormodules_tcl$tcl_major]} { lappend test_tmlist [file normalize $test_base/../vendormodules_tcl$tcl_major] } lappend test_tmlist [file normalize $test_base/../bootsupport/modules] ;#after vendormodules - wins same-version ties set test_auto_path [list] lappend test_auto_path [file normalize $test_base/../lib] lappend test_auto_path [file normalize $test_base/../lib/tcl$tcl_major] lappend test_auto_path [file normalize $test_base/../../lib_tcl$tcl_major/$arch] lappend test_auto_path [info library] #the parent of [info library] is where an installation's binary packages usually live #(e.g Thread, needed by shellrun in the testinterp) - the default tclsh auto_path has it, #but we replace auto_path wholesale in the testinterp, and not every project carries a #root lib_tcl/ runtime payload that would otherwise supply Thread. lappend test_auto_path [file dirname [info library]] #kit-internal library trees: when running under a kit/zipkit executable the wholesale #auto_path replacement above would otherwise hide packages bundled in the kit's lib trees #(e.g tcllib's tcl::chan::fifo2, needed by the shellrun harness) - tclPkgUnknown only scans #an auto_path entry and its immediate children, so [file dirname [info library]] (e.g #//zipfs:/app) cannot reach //zipfs:/app/lib_tcl/. Mirrors the internal-path #classification in src/vfs/_config/punk_main.tcl: zipfs app mount, tclkit ::tcl::kitpath #(exe path dir-shadow), cookfs //cookit:/ volume (mount name is compile-configurable; #only the known default is supported - as per punk_main.tcl). set kit_lib_bases [list] if {[info commands tcl::zipfs::root] ne "" && [llength [tcl::zipfs::mount]]} { set zipbase [file join [tcl::zipfs::root] app] if {"$zipbase" in [tcl::zipfs::mount]} { lappend kit_lib_bases $zipbase } } if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { lappend kit_lib_bases [file normalize $::tcl::kitpath] } if {"//cookit:/" in [file volumes]} { lappend kit_lib_bases //cookit:/ } foreach kit_base $kit_lib_bases { foreach p [list lib lib_tcl$tcl_major] { set kit_libdir [file join $kit_base $p] if {[file isdirectory $kit_libdir] && $kit_libdir ni $test_auto_path} { lappend test_auto_path $kit_libdir } } } #------------------------------------ if {[dict exists $tcltestoptions -singleproc] && [dict get $tcltestoptions -singleproc]} { if {!$report_json_only} { puts "Running tests in single process mode" } set singleproc 1 } else { if {!$report_json_only} { if {$opt_jobs > 1} { puts "Running tests in multiple processes (-jobs $opt_jobs)" } else { puts "Running tests in multiple processes" } } set singleproc 0 } set jobs_mode [expr {!$singleproc && $opt_jobs > 1}] if {!$report_json_only} { puts "test auto_path: $test_auto_path" puts "test tmlist: $test_tmlist" puts "tcltestoptions: $tcltestoptions" } #multi-process mode setup: each test file runs as # testsupport/child_test_runner.tcl #with stdout/stderr captured to files under a run-scoped work directory. The generated payload #forwards the parent-computed environment (module paths, auto_path, modpod ifneeded definitions, #tcltest options) so children select the same unbuilt dev modules as the singleproc testinterp. set runtests_workdir "" if {!$singleproc} { set child_exe_modeargs [list] if {[llength $kit_lib_bases]} { if {[namespace exists ::punkboot]} { #punk kit (punk_main.tcl boot): plain script dispatch boots kit-stamped punk #packages into the child (e.g punk::console 0.7.2) BEFORE the payload's src #paths apply, so suite requires pinned 999999.0a1.0- hit version conflicts. #The kit's 'src' package_mode boots children on the project's src dev modules #instead - matching what the payload selects (G-098 kit-hosted runs 2026-07-20). set child_exe_modeargs [list src] puts stderr "NOTE: punk kit executable - child test processes launch with the kit's 'src' package_mode so src dev modules boot (not kit-stamped packages)." } else { puts stderr "WARNING: -singleproc 0 under a non-punk kit executable: child processes boot with the kit's bundled packages which can shadow the src dev modules under test. Prefer a native tclsh for multi-process runs." } } set child_bootstrap [file join $test_base testsupport child_test_runner.tcl] if {![file exists $child_bootstrap]} { puts stderr "Error: missing child bootstrap script: $child_bootstrap" exit 2 } set runtests_workdir [runtests_create_tempdir runtests_work] if {$runtests_workdir eq ""} { puts stderr "Error: could not create a work directory for multi-process test runs (no usable temp area)" exit 2 } set child_payloadfile [file join $runtests_workdir child_payload.tcl] set child_outfile [file join $runtests_workdir child_stdout.txt] set child_errfile [file join $runtests_workdir child_stderr.txt] #each child runs one file in one process, so its tcltest env mirrors the singleproc #testinterp (-singleproc 1; per-file -testdir is computed child-side from the test file path) set child_tcltestoptions $tcltestoptions dict set child_tcltestoptions -singleproc 1 runtests_write_child_payload $child_payloadfile $test_tmlist $test_auto_path $ifneeded_script $child_tcltestoptions } #Optional live watch of test runs over UDP (e.g a local tk viewer app): set env(PUNK_TEST_UDPTEE) #to or : (e.g 41197 for udp://127.0.0.1:41197). Uses the shellfilter::log #mechanism (shellthread worker threads -> tcludp datagrams, one per line, cooked format with a #source column). Runner lifecycle events go to tag 'runtests' (each message is a tcl list: #RUNTESTS-EVENT ?key value ...?). Test file output goes to tags 'teststdout' and #'teststderr': streamed live via shellrun::runx -teelog inside the testinterp in single-process #mode; written per completed file by this parent in multi-process mode (children do not stream). #No listener is required - datagram sends to an unbound local port are discarded harmlessly. set runtests_udptee_target "" if {[info exists ::env(PUNK_TEST_UDPTEE)] && [string trim $::env(PUNK_TEST_UDPTEE)] ne ""} { set udptee_raw [string trim $::env(PUNK_TEST_UDPTEE)] if {[string is integer -strict $udptee_raw]} { set runtests_udptee_target 127.0.0.1:$udptee_raw } else { set runtests_udptee_target $udptee_raw } lassign [split $runtests_udptee_target :] udptee_host udptee_port if {$udptee_host eq "" || ![string is integer -strict $udptee_port] || $udptee_port < 1 || $udptee_port > 65535} { puts stderr "runtests: ignoring invalid PUNK_TEST_UDPTEE value '$::env(PUNK_TEST_UDPTEE)' (expected or :)" set runtests_udptee_target "" } } if {$runtests_udptee_target ne ""} { puts stderr "runtests: UDP tee enabled -> $runtests_udptee_target (PUNK_TEST_UDPTEE)" #ensure log workers resolve the project's tcludp (1.0.13+) rather than an older copy on #the runtime's default auto_path - 1.0.12's UDP_ExitProc closes process-global event #sources at exit (the G-036 piped-stdin exit-hang class). Workers inherit ::auto_path at #creation, so this must precede the opens. (The testinterp/child test env already gets #this path via test_auto_path.) set runtests_udp_libdir [file normalize $test_base/../../lib_tcl$tcl_major/$arch] if {[file isdirectory $runtests_udp_libdir] && $runtests_udp_libdir ni $::auto_path} { lappend ::auto_path $runtests_udp_libdir } if {[catch {::shellfilter::log::open runtests [list -syslog $runtests_udptee_target]} errM]} { puts stderr "runtests: could not open UDP tee log worker ($errM) - disabling tee" set runtests_udptee_target "" } elseif {!$singleproc} { #multi-process mode: the parent relays each child's captured output after the file runs catch {::shellfilter::log::open teststdout [list -syslog $runtests_udptee_target]} catch {::shellfilter::log::open teststderr [list -syslog $runtests_udptee_target]} } } runtests_udptee_event run-start mode [expr {$singleproc ? "singleproc" : "multiproc"}] jobs $opt_jobs executable $thisexecutable tcl [info patchlevel] files [llength $testfiles] argv $::argv #-jobs parallel phase (G-091): partition the discovered files into a parallel batch and a #serial tail (-serial-paths: console-state-sensitive suites must not run concurrently), run #the parallel batch through a tpool of -jobs concurrent child processes with per-child #capture files and tcltest tmpdirs, then run the serial files sequentially through the same #child mechanism. Results are cached in runtests_job_results and the main loop below consumes #them in discovery order, so reports are identical in shape and order to a sequential run. #Submission is longest-first using static weights from the 2026-07-18 timing measurements #(G-091, achieved - see goals/archive/G-091-runtests-parallel-jobs.md): the full-suite #floor is the slowest single file, so the slowest files must start immediately. #Watch-event semantics under -jobs: no file-start events; file-collected (with exitcode) #fires in completion order here, and the authoritative file-end (with tallies) fires from #the processing loop in discovery order. array set runtests_job_results {} set runtests_phase_times [dict create] if {$jobs_mode} { set _phase_t0 [clock milliseconds] set serial_patterns [concat {*}$opt_serial_paths] set parallel_files [list] set serial_files [list] foreach tf $testfiles { #directory-of-file classification - same directory-oriented pattern reading as #-include-paths (G-093; previously matched the file path itself) set is_serial [runtests_discovery::dir_matches_any $serial_patterns $tf] if {$is_serial} { lappend serial_files $tf } else { lappend parallel_files $tf } } #longest-first submission order. Static heuristic weights (seconds, measured 2026-07-18 #on the reference machine); unlisted files weight 0 and keep discovery order among #themselves (lsort is stable). set weight_globs { */runtimecmd_roundtrip.test 36 */runtimecmd_checkfile.test 35 */argparsingtest_compare.test 30 */multishell_wrapverify.test 26 */multishell_wrapdeterminism.test 26 */dtplite.test 25 */argparsingtest.test 22 */multishell.test 20 */scriptexec.test 10 */shellexit.test 6 */exec.test 5 */staticruntime.test 3 */runtimebash_wsl.test 3 */shellnavns.test 2 } set decorated [list] foreach tf $parallel_files { set w 0 foreach {g gw} $weight_globs { if {[string match $g $tf]} { set w $gw break } } lappend decorated [list $w $tf] } set ordered_parallel [list] foreach rec [lsort -integer -decreasing -index 0 $decorated] { lappend ordered_parallel [lindex $rec 1] } if {!$report_json_only} { puts "parallel phase: [llength $parallel_files] files across $opt_jobs jobs; serial tail: [llength $serial_files] files" } #per-child tcltest tmpdirs: nest under a user-supplied -tmpdir if given, else the workdir if {[dict exists $opt_tcltestoptions -tmpdir]} { set childtmp_base [dict get $opt_tcltestoptions -tmpdir] } else { set childtmp_base $runtests_workdir } set idx_of [dict create] set fidx 0 foreach tf $testfiles { dict set idx_of $tf [incr fidx] } #tpool workers need only the child-spawn proc: replicate it verbatim (no packages, no #globals - see the proc's comments) set pool_initcmd [list proc runtests_run_child_process [info args runtests_run_child_process] [info body runtests_run_child_process]] set pool [tpool::create -minworkers 0 -maxworkers $opt_jobs -initcmd $pool_initcmd] set jobmap [dict create] foreach tf $ordered_parallel { set i [dict get $idx_of $tf] set tfabs [file normalize [file join $test_base $tf]] set c_out [file join $runtests_workdir child_stdout_$i.txt] set c_err [file join $runtests_workdir child_stderr_$i.txt] set c_tmp [file join $childtmp_base childtmp_$i] file mkdir $c_tmp set jid [tpool::post $pool [list runtests_run_child_process $thisexecutable $child_exe_modeargs $child_bootstrap $child_payloadfile $tfabs $c_out $c_err $c_tmp]] dict set jobmap $jid $tf } set pending [dict keys $jobmap] set collected 0 while {[llength $pending]} { set done [tpool::wait $pool $pending pending] foreach jid $done { set tf [dict get $jobmap $jid] if {[catch {tpool::get $pool $jid} jobresult]} { #worker-level failure (a nonzero child exit comes back inside the dict, not here) set jobresult [dict create error $jobresult errorCode {RUNTESTS JOBFAIL} errorInfo $jobresult] } incr collected if {$report_detailed_markdown} { puts stdout "parallel collected $collected/[llength $parallel_files]: $tf" flush stdout } runtests_collect_child_result $tf $jobresult } } tpool::release $pool dict set runtests_phase_times parallel_s [format %.1f [expr {([clock milliseconds] - $_phase_t0) / 1000.0}]] set _phase_t1 [clock milliseconds] #serial tail: console-state-sensitive files, one at a time (still child processes) foreach tf $serial_files { set i [dict get $idx_of $tf] set tfabs [file normalize [file join $test_base $tf]] set c_out [file join $runtests_workdir child_stdout_$i.txt] set c_err [file join $runtests_workdir child_stderr_$i.txt] set c_tmp [file join $childtmp_base childtmp_$i] file mkdir $c_tmp set jobresult [runtests_run_child_process $thisexecutable $child_exe_modeargs $child_bootstrap $child_payloadfile $tfabs $c_out $c_err $c_tmp] if {$report_detailed_markdown} { puts stdout "serial completed: $tf" flush stdout } runtests_collect_child_result $tf $jobresult } dict set runtests_phase_times serial_s [format %.1f [expr {([clock milliseconds] - $_phase_t1) / 1000.0}]] if {!$report_json_only} { puts "parallel phase: [dict get $runtests_phase_times parallel_s]s; serial tail: [dict get $runtests_phase_times serial_s]s" #child process wall times (boot + fixtures + tests) - the -jobs critical path is the #slowest child, which per-test usec timings understate set walls [list] foreach tf $testfiles { if {[info exists runtests_job_results($tf)] && [dict exists $runtests_job_results($tf) wall_ms]} { lappend walls [list [dict get $runtests_job_results($tf) wall_ms] $tf] } } puts "slowest child processes (wall):" foreach rec [lrange [lsort -integer -decreasing -index 0 $walls] 0 9] { puts [format " %7.1fs %s" [expr {[lindex $rec 0] / 1000.0}] [lindex $rec 1]] } } set _phase_t2 [clock milliseconds] } set runtests_file_number 0 foreach testfile_relative $testfiles { set testfile [file normalize [file join $test_base $testfile_relative]] incr runtests_file_number if {!$jobs_mode} { #under -jobs the run already happened - file-collected was emitted in completion #order and the discovery-order file-end below carries the tallies runtests_udptee_event file-start path $testfile_relative index $runtests_file_number of [llength $testfiles] } if {$report_detailed_markdown} { puts stdout "" #puts stdout "running test file $testfile" puts stdout "## runtests $testfile_relative" puts stdout "" } dict set tcltestoptions -testdir [file dirname $testfile] if {$singleproc} { #in single process mode we can just source the test file in an interp - but we need to set up the environment for the test file - such as the module search path to ensure it picks up the unbuilt modules under development rather than any installed versions. interp create testinterp #latest mode so the alpha-versioned dev modules (999999.0a1.0) are preferred over stable #bootsupport/vendored copies on unversioned 'package require' (default 'stable' mode would #silently select e.g bootsupport punk::console 0.1.x over the dev module under test) testinterp eval {package prefer latest} testinterp eval {tcl::tm::remove [tcl::tm::list]} testinterp eval [list tcl::tm::add {*}$test_tmlist] testinterp eval [list set ::auto_path $test_auto_path] testinterp eval $ifneeded_script testinterp eval [list set ::argv0 $::argv0] testinterp eval [list set ::argv $tcltestoptions] testinterp eval [list set ::argc [llength $tcltestoptions]] testinterp eval {package require tcltest} testinterp eval [list tcltest::configure {*}$tcltestoptions] testinterp eval { if {[info commands ::lpop] eq ""} { #native Tcl 8.6 testinterp: shellrun's runx (the runner's capture mechanism) parses via #punk::args::parse, which uses lpop. punk::lib installs the validated compat aliases #(parity pinned by modules/punk/lib compat.test). No-op on Tcl 8.7+/9. #(floored like the toplevel requires - fossil-rejection; prefer-latest selects the dev # module here anyway) package require punk::lib 0.5.1- } } testinterp eval {package require shellrun} #puts ">>>> [testinterp eval { # set result "" # foreach key [tcltest::configure] { # append result "$key: [tcltest::configure $key]\n" # } # return $result # }] <<<<" if {$runtests_udptee_target ne ""} { #live-stream this file's output to the UDP watch target while capturing #(log sources teststdout/teststderr - same tags the multiproc parent relay uses) set result [testinterp eval [list shellrun::runx -teelog [list -tag test -syslog $runtests_udptee_target] -tcl source $testfile]] } else { set result [testinterp eval [list shellrun::runx -tcl source $testfile]] } if {$runtests_udptee_target ne ""} { #Watch mode: close the shellfilter::log worker threads opened inside the testinterp #(the -teelog tag workers plus shellrun's punkshout/punksherr teehandle workers) and #terminate them - they are process-level threads whose manager state lives in this #short-lived interp, so without this every watched file would leak 4 idle worker #threads for the remainder of the run. Costs ~0.5-0.7s per file (terminate #handshakes), so it is not done for unwatched runs - those spawn only the two #teehandle workers per file, a small pre-existing leak noted for the #shellfilter/shellthread audit. testinterp eval { catch { if {[info exists ::shellthread::manager::workers]} { foreach _rt_tag [dict keys $::shellthread::manager::workers] { catch {::shellfilter::log::close $_rt_tag} } } catch {shellthread::manager::shutdown_free_threads 1000} } } } interp delete testinterp if {$report_detailed_markdown} { puts stdout "sourced $testfile " } flush stdout } else { if {$jobs_mode} { #run already performed in the parallel/serial phases above; output relay and the #file-collected event happened at collection time set result $runtests_job_results($testfile_relative) } else { set result [runtests_run_child_process $thisexecutable $child_exe_modeargs $child_bootstrap $child_payloadfile $testfile $child_outfile $child_errfile ""] if {$runtests_udptee_target ne ""} { #relay the child's captured output to the watch target (file granularity - #children do not stream live; see src/tests/AGENTS.md) if {[dict exists $result stdout] && [dict get $result stdout] ne ""} { catch {::shellfilter::log::write teststdout [dict get $result stdout]} } if {[dict exists $result stderr] && [dict get $result stderr] ne ""} { catch {::shellfilter::log::write teststderr [dict get $result stderr]} } } } if {$report_detailed_markdown} { puts stdout "executed $thisexecutable[expr {[llength $child_exe_modeargs] ? " $child_exe_modeargs" : ""}] testsupport/child_test_runner.tcl $testfile_relative " } flush stdout } if {$opt_show_raw_output} { puts stdout "" puts stdout "### stdout from $testfile_relative" puts stdout "" puts stdout "```" puts stdout [dict get $result stdout] puts stdout "```" puts stdout "" puts stdout "### stderr from $testfile_relative" puts stdout "" puts stdout "```" puts stdout [dict get $result stderr] puts stdout "```" puts stdout "" } if {[dict exists $result error]} { puts stdout "" puts stdout "### error running test file $testfile_relative" puts stdout "error : [dict get $result error] " puts stdout "errorCode: [dict get $result errorCode] " puts stdout "errorInfo: " puts stdout "```" puts stdout [runtests_clr fail [dict get $result errorInfo]] puts stdout "```" puts stdout "" flush stdout dict lappend tallydict files_with_fails $testfile_relative lappend file_summaries [dict create path $testfile_relative status error total 0 passed 0 skipped 0 failed 1 summaryline_detected 0 observed_passes 0 observed_skips 0 observed_failures 1 warnings [list] failures [list [dict create name $testfile_relative status ERROR errorcode [dict get $result error]]] skips [list]] } else { set resultdict [punk::tcltestrun::parse_testrun $result $testfile] set file_status pass set file_warnings [list] set child_exit_failures [list] set child_exitcode [runtests_dict_get_default $resultdict exitcode ""] if {$child_exitcode ni [list "" 0]} { #multi-process mode: a nonzero child exit is a file-level failure regardless of any #summary line - the child usually died before reaching tcltest::cleanupTests. #(previously this was misreported as a missing-cleanupTests warning with the child's #stderr discarded) set stderr_tail [runtests_text_tail [runtests_dict_get_default $result stderr ""] 2000] set child_exit_failures [list [dict create name $testfile_relative status ERROR errorcode [list CHILDPROCESS exit $child_exitcode] errorinfo $stderr_tail]] puts stderr "ERROR: test file child process exited with code $child_exitcode: $testfile" if {!$report_json_only} { puts stdout [runtests_clr fail "test file $testfile_relative child process failed (exitcode $child_exitcode)"] } dict lappend tallydict files_with_fails $testfile_relative set file_status error if {[dict get $resultdict summaryline_detected] == 1} { #the child still reported results before dying - keep them in the tallies dict incr tallydict total [dict get $resultdict summaryline_total] dict incr tallydict passed [dict get $resultdict summaryline_passed] dict incr tallydict skipped [dict get $resultdict summaryline_skipped] dict incr tallydict failed [dict get $resultdict summaryline_failed] } } elseif {[dict get $resultdict summaryline_detected] == 0} { set warning_message "No tcltest summary line detected; test file may be missing tcltest::cleanupTests" set file_warnings [list [runtests_warning_summary missing-cleanupTests $warning_message 0]] puts stderr "WARNING: $warning_message: $testfile" dict lappend tallydict files_with_warnings $testfile_relative set file_status warning } elseif {[dict get $resultdict summaryline_detected] > 1} { set warning_message "More than one tcltest summary line detected; test file may be calling tcltest::cleanupTests multiple times" set file_warnings [list [runtests_warning_summary multiple-summary-lines $warning_message [dict get $resultdict summaryline_detected]]] puts stderr "WARNING: $warning_message: $testfile" dict lappend tallydict files_with_warnings $testfile_relative set file_status warning } else { dict incr tallydict total [dict get $resultdict summaryline_total] dict incr tallydict passed [dict get $resultdict summaryline_passed] dict incr tallydict skipped [dict get $resultdict summaryline_skipped] ;#more than just skipped due to constraints - also includes skipped due to -skip and -match values. dict incr tallydict failed [dict get $resultdict summaryline_failed] #puts stdout [dict get $resultdict out] if {[dict get $resultdict summaryline_failed] > 0} { if {!$report_json_only} { puts stdout [runtests_clr fail "test file $testfile_relative had failures"] } dict lappend tallydict files_with_fails $testfile_relative set file_status fail } else { if {$report_detailed_markdown} { puts stdout [runtests_clr pass "test file $testfile_relative passed"] } dict lappend tallydict files_without_fails $testfile_relative } } set failures [concat [runtests_failure_summaries $resultdict] $child_exit_failures] set skips [runtests_skip_summaries $resultdict] set passes [runtests_pass_summaries $testfile_relative $resultdict] if {$file_status ne "warning"} { set all_passes [concat $all_passes $passes] } set observed_passes [runtests_count_dict_entries [runtests_dict_get_default $resultdict testcase_passes [dict create]]] set observed_skips [runtests_count_dict_entries [runtests_dict_get_default $resultdict testcase_constraintskips [dict create]]] set observed_failures [runtests_count_dict_entries [runtests_dict_get_default $resultdict testcase_fails [dict create]]] lappend file_summaries [dict create {*}{ } path $testfile_relative {*}{ } status $file_status {*}{ } total [dict get $resultdict summaryline_total] {*}{ } passed [dict get $resultdict summaryline_passed] {*}{ } skipped [dict get $resultdict summaryline_skipped] {*}{ } failed [dict get $resultdict summaryline_failed] {*}{ } summaryline_detected [dict get $resultdict summaryline_detected] {*}{ } observed_passes $observed_passes {*}{ } observed_skips $observed_skips {*}{ } observed_failures $observed_failures {*}{ } warnings $file_warnings {*}{ } failures $failures {*}{ } skips $skips {*}{ } ] #puts stdout "resultdict: $resultdict" if {$report_detailed_markdown} { if {$file_status eq "warning"} { foreach warning $file_warnings { runtests_print_file_warning $testfile_relative $warning $observed_passes $observed_skips $observed_failures } } if {[llength $child_exit_failures]} { puts stdout "### child process failure for $testfile_relative" puts stdout "" puts stdout "- exitcode: $child_exitcode " puts stdout " stderr tail: " puts stdout " ```" puts stdout " [dict get [lindex $child_exit_failures 0] errorinfo]" puts stdout " ```" puts stdout "" } if {$opt_show_passes && $file_status ne "warning"} { puts stdout "" puts stdout "### testcase passes for $testfile_relative" puts stdout "" dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_passes [dict create]] { puts stdout "- testname: $testname " if {$opt_show_timings && [dict exists $testdict microseconds]} { puts stdout " microseconds: [dict get $testdict microseconds] " } } puts stdout "" } if {$opt_show_passes && $file_status eq "warning" && $observed_passes > 0} { puts stdout "### observed testcase pass events for $testfile_relative" puts stdout "" puts stdout "These events are untrusted for aggregate counts because no single tcltest cleanup summary was parsed." puts stdout "" dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_passes [dict create]] { puts stdout "- testname: $testname " if {$opt_show_timings && [dict exists $testdict microseconds]} { puts stdout " microseconds: [dict get $testdict microseconds] " } } puts stdout "" } if {$file_status eq "warning"} { puts stdout "### observed testcase failures for $testfile_relative" } else { puts stdout "### testcase failures for $testfile_relative" } puts stdout "" runtests_print_failure_details $testfile_relative $resultdict puts stdout "" if {$file_status eq "warning"} { puts stdout "### observed testcase_constraintskips for $testfile_relative" } else { puts stdout "### testcase_constraintskips for $testfile_relative" } puts stdout "" dict for {testname testdict} [runtests_dict_get_default $resultdict testcase_constraintskips [dict create]] { puts stdout "- testname: $testname " puts stdout " skipreason: [dict get $testdict reason] " } puts -nonewline stdout "\n" } flush stdout } if {$runtests_udptee_target ne ""} { set last_summary [lindex $file_summaries end] runtests_udptee_event file-end path $testfile_relative status [dict get $last_summary status] total [dict get $last_summary total] passed [dict get $last_summary passed] skipped [dict get $last_summary skipped] failed [dict get $last_summary failed] } set i 0 } set status [runtests_status $tallydict] set slowest_tests [runtests_slowest_tests $all_passes $opt_slowest] set elapsed_seconds [expr {[clock seconds] - $ts_start}] if {$jobs_mode} { dict set runtests_phase_times processing_s [format %.1f [expr {([clock milliseconds] - $_phase_t2) / 1000.0}]] if {!$report_json_only} { puts stdout "jobs phase times: parallel [dict get $runtests_phase_times parallel_s]s, serial tail [dict get $runtests_phase_times serial_s]s, processing [dict get $runtests_phase_times processing_s]s" } } runtests_udptee_event run-end status $status total [dict get $tallydict total] passed [dict get $tallydict passed] skipped [dict get $tallydict skipped] failed [dict get $tallydict failed] files [llength $file_summaries] elapsed_seconds $elapsed_seconds {*}$runtests_phase_times if {!$report_json_only} { puts stdout "## runtests summary" puts stdout "" runtests_emit_result_line $status $tallydict $file_summaries $elapsed_seconds puts stdout "" } if {$report_compact} { puts stdout "### testfiles" puts stdout "" foreach file_summary $file_summaries { set fstatus [dict get $file_summary status] set line "- [runtests_clr $fstatus $fstatus] `[dict get $file_summary path]` total=[dict get $file_summary total] passed=[dict get $file_summary passed] skipped=[dict get $file_summary skipped] failed=[dict get $file_summary failed]" if {[dict get $file_summary status] eq "warning"} { set warnings [dict get $file_summary warnings] if {[llength $warnings] > 0} { set warning [lindex $warnings 0] append line " reason=[dict get $warning code] summaryline_detected=[dict get $warning summaryline_detected] observed_passes=[dict get $file_summary observed_passes] observed_skips=[dict get $file_summary observed_skips] observed_failures=[dict get $file_summary observed_failures]" } } puts stdout $line } puts stdout "" puts stdout "### failures" puts stdout "" foreach file_summary $file_summaries { foreach failure [dict get $file_summary failures] { set line "- `[dict get $file_summary path]` [dict get $failure name] status=[dict get $failure status]" if {[dict exists $failure errorcode] && [dict get $failure errorcode] ne ""} { append line " errorcode=[dict get $failure errorcode]" } if {[dict exists $failure errorinfo] && [dict get $failure errorinfo] ne ""} { set msg [string trim [dict get $failure errorinfo]] set first_line [lindex [split $msg \n] 0] if {[string length $first_line] > 120} { set first_line "[string range $first_line 0 119]..." } append line " message=$first_line" } if {[dict exists $failure result_was] && [dict get $failure result_was] ne ""} { set actual [string trim [dict get $failure result_was]] set first_line [lindex [split $actual \n] 0] if {[string length $first_line] > 80} { set first_line "[string range $first_line 0 79]..." } append line " actual=$first_line" } if {[dict exists $failure result_expected] && [dict get $failure result_expected] ne ""} { set expected [string trim [dict get $failure result_expected]] set first_line [lindex [split $expected \n] 0] if {[string length $first_line] > 80} { set first_line "[string range $first_line 0 79]..." } append line " expected=$first_line" } puts stdout [runtests_clr fail $line] } } puts stdout "" puts stdout "### warnings" puts stdout "" foreach file_summary $file_summaries { foreach warning [dict get $file_summary warnings] { puts stdout [runtests_clr warning "- `[dict get $file_summary path]` reason=[dict get $warning code] summaryline_detected=[dict get $warning summaryline_detected] observed_passes=[dict get $file_summary observed_passes]"] } } puts stdout "" if {$opt_slowest > 0} { runtests_print_slowest_tests $slowest_tests $opt_show_timings } } if {$report_detailed_markdown} { puts stdout "### testfiles without failures" puts stdout "" foreach f [dict get $tallydict files_without_fails] { puts stdout " - $f" } puts stdout "" puts stdout "### testfiles with failures" puts stdout "" foreach f [dict get $tallydict files_with_fails] { puts stdout " - [runtests_clr fail $f]" } puts stdout "" puts stdout "### testfiles with warnings" puts stdout "" foreach f [dict get $tallydict files_with_warnings] { puts stdout " - [runtests_clr warning $f]" } puts stdout "" if {$opt_slowest > 0} { runtests_print_slowest_tests $slowest_tests $opt_show_timings } } if {!$report_json_only} { puts stdout "### runtests tally" puts stdout "" set tally_passed "Passed [dict get $tallydict passed]" set tally_failed "Failed [dict get $tallydict failed]" if {[dict get $tallydict failed] > 0 || [llength [dict get $tallydict files_with_fails]]} { set tally_failed [runtests_clr fail $tally_failed] } else { set tally_passed [runtests_clr pass $tally_passed] } set tally_line "Total [dict get $tallydict total] $tally_passed Skipped [dict get $tallydict skipped] $tally_failed" if {[llength [dict get $tallydict files_with_fails]]} { #file-level failures (load/setup errors, child process failures) are not test #results - surface them here so a red FAIL can't sit beside 'Failed 0' unexplained append tally_line " " [runtests_clr fail "Testfiles-failed [llength [dict get $tallydict files_with_fails]]"] } puts stdout "$tally_line " puts stdout "" } if {$report_emit_json} { if {!$report_json_only} { puts stdout "### runtests json" puts stdout "" puts stdout "```json" } puts stdout [runtests_json_report $status $tallydict $file_summaries $slowest_tests $elapsed_seconds] if {!$report_json_only} { puts stdout "```" puts stdout "" } } if {!$report_json_only} { puts stdout "### runtests DONE at [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"] (elapsed ${elapsed_seconds}s) - [runtests_clr $status [string toupper $status]]" puts stdout "" } if {$runtests_tmpdir ne "" && [file isdirectory $runtests_tmpdir]} { catch {file delete -force $runtests_tmpdir} } if {$runtests_workdir ne "" && [file isdirectory $runtests_workdir]} { catch {file delete -force $runtests_workdir} } if {$runtests_udptee_target ne ""} { #orderly shutdown of the parent's tee log workers before exit - worker threads and their #tcludp sockets must not be left running into process teardown (see the G-036 exit-wedge #history around udp workers at exit/quit) catch {::shellfilter::log::close runtests} catch {::shellfilter::log::close teststdout} catch {::shellfilter::log::close teststderr} catch {shellthread::manager::shutdown_free_threads 2500} } if {$opt_strict_exit} { if {[dict get $tallydict failed] > 0 || [llength [dict get $tallydict files_with_fails]] > 0} { exit 1 } if {[llength [dict get $tallydict files_with_warnings]] > 0} { exit 2 } } exit 0 ##don't package require tcltest too early or it may examine and respond to ::argv itself. (e.g to respond to --help, but we have our own help) #package require tcltest # #set ::argv $tcltestoptions #set ::argc [llength $tcltestoptions] ##set ::argv {} ##set ::argc 0 # #tcltest::configure -verbose "body pass skip error usec" #tcltest::configure -testdir $script_dir #tcltest::configure -file $file_globs ##review - single process has less isolation - but works better in this case. ##(some tclsh shells can hang when running with -singleproc false - needs investigation) ##tclte::configure -singleproc true #tcltest::configure -singleproc true #dict for {k v} $tcltestoptions { # tcltest::configure $k $v #} #tcltest::runAllTests