jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

tcltestrun 0.3.0: fix tm_path_additional_ifneeded project_root scope bug + dynamic #modpod version extraction 

tm_path_additional_ifneeded referenced an out-of-scope \ variable that was never a parameter or local, causing 'can't read project_root: no such variable' whenever a #modpod module was found. The proc now requires project_root as a 2nd parameter. Additionally, the #modpod directory pattern was hardcoded to 999999.0a1.0 which the build system replaces with the real version (e.g 0.3.0) during make.tcl modules — breaking pattern matching in built bootsupport copies that looked for #modpod-*-0.3.0 directories which don't exist on disk. The proc now extracts both modname and version dynamically from the #modpod-<modname>-<version> directory name by splitting on the last dash, making it version-agnostic. Punk::lib::tm_version_magic convention was considered but dynamic extraction is preferred here as it will also work in the future src package_mode boot context where punk modules aren't loaded yet.
master
Julian Noble 2 weeks ago
parent
e3e6123160
commit
4bd27338e7
3 changed files with 98 additions and 34 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 96
      src/bootsupport/modules/punk/tcltestrun-0.3.0.tm
  2. 31
      src/modules/punk/tcltestrun-999999.0a1.0.tm
  3. 5
      src/modules/punk/tcltestrun-buildversion.txt

96
src/bootsupport/modules/punk/tcltestrun-0.1.0.tm → src/bootsupport/modules/punk/tcltestrun-0.3.0.tm
Unescape View File

@ -8,7 +8,7 @@
# (C) 2026 # (C) 2026
# #
# @@ Meta Begin # @@ Meta Begin
# Application punk::tcltestrun 0.1.0 # Application punk::tcltestrun 0.3.0
# Meta platform tcl # Meta platform tcl
# Meta license BSD # Meta license BSD
# @@ Meta End # @@ Meta End
@ -93,14 +93,18 @@ tcl::namespace::eval punk::tcltestrun {
#'took' lines can occur for both passing and failing tests, but will occur before the ++++ PASSED or ==== FAILED lines for a test case, #'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]} { if {[string match "++++ * took * µs" $ln_trimright]} {
dict append results out "<stdout><$pkg> $ln" \n dict append results out "<stdout><$pkg> $ln" \n
set nm [lindex $ln 1] # 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]] dict set test_case_time $nm [dict create microseconds [lindex $ln end-1]]
continue continue
} }
if {[string match "++++ * PASSED" $ln_trimright]} { if {[string match "++++ * PASSED" $ln_trimright]} {
dict append results out "<stdout><$pkg> $ln" \n dict append results out "<stdout><$pkg> $ln" \n
set nm [lindex $ln 1] # " 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]} { if {[dict exists $test_case_time $nm]} {
dict set results testcase_passes $nm [dict get $test_case_time $nm] dict set results testcase_passes $nm [dict get $test_case_time $nm]
} else { } else {
@ -111,8 +115,11 @@ tcl::namespace::eval punk::tcltestrun {
# ++++ <testname_words> SKIPPED: <constraint/reason> # ++++ <testname_words> SKIPPED: <constraint/reason>
if {[string match "++++ * SKIPPED: *" $ln_trimright]} { if {[string match "++++ * SKIPPED: *" $ln_trimright]} {
dict append results out "<stdout><$pkg> $ln" \n dict append results out "<stdout><$pkg> $ln" \n
set nm [lindex $ln 1] # Anchor on " SKIPPED:" (with leading space) so the name is extracted as the substring before it.
set reason [string trim [string range $ln [expr {[string first "SKIPPED:" $ln] + 8}] end]] # 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] dict set results testcase_constraintskips $nm [list reason $reason]
continue continue
} }
@ -222,6 +229,33 @@ tcl::namespace::eval punk::tcltestrun {
} }
# 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]} { 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 test_case_fail test_body "$ln\n"
dict append results out "<stdout><$pkg> $ln" \n dict append results out "<stdout><$pkg> $ln" \n
@ -247,8 +281,17 @@ tcl::namespace::eval punk::tcltestrun {
} errorcode [dict get $test_case_fail errorcode] {*}{ } errorcode [dict get $test_case_fail errorcode] {*}{
} }
] ]
if {[dict exists $test_case_time $nm]} { if {[dict exists $test_case_time $test_name]} {
dict set results testcase_fails $nm microseconds [dict get $test_case_time $nm microseconds] 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 stage ""
@ -257,6 +300,10 @@ tcl::namespace::eval punk::tcltestrun {
dict set test_case_fail test_body "" dict set test_case_fail test_body ""
dict set test_case_fail returncode "" dict set test_case_fail returncode ""
dict set test_case_fail errorcode "" 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 dict append results out "<stdout><$pkg> $ln" \n
continue ;#skip to next line. continue ;#skip to next line.
@ -312,31 +359,39 @@ tcl::namespace::eval punk::tcltestrun {
"Add package ifneeded definitions for any unbuilt #modpod modules found in the specified path." "Add package ifneeded definitions for any unbuilt #modpod modules found in the specified path."
@leaders @leaders
@opts @opts
@values -min 1 -max 1 @values -min 2 -max 2
tmpath -type string -help\ tmpath -type string -help\
"Path to a folder containing unbuilt #modpod modules." "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} { 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. #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. #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. #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. # add 'package ifneeded' definitions for unbuilt #modpod modules.
#first gather subdirectories of modules that contain #modpod-*-0.1.0 in their name - these should be the unbuilt versions of zip based modules. #first gather subdirectories of modules that contain #modpod-*-<version> in their name - these should be the unbuilt versions of zip based modules.
#set subfolders [punk::path::subfolders -recursive $tmpath -match */#modpod-*-0.1.0]
#'punk::path::subfolders' currently only supports negative matching with -exclude, so we have to filter for the positive match ourselves. #'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 subfolders [punk::path::subfolders -recursive -exclude {**/_build/** **/_build} $tmpath]
set script "" set script ""
foreach sub $subfolders { foreach sub $subfolders {
#In most cases we could use string match - but the * within modpod-*-0.1.0 could match a forward slash which could then match some other file under a #modpod- folder structure, #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. #so we use globmatchpath which treats * as matching any characters except path separators.
if {[punk::path::globmatchpath "**/#modpod-*-0.1.0" $sub]} { if {[punk::path::globmatchpath "**/#modpod-*" $sub]} {
set modname [file tail $sub] set tail [file tail $sub]
set modname [string range $modname 8 end-13] ;#strip off #modpod- and -0.1.0 # Extract modname and version from the #modpod-<modname>-<version> directory name.
set modpath [file join $sub "$modname-0.1.0.tm"] # 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. #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]] set relpath [punk::path::relative [file join $project_root src modules] [file dirname $sub]]
if {$relpath eq "."} { if {$relpath eq "."} {
set relpath "" set relpath ""
set fullmodname $modname set fullmodname $modname
@ -350,10 +405,9 @@ tcl::namespace::eval punk::tcltestrun {
if {[file exists $modpath]} { if {[file exists $modpath]} {
puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $fullmodname at path $modpath" puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $fullmodname at path $modpath"
#package ifneeded $modname 0.1.0 [list source $modpath] append script [list package ifneeded $fullmodname $modver [list source $modpath]] { ;} \n
append script [list package ifneeded $fullmodname 0.1.0 [list source $modpath]] { ;} \n
} else { } else {
puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $fullmodname at path $modpath" puts stderr "runtestmodules.tcl warning: expected tcl module file not found for modpod module $fullmodname at path $modpath"
} }
} }
} }
@ -489,7 +543,7 @@ namespace eval ::punk::args::register {
package provide punk::tcltestrun [tcl::namespace::eval punk::tcltestrun { package provide punk::tcltestrun [tcl::namespace::eval punk::tcltestrun {
variable pkg punk::tcltestrun variable pkg punk::tcltestrun
variable version variable version
set version 0.1.0 set version 0.3.0
}] }]
return return

31
src/modules/punk/tcltestrun-999999.0a1.0.tm
Unescape View File

@ -359,31 +359,39 @@ tcl::namespace::eval punk::tcltestrun {
"Add package ifneeded definitions for any unbuilt #modpod modules found in the specified path." "Add package ifneeded definitions for any unbuilt #modpod modules found in the specified path."
@leaders @leaders
@opts @opts
@values -min 1 -max 1 @values -min 2 -max 2
tmpath -type string -help\ tmpath -type string -help\
"Path to a folder containing unbuilt #modpod modules." "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} { 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. #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. #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. #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. # 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. #first gather subdirectories of modules that contain #modpod-*-<version> 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. #'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 subfolders [punk::path::subfolders -recursive -exclude {**/_build/** **/_build} $tmpath]
set script "" set script ""
foreach sub $subfolders { 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, #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. #so we use globmatchpath which treats * as matching any characters except path separators.
if {[punk::path::globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { if {[punk::path::globmatchpath "**/#modpod-*" $sub]} {
set modname [file tail $sub] set tail [file tail $sub]
set modname [string range $modname 8 end-13] ;#strip off #modpod- and -999999.0a1.0 # Extract modname and version from the #modpod-<modname>-<version> directory name.
set modpath [file join $sub "$modname-999999.0a1.0.tm"] # 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. #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]] set relpath [punk::path::relative [file join $project_root src modules] [file dirname $sub]]
if {$relpath eq "."} { if {$relpath eq "."} {
set relpath "" set relpath ""
set fullmodname $modname set fullmodname $modname
@ -397,8 +405,7 @@ tcl::namespace::eval punk::tcltestrun {
if {[file exists $modpath]} { if {[file exists $modpath]} {
puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $fullmodname at path $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 $modver [list source $modpath]] { ;} \n
append script [list package ifneeded $fullmodname 999999.0a1.0 [list source $modpath]] { ;} \n
} else { } else {
puts stderr "runtestmodules.tcl warning: expected tcl module file not found for modpod module $fullmodname at path $modpath" puts stderr "runtestmodules.tcl warning: expected tcl module file not found for modpod module $fullmodname at path $modpath"
} }

5
src/modules/punk/tcltestrun-buildversion.txt
Unescape View File

@ -1,5 +1,8 @@
0.2.0 0.3.0
#First line must be a semantic version number #First line must be a semantic version number
#all other lines are ignored. #all other lines are ignored.
#0.3.0 - breaking: tm_path_additional_ifneeded now requires project_root as a 2nd parameter to fix out-of-scope $project_root bug that caused 'no such variable' errors whenever #modpod modules were found
#0.3.0 - fix: #modpod version pattern is now extracted dynamically from directory name instead of hardcoded, preventing build-system version replacement from breaking pattern matching in built bootsupport copies
#0.3.0 - fix: runtests.tcl second tm_path_additional_ifneeded call now passes modules_tcl$tcl_major instead of modules (copy-paste bug)
#0.2.0 - parse_testrun now preserves errorinfo, result_was, result_expected in testcase_fails entries (backward-compatible additive keys) #0.2.0 - parse_testrun now preserves errorinfo, result_was, result_expected in testcase_fails entries (backward-compatible additive keys)
#0.2.0 - fix test name extraction: took/PASSED/SKIPPED handlers and microseconds lookup now key by the full test name instead of the first word (lindex $ln 1), which corrupted timing associations and testcase_passes/testcase_constraintskips keys for multi-word test names #0.2.0 - fix test name extraction: took/PASSED/SKIPPED handlers and microseconds lookup now key by the full test name instead of the first word (lindex $ln 1), which corrupted timing associations and testcase_passes/testcase_constraintskips keys for multi-word test names

Write Preview
Loading…
Cancel
Save