jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
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.
915 Commits
1 Branch
1 Tag
191 MiB
 
 
 
 
 
 
Tree: 75cffe21f3
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '75cffe21f3'
${ noResults }
punkshell/src/modules/punk/tcltestrun-999999.0a1.0.tm

549 lines
33 KiB
Raw Blame History

# -*- 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 testcase_fails [dict create] ;#dict of dicts keyed on testname with keys test_description, test_content, test_status, returncode, errorcode
dict set results testcase_passes [dict create] ;#dict of dicts keyed on testname with keys microseconds
dict set results testcase_constraintskips [list]
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_fail [dict create]
dict set test_case_fail stage ""; #""|"open"|"contents"
dict set test_case_fail test_status "FAILED"; #default - may be changed to "ERROR" if we encounter an error line in the test case output.
dict set test_case_fail 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.
dict set test_case_fail test_body ""
dict set test_case_fail returncode ""
dict set test_case_fail errorcode ""
set test_case_pass [dict create]
#dict set test_case_pass microseconds 0
set test_case_time [dict create]
switch -- $what {
stdout {
foreach ln [split $chunk \n] {
set ln_trimright [string trimright $ln]
incr i
set fail_stage [dict get $test_case_fail stage]
if {$fail_stage eq ""} {
#not within a test case failure section, so we can parse summary lines and other output normally.
#'took' lines can occur for both passing and failing tests, but will occur before the ++++ PASSED or ==== FAILED lines for a test case,
if {[string match "++++ * took * µs" $ln_trimright]} {
dict append results out "<stdout><$pkg> $ln" \n
# The test name may itself contain the word "took", so locate the " took " delimiter from the right (last occurrence).
# Name is the substring between "++++ " (5 chars) and the last " took ".
set took_pos [string last " took " $ln_trimright]
set nm [string range $ln_trimright 5 [expr {$took_pos - 1}]]
dict set test_case_time $nm [dict create microseconds [lindex $ln end-1]]
continue
}
if {[string match "++++ * PASSED" $ln_trimright]} {
dict append results out "<stdout><$pkg> $ln" \n
# " PASSED" is terminal (7 chars); trim "++++ " (5 chars) from front and " PASSED" from end to get the full name.
set nm [string range $ln_trimright 5 end-7]
if {[dict exists $test_case_time $nm]} {
dict set results testcase_passes $nm [dict get $test_case_time $nm]
} else {
dict set results testcase_passes $nm [dict create]
}
continue
}
# ++++ <testname_words> SKIPPED: <constraint/reason>
if {[string match "++++ * SKIPPED: *" $ln_trimright]} {
dict append results out "<stdout><$pkg> $ln" \n
# Anchor on " SKIPPED:" (with leading space) so the name is extracted as the substring before it.
# Leftmost occurrence is used because the reason is free text after the delimiter and may itself contain "SKIPPED:".
set skip_pos [string first " SKIPPED:" $ln_trimright]
set nm [string range $ln_trimright 5 [expr {$skip_pos - 1}]]
set reason [string trim [string range $ln_trimright [expr {$skip_pos + 9}] end]]
dict set results testcase_constraintskips $nm [list reason $reason]
continue
}
if {[string match "Tests ended at*" $ln]} {
#review - what outputs this?
#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 "==== * FAILED" $ln_trimright]} {
#entry point to failing test section
dict set test_case_fail stage open
set line_inner [string range $ln 5 end-7] ;#trim leading ====<space> and trailing <space>FAILED
dict set test_case_fail test_openingtext $line_inner
}
dict append results out "<stdout><$pkg> $ln" \n
#depending on whether -verbose contains body(b) pass(p) skip(s) error(e) msec(m) usec(u)
#we may get ---- or ++++ lines.
#the parse_testrun function is intended to run in a context where all these -verbose options are enabled. (except msec)
#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
} else {
#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
#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.
if {$fail_stage eq "error" && ![string match "==== * FAILED" $ln_trimright]} {
if {[string match "---- errorInfo: *" $ln]} {
dict append results out "<stdout><$pkg> $ln" \n
dict append test_case_fail errorinfo "[string range $ln 15 end]\n"
continue
} elseif {[string match "---- errorCode: *" $ln]} {
dict set test_case_fail errorcode "[string range $ln 15 end]"
dict append results out "<stdout><$pkg> $ln" \n
continue
} elseif {[string match "---- *" $ln]} {
dict append results out "<stdout><$pkg> $ln" \n
continue
} else {
dict append test_case_fail errorinfo "$ln\n"
dict append results out "<stdout><$pkg> $ln" \n
continue
}
}
# Result capture for FAILED (non-error) tests: grab "---- Result was:" and "---- Result should have been" blocks.
if {$fail_stage eq "contents"} {
if {[dict exists $test_case_fail result_stage] && [dict get $test_case_fail result_stage] ne ""} {
if {[string match "---- *" $ln] || [string match "==== * FAILED" $ln_trimright] || [string match "++++ *" $ln]} {
dict set test_case_fail result_stage ""
# fall through to normal handling below (do not continue)
} else {
dict append test_case_fail [dict get $test_case_fail result_stage] "$ln\n"
dict append results out "<stdout><$pkg> $ln" \n
continue
}
} elseif {[string match "---- Result was:*" $ln]} {
dict set test_case_fail result_stage "result_was"
if {![dict exists $test_case_fail result_was]} {
dict set test_case_fail result_was ""
}
dict append results out "<stdout><$pkg> $ln" \n
continue
} elseif {[string match "---- Result should have been*" $ln]} {
dict set test_case_fail result_stage "result_expected"
if {![dict exists $test_case_fail result_expected]} {
dict set test_case_fail result_expected ""
}
dict append results out "<stdout><$pkg> $ln" \n
continue
}
}
if {$fail_stage eq "contents" && ![string match "---- *" $ln] && ![string match "++++ *" $ln] && ![string match "==== * FAILED" $ln_trimright]} {
dict append test_case_fail test_body "$ln\n"
dict append results out "<stdout><$pkg> $ln" \n
continue
}
if {$fail_stage eq "open" && [string match "==== Contents of test case:*" $ln]} {
dict set test_case_fail stage contents
dict append results out "<stdout><$pkg> $ln" \n
continue ;#skip to next line.
}
if {[string match "==== * FAILED" $ln_trimright]} {
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_fail test_openingtext]]} {
set test_description [string trim [string range [dict get $test_case_fail test_openingtext] [string length $line_inner] end]]
set test_name [string trim $line_inner]
# add to testcase_fails list
dict set results testcase_fails $test_name [dict create {*}{
} test_description $test_description {*}{
} test_body [dict get $test_case_fail test_body] {*}{
} test_status [dict get $test_case_fail test_status] {*}{
} returncode [dict get $test_case_fail returncode] {*}{
} errorcode [dict get $test_case_fail errorcode] {*}{
}
]
if {[dict exists $test_case_time $test_name]} {
dict set results testcase_fails $test_name microseconds [dict get $test_case_time $test_name microseconds]
}
if {[dict exists $test_case_fail errorinfo] && [dict get $test_case_fail errorinfo] ne ""} {
dict set results testcase_fails $test_name errorinfo [dict get $test_case_fail errorinfo]
}
if {[dict exists $test_case_fail result_was] && [dict get $test_case_fail result_was] ne ""} {
dict set results testcase_fails $test_name result_was [dict get $test_case_fail result_was]
}
if {[dict exists $test_case_fail result_expected] && [dict get $test_case_fail result_expected] ne ""} {
dict set results testcase_fails $test_name result_expected [dict get $test_case_fail result_expected]
}
dict set test_case_fail stage ""
dict set test_case_fail test_status "FAILED" ;#default - may be changed to "ERROR" if we encounter an error line in the test case output.
dict set test_case_fail test_openingtext ""
dict set test_case_fail test_body ""
dict set test_case_fail returncode ""
dict set test_case_fail errorcode ""
dict unset test_case_fail errorinfo
dict unset test_case_fail result_was
dict unset test_case_fail result_expected
dict unset test_case_fail result_stage
dict append results out "<stdout><$pkg> $ln" \n
continue ;#skip to next line.
}
}
if {[string match "---- Test generated error;*" $ln]} {
dict append results out "<stdout><$pkg> $ln" \n
dict set test_case_fail stage "error"
dict set test_case_fail test_status "ERROR"
set posn [string first "Return code was:" $ln]
if {$posn >= 0} {
set returncode [string trim [string range $ln [expr {$posn + 16}] end]]
dict set test_case_fail returncode $returncode
}
continue
}
dict append results out "<stdout><$pkg> $ln" \n
}
}
#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 2 -max 2
tmpath -type string -help\
"Path to a folder containing unbuilt #modpod modules."
project_root -type string -help\
"Project root directory used to compute the fully qualified module name from the #modpod directory's path relative to <project_root>/src/modules."
}]
}
proc tm_path_additional_ifneeded {tmpath project_root} {
#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-*-<version> in their name - these should be the unbuilt versions of zip based modules.
#'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-*-<version> 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-*" $sub]} {
set tail [file tail $sub]
# Extract modname and version from the #modpod-<modname>-<version> directory name.
# The directory name format is: #modpod-<modname>-<version>
# Strip the leading "#modpod-" (8 chars), then split on the last "-" to separate modname from version.
set rest [string range $tail 8 end]
set last_dash [string last "-" $rest]
if {$last_dash < 0} { continue }
set modname [string range $rest 0 [expr {$last_dash - 1}]]
set modver [string range $rest [expr {$last_dash + 1}] end]
set modpath [file join $sub "$modname-$modver.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 [file join $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"
append script [list package ifneeded $fullmodname $modver [list source $modpath]] { ;} \n
} else {
puts stderr "runtestmodules.tcl warning: expected tcl module file 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