20 changed files with 625 additions and 57 deletions
@ -0,0 +1,441 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tcltestrun 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::tcltestrun { |
||||
variable PUNKARGS |
||||
|
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::tcltestrun::parse_testrun |
||||
@cmd -name punk::tcltestrun::parse_testrun\ |
||||
-summary\ |
||||
"Parse a dict containing stderr and stdout keys into testresult summary data."\ |
||||
-help\ |
||||
"Parse a dict containing stderr and stdout keys into testresult summary data. |
||||
The dict is expected to be in the format returned by shellrun::runx from execution of a tcltest script" |
||||
@leaders |
||||
@opts |
||||
@values -min 1 -max 2 |
||||
testtextdict -type dict -help\ |
||||
"Dict containing the keys 'stdout' and 'stderr' with the raw text output from a tcltestrun execution. |
||||
This is expected to be output from a single test file ie with only one summary line showing the total |
||||
number of tests run, passed, skipped and failed." |
||||
pkg -type string -optional 1 -help\ |
||||
"An optional package name to include in the output lines of the parsed result for easier |
||||
identification of which test file the results came from when running multiple test files." |
||||
}] |
||||
} |
||||
proc parse_testrun {testtextdict {pkg ""}} { |
||||
if {[llength $testtextdict] % 2 != 0} { |
||||
return -code error "punk::tcltestrun::parse_testrun expected even number of elements in outputdict but got [llength $testtextdict]" |
||||
} |
||||
|
||||
set results [dict create] |
||||
dict set results summaryline_total 0 |
||||
dict set results summaryline_passed 0 |
||||
dict set results summaryline_skipped 0 |
||||
dict set results summaryline_failed 0 |
||||
dict set results summaryline_detected 0 |
||||
dict set results out "" |
||||
dict set results err "" |
||||
dict set results exitcode "" |
||||
dict set results test_case_results [list] ;#list of dicts with keys test_name, test_description, test_output |
||||
|
||||
dict for {what chunk} $testtextdict { |
||||
set chunk [string map [list \r\n \n] $chunk] |
||||
#set test_case_open "" ;#used to track state for parsing test case names and descriptions from tcltest output |
||||
set test_case_state [dict create] |
||||
dict set test_case_state stage ""; #""|"open"|"contents" |
||||
dict set test_case_state test_status ""; #""|"PASSED"|"FAILED" |
||||
dict set test_case_state test_openingtext ""; #the text from the opening line of a test case which includes the test name and description, used to match against the closing line of the test case to ensure we are correctly parsing the test name and description even if they contain spaces or other potentially confounding characters. |
||||
switch -- $what { |
||||
stdout { |
||||
foreach ln [split $chunk \n] { |
||||
incr i |
||||
if {[string match "Tests ended at*" $ln]} { |
||||
#puts stdout "<stdout><$pkg> $ln" |
||||
dict append results out "<stdout><$pkg> $ln" \n |
||||
} elseif {[string match "*:*Total*Passed*Skipped*Failed*" $ln]} { |
||||
#summary line - will only be present if the test script contains a tcltest::cleanupTests call at the end of the script. |
||||
|
||||
#we don't expect more than one. |
||||
#if we do get more than one, we will just process as normal here, which may increment tally fields incorrectly, |
||||
#but the caller should use summaryline_detected to warn or error if more than one summary line is detected, |
||||
#as this is a red flag that something is not configured correctly. |
||||
dict incr results summaryline_detected 1 |
||||
|
||||
set fields [lrange $ln 1 end] |
||||
dict for {K v} $fields { |
||||
#total passed skipped failed |
||||
set k [string tolower $K] |
||||
dict incr results summaryline_$k $v |
||||
} |
||||
#puts stdout "<stdout><$pkg> $ln" |
||||
dict append results out "<stdout><$pkg> $ln" \n |
||||
} elseif {[string match "*Sourced * Test Files*" $ln]} { |
||||
#puts stdout "<stdout><$pkg> $ln" |
||||
dict append results out "<stdout><$pkg> $ln" \n |
||||
} elseif {[string match "==== *" $ln]} { |
||||
#*probable* tcltest structure line. |
||||
|
||||
#structure for failing test that wasn't due to an error (when -verbose contains body): |
||||
# ==== <testname_words> <test_description_words> FAILED |
||||
# ==== Contents of test case: |
||||
# |
||||
# <contents of test case> |
||||
# |
||||
# ---- Result was: |
||||
# <result of test case> |
||||
# ---- Result should have been (exact matching): |
||||
# <expected result of test case> |
||||
# ==== <testname_words> FAILED |
||||
|
||||
#depending on whether -verbose contains body(b) pass(p) skip(s) error(e) msec(m) usec(u) |
||||
#we may get ---- or ++++ lines. |
||||
|
||||
#e.g |
||||
# ---- <testname_words> start |
||||
# ++++ <testname_words> took 636 µs |
||||
# ++++ <testname_words> took 1 ms |
||||
# ++++ <testname_words> PASSED |
||||
# ++++ <testname_words> SKIPPED: <constraint/reason> |
||||
|
||||
#Note that -verbose skip only reports a +++... SKIPPED:.. line if the test was actually skipped due to a constraint. |
||||
#It will not report if the skip was due to a failure to match a -match value or a match of a -skip value. |
||||
#See tcl ticket RFE: https://core.tcl-lang.org/tcl/tktview/1228806fffffffffffff |
||||
|
||||
#unlikely but possible confounding factors. |
||||
#Test could include a command named "====" which outputs lines starting with "====" |
||||
#or a test could call something that uses puts stdout to output lines starting with "====" |
||||
#The first case is certainly possible as "====" can be defined as a command name - but pretty unlikely |
||||
#The second case is slightly more likely but still probably uncommon, and it would be more uncommon for the |
||||
#last word to be FAILED in that case. |
||||
#So it's probably a reasonable heuristic that lines starting with "====" and ending with FAILED |
||||
#are tcltest result lines, and we can parse the test name and description from those lines. |
||||
#Both cases are probably uncommon/unlikely unless the test is specifically designed to try to break this parser |
||||
#or to emulate tcltest output format. |
||||
|
||||
#the tcltest output format is not nicely structured in that the testname and description can both contain spaces, |
||||
#so the first ==== * FAILED line can't on it's own be used to extract the test name and description |
||||
|
||||
#we will handle this by maintaining state on encountering the first ==== * FAILED line, |
||||
#and not looking for the closing ==== <testname_words> FAILED line until we encounter |
||||
#the exact line ==== Contents of test case: which is always between the opening and closing lines for a test case. |
||||
#we should also only accept a closing ==== <testname_words> FAILED line |
||||
#if the <testname_words> portion is a prefix of the combined <testname_words> <test_description_words> |
||||
#portion from the opening line. |
||||
#This should allow us to correctly parse the test name and description even if they contain spaces, |
||||
#and even if the section between ==== Contents of test case: and the closing ==== <testname_words> FAILED contains |
||||
# emulated tcltest output lines or sub-output from some other call to tcltest, we should be able to ignore it properly. |
||||
set stage [dict get $test_case_state stage] |
||||
switch -exact -- $stage { |
||||
"" { |
||||
if {[string match "==== * FAILED" $ln]} { |
||||
dict set test_case_state stage open |
||||
set line_inner [string range $ln 5 end-7] ;#trim leading ====<space> and trailing <space>FAILED |
||||
dict set test_case_state test_openingtext $line_inner |
||||
} |
||||
dict append results out "<stdout><$pkg> $ln" \n |
||||
} |
||||
open { |
||||
if {[string match "==== Contents of test case:" $ln]} { |
||||
dict set test_case_state stage contents |
||||
} elseif {[string match "==== * FAILED" $ln]} { |
||||
set line_inner [string range $ln 5 end-7] ;#trim leading ====<space> and trailing <space>FAILED |
||||
if {[string match "$line_inner*" [dict get $test_case_state test_openingtext]]} { |
||||
dict set test_case_state stage "" |
||||
dict set test_case_state test_status "" |
||||
dict set test_case_state test_openingtext "" |
||||
# add to test_case_results list |
||||
set test_description [string trim [string range [dict get $test_case_state test_openingtext] [string length $line_inner] end]] |
||||
dict lappend results test_case_results [dict create {*}{ |
||||
} test_name $line_inner {*}{ |
||||
} test_description $test_description {*}{ |
||||
} test_status FAILED {*}{ |
||||
} test_output "" {*}{ |
||||
} |
||||
] |
||||
} else { |
||||
} |
||||
} |
||||
dict append results out "<stdout><$pkg> $ln" \n |
||||
} |
||||
contents { |
||||
|
||||
#we are in the contents section for a test case, so we should ignore any lines that look like they might be the closing line until we encounter the actual closing line that matches the test name prefix from the opening line. |
||||
#puts stdout "<stdout><$pkg> $ln" |
||||
if {[string match "==== * FAILED" $ln]} { |
||||
set line_inner [string range $ln 5 end-7] ;#trim leading ====<space> and trailing <space>FAILED |
||||
if {[string match "$line_inner*" [dict get $test_case_state test_openingtext]]} { |
||||
dict set test_case_state stage "" |
||||
dict set test_case_state test_status "" |
||||
dict set test_case_state test_openingtext "" |
||||
# add to test_case_results list |
||||
set test_description [string trim [string range [dict get $test_case_state test_openingtext] [string length $line_inner] end]] |
||||
dict lappend results test_case_results [dict create {*}{ |
||||
} test_name $line_inner {*}{ |
||||
} test_description $test_description {*}{ |
||||
} test_status FAILED {*}{ |
||||
} test_output "" {*}{ |
||||
} |
||||
] |
||||
} else { |
||||
#we are in the contents section for a test case, but we have not yet encountered the closing line for that section |
||||
#so we should ignore any lines that look like they might be the closing line until we encounter the actual closing line that matches the test name prefix from the opening line. |
||||
} |
||||
} |
||||
dict append results out "<stdout><$pkg> $ln" \n |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
if {[string trim $ln] ne ""} { |
||||
#puts stdout "<stdout> $ln" |
||||
dict append results out "<stdout> $ln" \n |
||||
} else { |
||||
#puts -nonewline stdout "\n" |
||||
dict append results out "\n" |
||||
} |
||||
#puts stdout "$i" |
||||
} |
||||
} |
||||
#flush stdout |
||||
} |
||||
stderr { |
||||
#puts stderr "<stderr> [punk::ansi::ansistring VIEW -lf 2 -cr 1 $chunk]" |
||||
set chunkview [punk::ansi::ansistring VIEW -lf 2 -cr 1 $chunk] |
||||
foreach ln [split $chunkview \n] { |
||||
#puts stderr "<stderr> $ln" |
||||
dict append results err "<stderr> $ln" \n |
||||
} |
||||
#flush stderr |
||||
} |
||||
exitcode { |
||||
dict set results exitcode $chunk |
||||
} |
||||
default { |
||||
#puts stderr "<${what}> $chunk" |
||||
dict append results err "<${what}> $chunk" \n |
||||
#flush stderr |
||||
} |
||||
} |
||||
} |
||||
return $results |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::tcltestrun::tm_path_additional_ifneeded |
||||
@cmd -name punk::tcltestrun::tm_path_additional_ifneeded\ |
||||
-summary\ |
||||
"Add package ifneeded definitions for any unbuilt #modpod modules found in the specified path."\ |
||||
-help\ |
||||
"Add package ifneeded definitions for any unbuilt #modpod modules found in the specified path." |
||||
@leaders |
||||
@opts |
||||
@values -min 1 -max 1 |
||||
tmpath -type string -help\ |
||||
"Path to a folder containing unbuilt #modpod modules." |
||||
}] |
||||
} |
||||
proc tm_path_additional_ifneeded {tmpath} { |
||||
#If the supplied tmpath contains any unbuilt #modpod modules, we want to add package ifneeded definitions for those modules. |
||||
#return a single script containing the package ifneeded definitions. |
||||
|
||||
#when running against unbuilt modules - we want to ensure that the unbuilt versions of any modules are used rather than any installed versions - so we add package ifneeded definitions for the unbuilt versions of any modules that are present. |
||||
# add 'package ifneeded' definitions for unbuilt #modpod modules. |
||||
#first gather subdirectories of modules that contain #modpod-*-999999.0a1.0 in their name - these should be the unbuilt versions of zip based modules. |
||||
#set subfolders [punk::path::subfolders -recursive $tmpath -match */#modpod-*-999999.0a1.0] |
||||
#'punk::path::subfolders' currently only supports negative matching with -exclude, so we have to filter for the positive match ourselves. |
||||
set subfolders [punk::path::subfolders -recursive -exclude {**/_build/** **/_build} $tmpath] |
||||
set script "" |
||||
foreach sub $subfolders { |
||||
#In most cases we could use string match - but the * within modpod-*-999999.0a1.0 could match a forward slash which could then match some other file under a #modpod- folder structure, |
||||
#so we use globmatchpath which treats * as matching any characters except path separators. |
||||
if {[punk::path::globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { |
||||
set modname [file tail $sub] |
||||
set modname [string range $modname 8 end-13] ;#strip off #modpod- and -999999.0a1.0 |
||||
set modpath [file join $sub "$modname-999999.0a1.0.tm"] |
||||
#calculate fully qualified module name based on path relative to the modules folder we added to the tcl::tm path. |
||||
set relpath [punk::path::relative $project_root/src/modules [file dirname $sub]] |
||||
if {$relpath eq "."} { |
||||
set relpath "" |
||||
set fullmodname $modname |
||||
} else { |
||||
set components [file split $relpath] |
||||
set fullmodname [join $components ::]::$modname |
||||
} |
||||
#!!!! |
||||
#todo - review whether we also need to add the path to the module's folder to the auto_path to ensure that any 'package require' calls within the module will find the unbuilt version of any dependencies. |
||||
#we probably do need to do this - otherwise if there is an installed version of a dependency it could be loaded instead of the unbuilt version which is likely not what we want when running tests against unbuilt modules. |
||||
|
||||
if {[file exists $modpath]} { |
||||
puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $fullmodname at path $modpath" |
||||
#package ifneeded $modname 999999.0a1.0 [list source $modpath] |
||||
append script [list package ifneeded $fullmodname 999999.0a1.0 [list source $modpath]] { ;} \n |
||||
} else { |
||||
puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $fullmodname at path $modpath" |
||||
} |
||||
} |
||||
} |
||||
return $script |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::tcltestrun::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::tcltestrun::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::tcltestrun { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::tcltestrun" |
||||
@package -name "punk::tcltestrun" -help\ |
||||
"Support package for running tcltest scripts and parsing their output. |
||||
This is primarily intended to be used with punk::shellrun when executing |
||||
tcltest scripts and parsing their output." |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::tcltestrun |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::tcltestrun |
||||
Support package for running tcltest scripts and parsing their output. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "BSD" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::tcltestrun::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{"Julian Noble" julian@precisium.com.au}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_note {} { |
||||
punk::args::lib::tstr -return string { |
||||
punk::tcltestrun is primarily intended to be used with punk::shellrun when executing |
||||
tcltest scripts and parsing their output. |
||||
e.g in src/tests/runtests.tcl |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::tcltestrun::about" |
||||
dict set overrides @cmd -name "punk::tcltestrun::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::tcltestrun |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::tcltestrun::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::tcltestrun::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::tcltestrun::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::tcltestrun::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::tcltestrun |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tcltestrun [tcl::namespace::eval punk::tcltestrun { |
||||
variable pkg punk::tcltestrun |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
Loading…
Reference in new issue