You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
887 lines
40 KiB
887 lines
40 KiB
#!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 <projectroot>/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 |
|
} |
|
#------------------------------------ |
|
package require punk |
|
package require punk::args |
|
package require Thread |
|
package require shellrun |
|
package require punk::tcltestrun |
|
|
|
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]} { |
|
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} { |
|
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 "\"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} { |
|
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]]" |
|
} |
|
|
|
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 "" |
|
} |
|
|
|
|
|
|
|
|
|
|
|
#------------------------------------ |
|
#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 <projectroot>/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<N>/<arch> 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<N>/<pkg>. 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 |
|
} |
|
} |
|
} |
|
#------------------------------------ |
|
|
|
|
|
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::<modulename> 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." |
|
-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 <testfile> |
|
and |
|
stderr from <testfile> |
|
" |
|
-include-paths -type list -default {**} -help\ |
|
"List of glob patterns for paths. |
|
Paths are relative to the test base and should use forward slashes as separators. |
|
|
|
Only test files under paths matching these patterns will be included. |
|
For example, to only include test files under <projectdir>/src/modules/punk |
|
-include-paths {modules/punk/**}" |
|
-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." |
|
@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 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}}] |
|
|
|
|
|
set include_paths [dict get $opts -include-paths] |
|
|
|
|
|
set tcltestoptions [dict merge $default_tcltestoptions $opt_tcltestoptions] |
|
|
|
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]} { |
|
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]} { |
|
if {[catch {file tempdir} runtests_tmpdir]} { |
|
#'file tempdir' requires tcl 8.7+ - fall back to env temp + pid subdir for 8.6 |
|
set runtests_tmpdir "" |
|
foreach evar {TMPDIR TEMP TMP} { |
|
if {[info exists ::env($evar)] && [file isdirectory $::env($evar)]} { |
|
set runtests_tmpdir [file join $::env($evar) runtests_tmp_[pid]] |
|
file mkdir $runtests_tmpdir |
|
break |
|
} |
|
} |
|
} |
|
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] |
|
|
|
set testfiles [punk::path::treefilenames -dir $test_base -tailbase $test_base -exclude-files $exclude_files -include-paths $include_paths $file_globs] |
|
|
|
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} { |
|
puts "Running tests in multiple processes" |
|
} |
|
set singleproc 0 |
|
} |
|
|
|
if {!$report_json_only} { |
|
puts "test auto_path: $test_auto_path" |
|
puts "test tmlist: $test_tmlist" |
|
puts "tcltestoptions: $tcltestoptions" |
|
} |
|
foreach testfile_relative $testfiles { |
|
set testfile [file normalize [file join $test_base $testfile_relative]] |
|
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 {package require shellrun} |
|
#puts ">>>> [testinterp eval { |
|
# set result "" |
|
# foreach key [tcltest::configure] { |
|
# append result "$key: [tcltest::configure $key]\n" |
|
# } |
|
# return $result |
|
# }] <<<<" |
|
set result [testinterp eval [list shellrun::runx -tcl source $testfile]] |
|
interp delete testinterp |
|
if {$report_detailed_markdown} { |
|
puts stdout "sourced $testfile " |
|
} |
|
flush stdout |
|
} else { |
|
#todo - 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. |
|
#we also need to pass the tcltestoptions to the test file. |
|
#one way would be to prepend this data to the testfiledata in a temporary file and then run that temporary file. |
|
#Another way might be to pipe the whole script through stdin to the child process - but that may cause issues with tcltest's use of stdin for user input. |
|
if {[catch { |
|
puts stderr "calling 'runout $thisexecutable $testfile'"; flush stderr |
|
set result [shellrun::runx $thisexecutable $testfile] |
|
#set result [shellrun::runx ls] |
|
} errM]} { |
|
puts stderr "error calling 'runout $thisexecutable $testfile' $errM"; flush stderr |
|
set result {none ""} |
|
} |
|
if {$report_detailed_markdown} { |
|
puts stdout "executed $thisexecutable $testfile " |
|
puts stdout "result keys: [dict keys $result] " |
|
} |
|
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 "\x1b\[31m" |
|
puts stdout [dict get $result errorInfo] |
|
puts stdout "\x1b\[m" |
|
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] |
|
if {[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 "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 "test file $testfile_relative passed" |
|
} |
|
dict lappend tallydict files_without_fails $testfile_relative |
|
} |
|
} |
|
|
|
set failures [runtests_failure_summaries $resultdict] |
|
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 {$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 |
|
} |
|
|
|
set i 0 |
|
} |
|
set status [runtests_status $tallydict] |
|
set slowest_tests [runtests_slowest_tests $all_passes $opt_slowest] |
|
|
|
if {!$report_json_only} { |
|
puts stdout "## runtests summary" |
|
puts stdout "" |
|
runtests_emit_result_line $status $tallydict $file_summaries |
|
puts stdout "" |
|
} |
|
|
|
if {$report_compact} { |
|
puts stdout "### testfiles" |
|
puts stdout "" |
|
foreach file_summary $file_summaries { |
|
set line "- [dict get $file_summary status] `[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 $line |
|
} |
|
} |
|
puts stdout "" |
|
puts stdout "### warnings" |
|
puts stdout "" |
|
foreach file_summary $file_summaries { |
|
foreach warning [dict get $file_summary warnings] { |
|
puts stdout "- `[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 " - $f" |
|
} |
|
puts stdout "" |
|
|
|
puts stdout "### testfiles with warnings" |
|
puts stdout "" |
|
foreach f [dict get $tallydict files_with_warnings] { |
|
puts stdout " - $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 "" |
|
puts stdout "Total [dict get $tallydict total] Passed [dict get $tallydict passed] Skipped [dict get $tallydict skipped] Failed [dict get $tallydict failed] " |
|
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] |
|
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"]" |
|
puts stdout "" |
|
} |
|
|
|
if {$runtests_tmpdir ne "" && [file isdirectory $runtests_tmpdir]} { |
|
catch {file delete -force $runtests_tmpdir} |
|
} |
|
|
|
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
|
|
|