23 changed files with 1754 additions and 628 deletions
@ -1,66 +0,0 @@
|
||||
#!tclsh |
||||
#This script uses shellfilter::run calls under the hood |
||||
lassign [split [info tclversion] .] tcl_major tcl_minor |
||||
|
||||
set script_dir [file dirname [info script]] |
||||
|
||||
#------------------------------------ |
||||
#use the unbuilt modules/libraries under development rather than the installed versions. |
||||
set original_tmlist [tcl::tm::list] |
||||
tcl::tm::remove {*}$original_tmlist |
||||
tcl::tm::add [file normalize $script_dir/../modules] ;#ie <projectroot>/src/modules |
||||
tcl::tm::add [file normalize $script_dir/../modules_tcl$tcl_major] |
||||
tcl::tm::add {*}[lreverse $original_tmlist] |
||||
set libdir [file normalize $script_dir/../lib] |
||||
set libvdir [file normalize $script_dir/../lib/tcl$tcl_major] |
||||
if {$libdir ni $::auto_path} { |
||||
lappend ::auto_path $libdir |
||||
} |
||||
if {$libvdir ni $::auto_path} { |
||||
lappend ::auto_path $libvdir |
||||
} |
||||
#------------------------------------ |
||||
package require tcltest |
||||
|
||||
|
||||
package require punk |
||||
package require punk::args |
||||
punk::args::define { |
||||
@id -id (script)::runtestmodules |
||||
@cmd -name runtestmodules -help\ |
||||
"Run test:: modules that support the packagetest api |
||||
(have RUN command)" |
||||
-tcltestoptions -type dict -default "" -help\ |
||||
"pairs of flags/values that will be passed to tcltest::configure before running the tests. |
||||
For example, to run only tests with names matching *foo* and *bar* you could use: |
||||
-tcltestoptions {-file {*foo* *bar*}} |
||||
" |
||||
@values -min 0 -max -1 |
||||
glob -type string -multiple 1 -optional 1 -help\ |
||||
" names or glob patterns of test files to run." |
||||
} |
||||
set argd [punk::args::parse $::argv withid (script)::runtestmodules] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set tcltestoptions [dict get $opts -tcltestoptions] |
||||
if {![dict exists $received glob]} { |
||||
set file_globs [list *.test] |
||||
} else { |
||||
set file_globs [dict get $values glob] |
||||
} |
||||
|
||||
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 |
||||
@ -1,33 +0,0 @@
|
||||
package require tcltest |
||||
tcltest::configure {*}$::argv |
||||
|
||||
|
||||
package require overtype |
||||
package require punk::path |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
|
||||
test globmatchpath_basic {Test single star between slashes pathglob argument will match exactly a single level}\ |
||||
-setup $common -body { |
||||
|
||||
set result [list {*}{ |
||||
} [punk::path::globmatchpath /etc/*/*.doc /etc/A/test.doc] {*}{ |
||||
} [punk::path::globmatchpath /etc/*/*.doc /etc/A/B/test.doc] {*}{ |
||||
} [punk::path::globmatchpath /etc/*/*.doc /etc/test.doc] |
||||
] |
||||
|
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list {*}{ |
||||
1 0 0 |
||||
}] |
||||
|
||||
} |
||||
|
||||
tcltest::cleanupTests ;#needed to produce test summary. |
||||
@ -0,0 +1,410 @@
|
||||
package require tcltest |
||||
tcltest::configure {*}$::argv |
||||
|
||||
|
||||
package require punk::lib |
||||
package require punk::path |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
variable subfolders_tree { |
||||
set sub_prevdir [pwd] |
||||
set sub_newbase [punk::lib::tempdir_newfolder -prefix punk_path_subfolders] |
||||
cd $sub_newbase |
||||
set sub_tree_tail __punk_path_subfolders_test__ |
||||
set sub_tree_root [file join $sub_newbase $sub_tree_tail] |
||||
file mkdir [file join $sub_tree_root keep] |
||||
file mkdir [file join $sub_tree_root src vfs deep] |
||||
file mkdir [file join $sub_tree_root aside child grandchild] |
||||
} |
||||
|
||||
variable subfolders_cleanup { |
||||
cd $sub_prevdir |
||||
file delete -force $sub_newbase |
||||
} |
||||
|
||||
variable repeated_subfolders_tree { |
||||
set rep_prevdir [pwd] |
||||
set rep_newbase [punk::lib::tempdir_newfolder -prefix punk_path_repeated_subfolders] |
||||
cd $rep_newbase |
||||
set rep_tree_tail __punk_path_repeated_subfolders_test__ |
||||
set rep_tree_root [file join $rep_newbase $rep_tree_tail] |
||||
file mkdir [file join $rep_tree_root alpha a a leaf deeper] |
||||
file mkdir [file join $rep_tree_root alpha a x a leaf deeper] |
||||
file mkdir [file join $rep_tree_root alpha a xx a leaf deeper] |
||||
file mkdir [file join $rep_tree_root alpha a x y a leaf deeper] |
||||
file mkdir [file join $rep_tree_root alpha a x y z a leaf deeper] |
||||
file mkdir [file join $rep_tree_root alpha a x y z keep] |
||||
file mkdir [file join $rep_tree_root alpha a q aa leaf deeper] |
||||
file mkdir [file join $rep_tree_root alpha aa x a leaf deeper] |
||||
} |
||||
|
||||
variable repeated_subfolders_cleanup { |
||||
cd $rep_prevdir |
||||
file delete -force $rep_newbase |
||||
} |
||||
|
||||
variable treefilenames_tree { |
||||
set tf_prevdir [pwd] |
||||
set tf_newbase [punk::lib::tempdir_newfolder -prefix punk_path_treefilenames] |
||||
cd $tf_newbase |
||||
set tf_tree_tail __punk_path_treefilenames_test__ |
||||
set tf_tree_root [file join $tf_newbase $tf_tree_tail] |
||||
file mkdir [file join $tf_tree_root keep] |
||||
file mkdir [file join $tf_tree_root src vfs deep] |
||||
file mkdir [file join $tf_tree_root aside child grandchild] |
||||
foreach relpath { |
||||
keep/keep.txt |
||||
src/srcroot.txt |
||||
src/vfs/vfs.txt |
||||
src/vfs/deep/deep.txt |
||||
aside/aside.txt |
||||
aside/child/child.txt |
||||
aside/child/grandchild/grandchild.txt |
||||
b/other/other.txt |
||||
} { |
||||
set filepath [file join $tf_tree_root $relpath] |
||||
file mkdir [file dirname $filepath] |
||||
set channel [open $filepath w] |
||||
puts $channel $relpath |
||||
close $channel |
||||
} |
||||
} |
||||
|
||||
variable treefilenames_cleanup { |
||||
cd $tf_prevdir |
||||
file delete -force $tf_newbase |
||||
} |
||||
|
||||
test globmatchpath_basic {Test single star between slashes pathglob argument will match exactly a single level} \ |
||||
-setup $common -body { |
||||
set result [list \ |
||||
[punk::path::globmatchpath /etc/*/*.doc /etc/A/test.doc] \ |
||||
[punk::path::globmatchpath /etc/*/*.doc /etc/A/B/test.doc] \ |
||||
[punk::path::globmatchpath /etc/*/*.doc /etc/test.doc] \ |
||||
] |
||||
} \ |
||||
-cleanup { |
||||
} \ |
||||
-result {1 0 0} |
||||
|
||||
test subfolders_exclude_trailing_doublestar {Trailing /** prunes descendants but keeps the matching base directory} \ |
||||
-setup $subfolders_tree -body { |
||||
set result [lsort [punk::path::subfolders -recursive -exclude-paths {**/src/**} .]] |
||||
set expected [lsort [list \ |
||||
[file join . $sub_tree_tail] \ |
||||
[file join . $sub_tree_tail aside] \ |
||||
[file join . $sub_tree_tail aside child] \ |
||||
[file join . $sub_tree_tail aside child grandchild] \ |
||||
[file join . $sub_tree_tail keep] \ |
||||
[file join . $sub_tree_tail src] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_exclude_single_segment {Single-level excludes omit the node but still recurse into it} \ |
||||
-setup $subfolders_tree -body { |
||||
set result [lsort [punk::path::subfolders -recursive -exclude-paths {**/aside/*} .]] |
||||
set expected [lsort [list \ |
||||
[file join . $sub_tree_tail] \ |
||||
[file join . $sub_tree_tail aside] \ |
||||
[file join . $sub_tree_tail aside child grandchild] \ |
||||
[file join . $sub_tree_tail keep] \ |
||||
[file join . $sub_tree_tail src] \ |
||||
[file join . $sub_tree_tail src vfs] \ |
||||
[file join . $sub_tree_tail src vfs deep] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_exclude_exact_segment {Exact segment excludes omit the node but still traverse below it} \ |
||||
-setup $subfolders_tree -body { |
||||
set result [lsort [punk::path::subfolders -recursive -exclude-paths {**/aside} .]] |
||||
set expected [lsort [list \ |
||||
[file join . $sub_tree_tail] \ |
||||
[file join . $sub_tree_tail aside child] \ |
||||
[file join . $sub_tree_tail aside child grandchild] \ |
||||
[file join . $sub_tree_tail keep] \ |
||||
[file join . $sub_tree_tail src] \ |
||||
[file join . $sub_tree_tail src vfs] \ |
||||
[file join . $sub_tree_tail src vfs deep] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_exclude_combined_patterns {Subtree and exact excludes compose correctly in recursive traversal} \ |
||||
-setup $subfolders_tree -body { |
||||
set result [lsort [punk::path::subfolders -recursive -exclude-paths {**/src/** **/aside} .]] |
||||
set expected [lsort [list \ |
||||
[file join . $sub_tree_tail] \ |
||||
[file join . $sub_tree_tail aside child] \ |
||||
[file join . $sub_tree_tail aside child grandchild] \ |
||||
[file join . $sub_tree_tail keep] \ |
||||
[file join . $sub_tree_tail src] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_single_star {Repeated segment exclude with one wildcard segment prunes only that shape} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf deeper] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z keep] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_two_single_stars {Repeated segment exclude with two wildcard segments prunes only that shape} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/*/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x y a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a leaf deeper] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z a leaf] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_middle_doublestar {Repeated segment exclude with middle doublestar prunes repeated a descendants at multiple depths} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/**/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z a leaf] ni $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_nonmatching_pattern {Repeated path segments are retained when pattern literals do not match} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/b/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x a leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z a leaf] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_exact_boundary {Exact repeated segment excludes boundary node but still traverses below it} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/a} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x a] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_adjacent_literals {Adjacent repeated literals match only adjacent path segments} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_question_segment {Question mark wildcard matches exactly one character within one segment} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/?/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a xx a leaf] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_similar_names {Similar segment names do not match repeated literal a patterns accidentally} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a q aa leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha aa x a leaf] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_similar_name_patterns {Similar literal aa patterns match only their own segment shapes} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/aa/** **/aa/*/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a q aa] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a q aa leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha aa x a] in $result \ |
||||
&& [file join . $rep_tree_tail alpha aa x a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x a leaf] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test subfolders_repeated_segments_overlapping_patterns {Overlapping repeated segment excludes prune each matching shape independently} \ |
||||
-setup $repeated_subfolders_tree -body { |
||||
set result [punk::path::subfolders -recursive -exclude-paths {**/a/*/a/** **/a/*/*/a/**} .] |
||||
expr { \ |
||||
[file join . $rep_tree_tail alpha a x a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y a leaf] ni $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z a leaf] in $result \ |
||||
&& [file join . $rep_tree_tail alpha a x y z keep] in $result \ |
||||
} |
||||
} \ |
||||
-cleanup $repeated_subfolders_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_recurse_nested_positive_glob {Positive glob traversal reaches nested matches below unmatched ancestors} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [lsort [punk::path::treefilenames -sort none -directory . -include-paths {**/src/**} *.txt]] |
||||
set expected [lsort [list \ |
||||
[file join . $tf_tree_tail src vfs deep deep.txt] \ |
||||
[file join . $tf_tree_tail src vfs vfs.txt] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_nonexistent_glob_path_returns_empty {Non-matching glob_paths subtree should return no files} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [punk::path::treefilenames -sort none -directory . -include-paths {**/nonexistantfolder/**} *] |
||||
expr {$result eq [list]} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_tailbase_newbase_returns_tree_tail {Tailbase can trim returned filenames to the tree folder} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [lsort [punk::path::treefilenames -sort none -directory $tf_tree_root -tailbase $tf_newbase *.txt]] |
||||
set expected [lsort [list \ |
||||
[file join $tf_tree_tail aside aside.txt] \ |
||||
[file join $tf_tree_tail aside child child.txt] \ |
||||
[file join $tf_tree_tail aside child grandchild grandchild.txt] \ |
||||
[file join $tf_tree_tail b other other.txt] \ |
||||
[file join $tf_tree_tail keep keep.txt] \ |
||||
[file join $tf_tree_tail src srcroot.txt] \ |
||||
[file join $tf_tree_tail src vfs deep deep.txt] \ |
||||
[file join $tf_tree_tail src vfs vfs.txt] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_tailbase_tree_root_returns_tree_relative {Tailbase can trim returned filenames to paths below the search root} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [lsort [punk::path::treefilenames -sort none -directory $tf_tree_root -tailbase $tf_tree_root *.txt]] |
||||
set expected [lsort [list \ |
||||
[file join aside aside.txt] \ |
||||
[file join aside child child.txt] \ |
||||
[file join aside child grandchild grandchild.txt] \ |
||||
[file join b other other.txt] \ |
||||
[file join keep keep.txt] \ |
||||
[file join src srcroot.txt] \ |
||||
[file join src vfs deep deep.txt] \ |
||||
[file join src vfs vfs.txt] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_tailbase_exclude_paths_match_returned_paths {Exclude paths match tailbase-relative returned paths} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [lsort [punk::path::treefilenames -sort none -directory $tf_tree_root -tailbase $tf_tree_root -exclude-paths {aside aside/** src/vfs/**} *.txt]] |
||||
set expected [lsort [list \ |
||||
[file join b other other.txt] \ |
||||
[file join keep keep.txt] \ |
||||
[file join src srcroot.txt] \ |
||||
[file join src vfs vfs.txt] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_tailbase_include_paths_match_tree_root_relative_paths {Include paths match tailbase-relative paths below the tree root} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [lsort [punk::path::treefilenames -sort none -directory $tf_tree_root -tailbase $tf_tree_root -include-paths {src/**} *.txt]] |
||||
set expected [lsort [list \ |
||||
[file join src vfs deep deep.txt] \ |
||||
[file join src vfs vfs.txt] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_tailbase_include_paths_match_newbase_relative_paths {Include paths include the tree folder when tailbase is above the search root} \ |
||||
-setup $treefilenames_tree -body { |
||||
set include_path [file join $tf_tree_tail src **] |
||||
set result [lsort [punk::path::treefilenames -sort none -directory $tf_tree_root -tailbase $tf_newbase -include-paths [list $include_path] *.txt]] |
||||
set expected [lsort [list \ |
||||
[file join $tf_tree_tail src vfs deep deep.txt] \ |
||||
[file join $tf_tree_tail src vfs vfs.txt] \ |
||||
]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_tailbase_include_and_exclude_paths_share_relative_base {Include and exclude paths use the same tailbase-relative base} \ |
||||
-setup $treefilenames_tree -body { |
||||
set result [lsort [punk::path::treefilenames -sort none -directory $tf_tree_root -tailbase $tf_tree_root -include-paths {src/**} -exclude-paths {src/vfs/**} *.txt]] |
||||
set expected [list [file join src vfs vfs.txt]] |
||||
expr {$result eq $expected} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
|
||||
test treefilenames_rejects_internal_call_flags {Internal recursion state flags are not public API} \ |
||||
-setup $treefilenames_tree -body { |
||||
set results [list] |
||||
foreach arglist { |
||||
{-call-depth-internal 1 -directory . *} |
||||
{-call-subvector {a b} -directory . *} |
||||
{-call-allbelow 1 -directory . *} |
||||
} { |
||||
lappend results [catch {punk::path::treefilenames {*}$arglist}] |
||||
} |
||||
expr {$results eq {1 1 1}} |
||||
} \ |
||||
-cleanup $treefilenames_cleanup \ |
||||
-result 1 |
||||
} |
||||
|
||||
tcltest::cleanupTests ;#needed to produce test summary. |
||||
@ -0,0 +1,125 @@
|
||||
#!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] |
||||
set libdir [list] |
||||
set libdir [file normalize $project_root/src/bootsupport/lib] |
||||
set libvdir [file normalize $project_root/src/bootsupport/lib/tcl$tcl_major] |
||||
if {$libdir ni $::auto_path} { |
||||
lappend ::auto_path $libdir |
||||
} |
||||
if {$libvdir ni $::auto_path} { |
||||
lappend ::auto_path $libvdir |
||||
} |
||||
#------------------------------------ |
||||
|
||||
#------------------------------------ |
||||
#for the tests running in child processes, |
||||
#use the unbuilt modules/libraries under development rather than the installed versions. |
||||
set tmlist [list] |
||||
lappend tmlist [file normalize $test_base/../modules] ;#ie <projectroot>/src/modules |
||||
lappend tmlist [file normalize $test_base/../modules_tcl$tcl_major] |
||||
set libdirs [list] |
||||
lappend libdirs [file normalize $test_base/../lib] |
||||
lappend libdirs [file normalize $test_base/../lib/tcl$tcl_major] |
||||
if {$libdir ni $::auto_path} { |
||||
lappend ::auto_path $libdir |
||||
} |
||||
if {$libvdir ni $::auto_path} { |
||||
lappend ::auto_path $libvdir |
||||
} |
||||
#------------------------------------ |
||||
|
||||
|
||||
package require punk |
||||
package require punk::args |
||||
punk::args::define { |
||||
@id -id (script)::runtestmodules |
||||
@cmd -name runtestmodules -help\ |
||||
"Run test:: modules that support the packagetest api |
||||
(have RUN command)" |
||||
-tcltestoptions -type dict -default "" -help\ |
||||
"pairs of flags/values that will be passed to tcltest::configure before running the tests. |
||||
For example, to run tests with verbose settings: |
||||
-tcltestoptions {-verbose {body pass skip error usec}} |
||||
" |
||||
-include-paths -type list -default {**} -help\ |
||||
"list of glob patterns for paths. |
||||
Only test files under paths matching these patterns will be included. |
||||
For example, to only include test files under src/modules/test: |
||||
-include-paths {src/modules/test/**}" |
||||
@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. |
||||
" |
||||
} |
||||
|
||||
|
||||
puts "argv: $::argv" |
||||
|
||||
|
||||
set argd [punk::args::parse $::argv withid (script)::runtestmodules] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set tcltestoptions [dict get $opts -tcltestoptions] |
||||
set include_paths [dict get $opts -include-paths] |
||||
if {![dict exists $received glob]} { |
||||
set file_globs [list *.test] |
||||
} else { |
||||
set file_globs [dict get $values glob] |
||||
} |
||||
|
||||
|
||||
puts "tcltestoptions: $tcltestoptions" |
||||
puts "file_globs: $file_globs" |
||||
puts "test_base: $test_base" |
||||
|
||||
set thisexecutable [info nameofexecutable] |
||||
puts "executable: $thisexecutable" |
||||
|
||||
set exclude_files [list AGENTS.md *.tcl] |
||||
|
||||
set testfiles [punk::path::treefilenames -dir $test_base -exclude-files $exclude_files -include-paths $include_paths $file_globs] |
||||
foreach f $testfiles { |
||||
puts "test file: $f" |
||||
} |
||||
|
||||
exit 1 |
||||
|
||||
#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 |
||||
Binary file not shown.
Binary file not shown.
Loading…
Reference in new issue