Browse Source

punk::path and punk::lib fixes, ongoing work on testing framework

master
Julian Noble 1 day ago
parent
commit
34ba71be43
  1. 28
      src/modules/punk-999999.0a1.0.tm
  2. 3
      src/modules/punk/ansi-999999.0a1.0.tm
  3. 10
      src/modules/punk/char-999999.0a1.0.tm
  4. 310
      src/modules/punk/lib-999999.0a1.0.tm
  5. 2
      src/modules/punk/mix/cli-999999.0a1.0.tm
  6. 2
      src/modules/punk/mix/commandset/module-999999.0a1.0.tm
  7. 42
      src/modules/punk/mix/commandset/project-999999.0a1.0.tm
  8. 11
      src/modules/punk/mix/util-999999.0a1.0.tm
  9. 16
      src/modules/punk/ns-999999.0a1.0.tm
  10. 757
      src/modules/punk/path-999999.0a1.0.tm
  11. 95
      src/modules/punkcheck-999999.0a1.0.tm
  12. 201
      src/modules/shellfilter-999999.0a1.0.tm
  13. 1
      src/modules/test/#modpod-overtype-999999.0a1.0/overtype-999999.0a1.0.tm
  14. 95
      src/modules/test/runtestmodules.tcl
  15. 66
      src/tests/all.tcl
  16. 0
      src/tests/modules/opunk/str/testsuites/tests/all.tcl
  17. 0
      src/tests/modules/opunk/str/testsuites/tests/str.test
  18. 33
      src/tests/modules/punk/path/tests/path.test
  19. 5
      src/tests/modules/punk/path/testsuites/tests/all.tcl
  20. 410
      src/tests/modules/punk/path/testsuites/tests/path.test
  21. 125
      src/tests/runtests.tcl
  22. BIN
      src/vendormodules/packagetest-0.1.7.tm
  23. BIN
      src/vendormodules/packagetest-0.1.8.tm

28
src/modules/punk-999999.0a1.0.tm

@ -7719,7 +7719,7 @@ namespace eval punk {
} }
namespace eval argdoc { namespace eval argdoc {
set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}} set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -exclude-paths]}}
punk::args::define { punk::args::define {
@dynamic @dynamic
@id -id ::punk::LOC @id -id ::punk::LOC
@ -7737,11 +7737,11 @@ namespace eval punk {
@opts @opts
-return -default showdict -choices {dict showdict} -return -default showdict -choices {dict showdict}
-dir -default "\uFFFF" -dir -default "\uFFFF"
-exclude_dupfiles -default 1 -type boolean -no-dupfiles -default 1 -type boolean
-no-punctlines -default 1 -type boolean
${$DYN_ANTIGLOB_PATHS} ${$DYN_ANTIGLOB_PATHS}
-antiglob_files -default "" -type list -help\ -exclude-files -default "" -type list -help\
"Exclude if file tail matches any of these patterns" "Exclude if file tail matches any of these patterns"
-exclude_punctlines -default 1 -type boolean
-show_largest -default 0 -type integer -help\ -show_largest -default 0 -type integer -help\
"Report the top largest linecount files. "Report the top largest linecount files.
The value represents the number of files The value represents the number of files
@ -7769,16 +7769,16 @@ namespace eval punk {
set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_exclude_dupfiles [dict get $opts -exclude_dupfiles] set opt_no_dupfiles [dict get $opts -no-dupfiles]
set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars set opt_no_punctlines [dict get $opts -no-punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars
set opt_punctchars [dict get $opts -punctchars] set opt_punctchars [dict get $opts -punctchars]
set opt_largest [dict get $opts -show_largest] set opt_largest [dict get $opts -show_largest]
set opt_antiglob_paths [dict get $opts -antiglob_paths] set opt_exclude_paths [dict get $opts -exclude-paths]
set opt_antiglob_files [dict get $opts -antiglob_files] set opt_exclude_files [dict get $opts -exclude-files]
# -- --- --- --- --- --- # -- --- --- --- --- ---
set filepaths [punk::path::treefilenames -dir $opt_dir -antiglob_paths $opt_antiglob_paths -antiglob_files $opt_antiglob_files {*}$searchspecs] set filepaths [punk::path::treefilenames -dir $opt_dir -exclude-paths $opt_exclude_paths -exclude-files $opt_exclude_files {*}$searchspecs]
set loc 0 set loc 0
set dupfileloc 0 set dupfileloc 0
set seentails [dict create] set seentails [dict create]
@ -7792,7 +7792,7 @@ namespace eval punk {
set notes "" set notes ""
if {$has_hashfunc} { if {$has_hashfunc} {
set dupfilemech sha1 set dupfilemech sha1
if {$opt_exclude_punctlines} { if {$opt_no_punctlines} {
append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n"
} else { } else {
append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n"
@ -7814,7 +7814,7 @@ namespace eval punk {
continue continue
} }
set lines [linelist -line {trimright} -block {trimall} $contents] set lines [linelist -line {trimright} -block {trimall} $contents]
if {!$opt_exclude_punctlines} { if {!$opt_no_punctlines} {
set floc [llength $lines] set floc [llength $lines]
set comparedlines $lines set comparedlines $lines
} else { } else {
@ -7852,7 +7852,7 @@ namespace eval punk {
incr dupfileloc $floc incr dupfileloc $floc
} }
} }
if {!$isdupfile || ($isdupfile && !$opt_exclude_dupfiles)} { if {!$isdupfile || ($isdupfile && !$opt_no_dupfiles)} {
incr loc $floc incr loc $floc
incr purepunctlines $fpurepunctlines incr purepunctlines $fpurepunctlines
} }
@ -7881,11 +7881,11 @@ namespace eval punk {
] dupfileloc $dupfileloc {*}[ ] dupfileloc $dupfileloc {*}[
] dupinfo $dupinfo {*}[ ] dupinfo $dupinfo {*}[
] extensions $extensions {*}[ ] extensions $extensions {*}[
# purepunctuationlines key only retained if punctuation lines are excluded from count by opt_exclude_punctlines # purepunctuationlines key only retained if punctuation lines are excluded from count by opt_no_punctlines
] purepunctuationlines $purepunctlines {*}[ ] purepunctuationlines $purepunctlines {*}[
] notes $notes {*}[ ] notes $notes {*}[
]] ]]
if {!$opt_exclude_punctlines} { if {!$opt_no_punctlines} {
dict unset result purepunctuationlines dict unset result purepunctuationlines
} }

3
src/modules/punk/ansi-999999.0a1.0.tm

@ -10349,8 +10349,9 @@ tcl::namespace::eval punk::ansi::ansistring {
set hack [tcl::dict::create] set hack [tcl::dict::create]
tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph)
tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"] tcl::dict::set hack ZWSP [list \u200B "${obm}ZWSP$cbm"]
tcl::dict::set hack ZWNJ [list \u200D "${obm}ZWNJ$cbm"] ;#zero width non-joiner. tcl::dict::set hack ZWNJ [list \u200C "${obm}ZWNJ$cbm"] ;#zero width non-joiner.
tcl::dict::set hack ZWJ [list \u200D "${obm}ZWJ$cbm"] tcl::dict::set hack ZWJ [list \u200D "${obm}ZWJ$cbm"]
tcl::dict::set hack CGJ [list \u034F "${obm}CGJ$cbm"] ;#combining grapheme joiner (MISNOMER) - zero width, but semantically important in some contexts - for example in indic scripts - where it can affect the shaping of the preceding character(s)
#review - other boms? Encoding dependent? #review - other boms? Encoding dependent?

10
src/modules/punk/char-999999.0a1.0.tm

@ -3033,13 +3033,15 @@ tcl::namespace::eval punk::char {
#This still leaves a whole class of clusters.. korean etc unhandled :/ #This still leaves a whole class of clusters.. korean etc unhandled :/
#todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl
#https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63 #https://core.tcl-lang.org/tcl/tktview/a4c7eeaf63
proc grapheme_split {text} { proc grapheme_split {text {return list}} {
#we should treat \r\n as a single grapheme cluster (as tk::endOfCluster does) #we should treat \r\n as a single grapheme cluster (as tk::endOfCluster does)
set components [list] set components [list]
set csplits [combiner_split $text] set csplits [combiner_split $text]
foreach {pt combiners} [lrange $csplits 0 end-1] { foreach {pt combiners} [lrange $csplits 0 end-1] {
set clist [split $pt ""] set clist [split $pt ""]
lset clist end [tcl::string::cat [lindex $clist end] $combiners] #review
#lset clist end [tcl::string::cat [lindex $clist end] $combiners]
ledit clist end end [tcl::string::cat [lindex $clist end] $combiners]
lappend components {*}$clist lappend components {*}$clist
#lappend components {*}[lrange $clist 0 end-1] #lappend components {*}[lrange $clist 0 end-1]
#lappend components [tcl::string::cat [lindex $clist end] $combiners] #lappend components [tcl::string::cat [lindex $clist end] $combiners]
@ -3183,7 +3185,11 @@ tcl::namespace::eval punk::char {
if {$current_cluster ne ""} { if {$current_cluster ne ""} {
lappend graphemes $current_cluster lappend graphemes $current_cluster
} }
if {$return eq "list"} {
return $graphemes return $graphemes
} else {
return [dict create list $graphemes last_extensible $current_cluster_is_extensible base $cluster_base RI_base $cluster_base_RI]
}
} }
namespace eval grapheme_split { namespace eval grapheme_split {
proc about {} { proc about {} {

310
src/modules/punk/lib-999999.0a1.0.tm

@ -138,25 +138,10 @@ tcl::namespace::eval punk::lib::check {
if {"windows" ne $::tcl_platform(platform)} { if {"windows" ne $::tcl_platform(platform)} {
set bug 0 set bug 0
} else { } else {
if {![catch {file tempdir} tmpdir]} { set tmpdir [punk::lib::tempdir_newfolder] ;#uses 'file tempdir' on tcl9+ or fallback to env vars or current directory on older versions
#tcl 9+ has 'file tempdir'
set testfile [file join $tmpdir "bugtest"]
} else {
#fallback for older tcl versions - use env TEMP/TMP or current directory
set tmpdir ""
foreach e {TEMP TMP} {
if {[info exists ::env($e)] && [file isdirectory ::env($e)]} {
set tmpdir ::env($e)
break
}
}
if {$tmpdir eq ""} {
#no env vars - fallback to current directory
set tmpdir [pwd]
}
set testfile [file join $tmpdir "bugtest"] set testfile [file join $tmpdir "bugtest"]
}
try {
set fd [open $testfile w] set fd [open $testfile w]
puts $fd test puts $fd test
close $fd close $fd
@ -170,6 +155,14 @@ tcl::namespace::eval punk::lib::check {
break break
} }
} }
} finally {
if {[file exists $testfile]} {
file delete $testfile
}
if {[file exists $tmpdir]} {
file delete -force $tmpdir
}
}
} }
#possibly related anomaly is that a returned result with case that doesn't match that of the file in the underlying filesystem can't be normalized #possibly related anomaly is that a returned result with case that doesn't match that of the file in the underlying filesystem can't be normalized
# to the correct case without doing some sort of string manipulation on the result such as 'string range $f 0 end' to affect the internal representation. # to the correct case without doing some sort of string manipulation on the result such as 'string range $f 0 end' to affect the internal representation.
@ -679,7 +672,207 @@ namespace eval punk::lib {
} }
} }
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::tempdir
@cmd -name punk::lib::tempdir\
-summary\
"Determine an appropriate temp dir for the process we are running under."\
-help\
"On windows:
If the process is running under the system account use the modern windows location: %SystemRoot%\SystemTemp
Detection of the system account relies on either twapi, or a combination of the whoami command and the
registry package.
Proceeds with same fallback logic as for other platforms if we fail to detect the system account or its temp location.
For other platforms we use the environment variables TMPDIR/TEMP/TMP or fallback to /tmp or /var/tmp if those
env vars aren't set or aren't writable directories.
Final fallback attempt is the current working directory.
Result is normalized so resulting path will have forward slashes on all platforms.
Alternatives: see the tcllib fileutil::tempdir function.
"
@values -min 0 -max 0
}]
}
proc tempdir {} {
set trydirs [list]
if {"windows" eq $::tcl_platform(platform)} {
#review.
#consider also checking for whether running under various service accounts
if {![catch {package require twapi}]} {
set tok [twapi::open_process_token] ;#first call is a little pricy.
set sid [twapi::get_token_user $tok]
if {$sid eq "S-1-5-18"} {
#system account - use system account temp location
set sysroot [twapi::get_shell_folder csidl_windows] ;#first call is a little pricy.
lappend trydirs [file join $sysroot "SystemTemp"]
}
#if not system account - use env vars as first choice.
} else {
#twapi not available - try to use builtin windows whoami to detect if we're running under system account - but this is less reliable than using twapi to check the process token - so we warn about it.
set whoami_exe [auto_execok whoami]
#test that system32 is somewhere in the whoami path as a basic attempt to avoid non-windows whoami commands that might be present in the path
set whoami_exe_parts [file split $whoami_exe]
if {"system32" in [string tolower $whoami_exe_parts]} {
set whoamiresult [string trim [exec {*}$whoami_exe /USER /FO LIST] \n\r]
set whoamiresult [string map {\r\n \n} $whoamiresult]
set whoamiresult_lines [split $whoamiresult \n]
set sid ""
foreach line $whoamiresult_lines {
if {[string match "SID:*" $line]} {
set sid [lindex $line 1]
break
}
}
set has_registry [expr {![catch {package require registry}]}]
if {$sid eq "S-1-5-18"} {
#system account - use system account temp location
set sysroot ""
if {$has_registry} {
#registry path is case-insensitive.
catch {
set sysroot [registry get {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion} SystemRoot]
}
} else {
if {[info exists ::env(SystemRoot)]} {
set sysroot [set ::env(SystemRoot)]
}
}
if {$sysroot ne ""} {
lappend trydirs [file join $sysroot "SystemTemp"]
}
}
#if not system account - use env vars as first choice.
}
}
}
foreach t {TMPDIR TEMP TMP} {
#TMPDIR is the posix standard as first choice for temp dir env var.
if {[info exists ::env($t)]} {
lappend trydirs $::env($t)
}
}
if {"windows" ne $::tcl_platform(platform)} {
#suitable for macos,linux and freebsd at least.
lappend trydirs [file join / tmp] [file join / var tmp]
#/usr/tmp is probably not a common location for a temp dir on modern unix-based systems.
}
foreach d $trydirs {
if {[file isdirectory $d] && [file writable $d]} {
return [file normalize $d]
}
}
#only even call 'pwd' as a last resort (mildly slow on first call).
set cwd [pwd]
if {[file isdirectory $cwd] && [file writable $cwd]} {
return $cwd
}
return -code error "punk::lib::tempdir unable to determine a suitable temp directory - tried: $trydirs"
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::lib::tempdir_newfolder
@cmd -name punk::lib::tempdir_newfolder\
-summary\
"Create unique folder within temp dir (or cwd as last resort)"\
-help\
"Creates a new unique folder within the temp dir determined by punk::lib::tempdir.
The folder is created before returning its full path and will be empty.
The folder is named with a tcl_ prefix followed by a random string.
See also: 'file tempdir' in tcl 9+ or fileutil::maketempdir from tcllib"
@opts
-dir -type string -default "" -help\
"Base directory to create the temp folder in - defaults to the result of punk::lib::tempdir"
-prefix -type string -default tcl -help\
"Prefix for the temp folder name
An underscore is automatically appended to the prefix in the generated folder name.
If prefix is the empty string - then the generated folder name will still be autoprefixed
with tcl_ (consistent with tcl9 'file tempdir')"
@values -min 0 -max 0
}]
}
proc tempdir_newfolder {args} {
set argd [punk::args::parse $args withid ::punk::lib::tempdir_newfolder]
set opt_dir [dict get $argd opts -dir]
set opt_prefix [dict get $argd opts -prefix]
puts "opt_prefix: $opt_prefix"
if {[llength [file split $opt_prefix]] > 1} {
error "punk::lib::tempdir_newfolder -prefix option should not contain any path separators"
}
if {$opt_prefix eq ""} {
#don't allow empty prefix - for consistency with tcl9 'file tempdir' - which would still prefix with 'tcl_' even if prefix is empty string.
set opt_prefix "tcl"
}
if {$opt_dir ne ""} {
if {[file isdirectory $opt_dir] && [file writable $opt_dir]} {
set tmpbase [file normalize $opt_dir]
} else {
error "punk::lib::tempdir_newfolder -dir option '$opt_dir' is not a writable directory"
}
} else {
set tmpbase [punk::lib::tempdir] ;#will raise an error if no writable temp dir or cwd found.
}
#assert: tmpbase has no trailing slash - unless it is a root dir (e.g / on unix, or C:/ on windows)
#assert: tmpbase is normalized with forward slashes on all platforms.
set tcl9_template_base [string trimright $tmpbase "/"] ;#set it to a form that can join along with a forward slash to prefix for tcl 9 'file tempdir' style template.
#tcl9 'file tempdir' separates the prefix in the template from the random string with an underscore.
#now form template by always joining with a slash (even if opt_prefix is empty)
#(avoiding file join and file normalize to ensure template is properly formed)
#whether or not opt_prefix ends with an underscore - another will be added. (by file tempdir, or by our own code if tcl9 'file tempdir' isn't available)
#assert: opt_prefix is not empty string (will have defaulted to 'tcl') and does not contain any path separators.
set tcl9_template "$tcl9_template_base/$opt_prefix"
#tcl 9+ has 'file tempdir'
#we don't support the same template as 'file tempdir'
if {[catch {file tempdir $tcl9_template} tmpdir]} {
set prefix tcl_ ;#todo - accept option: -prefix
set chars abcddefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789
set nrand_chars 8
set maxtries 100
for {set i 0} {$i < $maxtries} {incr i} {
set dirname ${opt_prefix}_ ;#always add underscore for consistency with tcl9 'file tempdir'.
for {set j 0} {$j < $nrand_chars} {incr j} {
append dirname [string index $chars [expr {int(rand()*62)}]]
}
set path [file join $tmpbase $dirname]
if {[file exists $path]} {
continue
}
if {[catch {
file mkdir $path
if {"windows" ne $::tcl_platform(platform)} {
file attributes $path -permissions 0o700
}
}]} {
continue
}
return $path
}
return -code error "punk::lib::tempdir_newfolder unable to create unique tempdir in $tmpbase after $maxtries attempts - too many collisions - aborting"
}
#tcl 9 'file tempdir' return.
#normalize because on early tcl 9 versions on windows it can return with mixed forward and backward slashes when a template is supplied with forward slashes.
return [file normalize $tmpdir]
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# Maintenance - This is the primary source for tm_version... functions # Maintenance - This is the primary source for tm_version... functions
@ -814,6 +1007,89 @@ namespace eval punk::lib {
error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point"
} }
} }
proc tm_version_magic {} {
#maintenance instruction:
# This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules.
# It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling.
# A copy of this is also present in punk::lib.
# Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder.
#tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use,
#even over decades of development.
set magicbase 999999 ;#deliberately large so given load-preference when testing!
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version
return ${magicbase}.0a1.0
}
namespace eval argdoc {
lappend PUNKARGS [list {
@id -id ::punk::lib::tm_split_name
@cmd -name punk::lib::tm_split_name\
-summary\
"Split a versioned module name into name and version parts, dropping trailing .tcl/.tm if any."\
-help\
"Splits a versioned module name (as present in a filename or namespaced name) into name and version parts,
Ignores any trailing .tm or .tcl file extension.
If the fullmodulename given is a namespaced name - then the returned modulename will also be namespaced,
but with any leading :: removed.
Returns a two element list - with the first element being the modulename and the second element being the version.
Tcl module version numbers are understood with leading zeros in each dotted part, but leading zeros are not canonical.
This split does not canonicalise the version number.
If the last dash-separated segment of the name doesn't look like a valid version number
- then it is treated as part of the modulename and an empty version string is returned.
e.g
mymod-1.2.3.tm -> mymod 1.2.3
mymod-1aa2.3.tm -> mymod-1aa2.3 {}
(repeated a is not a valid version segment - so the entire '1aa2.3' is treated as part of the modulename)
see also: tm_version_canonical
"
@values -min 1 -max 1
fullmodulename -type string -help\
"The full module name to split - as present in a filename or namespaced name. E.g:
mymod-1.2.3
mymod-1.2.3.tm
mymod-1.2.3.tcl
/some/where/mymod-123.0a4.0.tm
mymod
mymod.tm
mymod.tcl
ns1::ns2::mymod-1.2.3
::ns1::ns2::mymod"
}]
}
proc tm_split_name {fullmodulename} {
#split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path
#ignore trailing .tm .TM if present
#if version doesn't pass validation - treat it as part of the modulename and return empty version string without error
#Up to caller to validate.
set lastpart [namespace tail $fullmodulename]
set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components
if {[string tolower [file extension $fullmodulename]] in {.tcl .tm}} {
set fileparts [split [file rootname $lastpart] -]
} else {
set fileparts [split $lastpart -]
}
if {[tm_version_isvalid [lindex $fileparts end]]} {
set versionsegment [lindex $fileparts end]
set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch
} else {
set namesegment [join $fileparts -]
set versionsegment ""
}
set base [string trimleft [namespace qualifiers $fullmodulename] :]
if {$base ne ""} {
set modulename "${base}::$namesegment"
} else {
set modulename $namesegment
}
return [list $modulename $versionsegment]
}
# end tm_version... functions # end tm_version... functions
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==

2
src/modules/punk/mix/cli-999999.0a1.0.tm

@ -499,7 +499,7 @@ namespace eval punk::mix::cli {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj]
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing
set module_list [list] set module_list [list]
if {[file tail [file dirname $srcdir]] ne "src"} { if {[file tail [file dirname $srcdir]] ne "src"} {

2
src/modules/punk/mix/commandset/module-999999.0a1.0.tm

@ -362,7 +362,7 @@ namespace eval punk::mix::commandset::module {
file mkdir $modulefolder file mkdir $modulefolder
set moduletail [namespace tail $modulename] set moduletail [namespace tail $modulename]
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing set magicversion [punk::mix::util::tm_version_magic] ;#deliberately large so given load-preference when testing

42
src/modules/punk/mix/commandset/project-999999.0a1.0.tm

@ -380,25 +380,25 @@ namespace eval punk::mix::commandset::project {
puts stdout ">>> about to call punkcheck::install $layout_path $projectdir" puts stdout ">>> about to call punkcheck::install $layout_path $projectdir"
set resultdict [dict create] set resultdict [dict create]
set antipaths [list\ set antipaths [list {*}{
src/doc/*\ src/doc/*
src/doc/include/*\ src/doc/include/*
src/PROJECT_LAYOUTS_*\ src/PROJECT_LAYOUTS_*
] }]
#set antiglob_dir [list\ #set exclude_dirsegments [list {*}{
# _ignore_*\ # _ignore_*
#] #}]
set antiglob_dir [list\ set exclude_dirsegments [list {*}{
] }]
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized
if {$opt_force} { if {$opt_force} {
puts stdout "copying layout files - with force applied - overwrite all-targets" puts stdout "copying layout files - with force applied - overwrite all-targets"
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments]
} else { } else {
puts stdout "copying layout files - (if source file changed)" puts stdout "copying layout files - (if source file changed)"
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir] set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -exclude-dirsegments $exclude_dirsegments]
} }
puts stdout [punkcheck::summarize_install_resultdict $resultdict] puts stdout [punkcheck::summarize_install_resultdict $resultdict]
@ -412,11 +412,11 @@ namespace eval punk::mix::commandset::project {
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. #target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence.
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. #In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized.
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] ## default_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"]
set override_antiglob_dir_core [list #* _aside .git] set override_exclude_dirsegments_core [list #* _aside .git]
if {[file exists $layout_path/.fossil-custom]} { if {[file exists $layout_path/.fossil-custom]} {
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict] puts stdout [punkcheck::summarize_install_resultdict $resultdict]
} else { } else {
puts stdout "no .fossil-custom in source template - update not required" puts stdout "no .fossil-custom in source template - update not required"
@ -424,7 +424,7 @@ namespace eval punk::mix::commandset::project {
if {[file exists $layout_path/.fossil-settings]} { if {[file exists $layout_path/.fossil-settings]} {
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -exclude-dirsegments_core $override_exclude_dirsegments_core -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict] puts stdout [punkcheck::summarize_install_resultdict $resultdict]
} else { } else {
puts stdout "no .fossil-settings in source template - update not required" puts stdout "no .fossil-settings in source template - update not required"
@ -470,8 +470,8 @@ namespace eval punk::mix::commandset::project {
if {[file exists $projectdir/src/modules]} { if {[file exists $projectdir/src/modules]} {
foreach m $opt_modules { foreach m $opt_modules {
#check if mod-ver.tm file or #modpod-mod-ver folder exist #check if mod-ver.tm file or #modpod-mod-ver folder exist
set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm set tmfile $projectdir/src/modules/$m-[punk::mix::util::tm_version_magic].tm
set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm
set has_tm [file exists $tmfile] set has_tm [file exists $tmfile]
set has_pod [file exists $podfile] set has_pod [file exists $podfile]

11
src/modules/punk/mix/util-999999.0a1.0.tm

@ -367,7 +367,16 @@ namespace eval punk::mix::util {
} }
#todo - semver conversion/validation for other systems? #todo - semver conversion/validation for other systems?
proc magic_tm_version {} { proc tm_version_magic {} {
#maintenance instruction:
# This specific 12 character nnnnnn.0a1.0 version number is used in text replacement when installing modules.
# It should not be modified without also considering the impact on existing projects based on punkshell that may have used this version number in their own code or documentation as a placeholder for tm version handling.
# A copy of this is also present in punk::lib to aid in dependency management.
# These 2 copies should be kept in sync.
# Essentially this should probably never be changed - and instead deprecated if we want to stop using it and replaced with a different mechanism/placeholder.
#tm versioning is not quite the same as semantic versioning - but similarly we should see extremely high major version numbers rarely if ever in real use,
#even over decades of development.
set magicbase 999999 ;#deliberately large so given load-preference when testing! set magicbase 999999 ;#deliberately large so given load-preference when testing!
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version
return ${magicbase}.0a1.0 return ${magicbase}.0a1.0

16
src/modules/punk/ns-999999.0a1.0.tm

@ -721,6 +721,22 @@ tcl::namespace::eval punk::ns {
} }
punk::args::define {
@id -id ::punk::ns::nstree_list
@cmd -name punk::ns::nstree_list\
-summary\
""\
-help\
""
@leaders
location -type path -optional 0
@opts
-subnslist -type list -default {} -help\
""
-allbelow -type boolean -default 1 -help\
""
@values -min 0 -max 0
}
#important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. #important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure.
#e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util #e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util
proc nstree_list {location args} { proc nstree_list {location args} {

757
src/modules/punk/path-999999.0a1.0.tm

@ -740,10 +740,10 @@ namespace eval punk::path {
return $ismatch return $ismatch
} }
punk::args::define { punk::args::define {
@id -id ::punk::path::subfolders @id -id ::punk::path::subfolders1
@cmd -name punk::path::subfolders\ @cmd -name punk::path::subfolders1\
-summary\ -summary\
"Listing of directories within supplied path."\ "Listing of directories below supplied path."\
-help\ -help\
"List of folders below path. "List of folders below path.
The resulting list is unsorted." The resulting list is unsorted."
@ -771,20 +771,20 @@ namespace eval punk::path {
(so should be written to match the same relative prefix if path is relative)" (so should be written to match the same relative prefix if path is relative)"
} }
proc subfolders {args} { proc subfolders1 {args} {
#NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose. #NOTE - this algorithm based on omit_only_patterns and prune_base_patterns was suggested by a 2026 AI model - it is apparent to this programmer that it is inadequate for the purpose.
#e.g consider subfolders -recursion -exclude {**/vfs/** **/src/**} #e.g consider subfolders1 -recursion -exclude {**/vfs/** **/src/**}
#This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/** #This can still return something like c:/repo/etc/src/vfs - which should be excluded by the pattern **/src/**
#todo - review and fix properly. #todo - review and fix properly.
set argd [punk::args::parse $args withid ::punk::path::subfolders] set argd [punk::args::parse $args withid ::punk::path::subfolders1]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
set do_recursion [dict exists $received -recursive] set do_recursion [dict exists $received -recursive]
set exclude_paths [dict get $opts -exclude-paths] set exclude_paths [dict get $opts -exclude-paths]
if {"**" in $exclude_paths} { if {"**" in $exclude_paths} {
#if ** is in exclude_paths - then we can skip all glob matching and just return empty list #if ** is in exclude_paths - then we can skip all glob matching and just return empty list
#This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring. #This is likely user error - so we'll be loud about it for now but will still return empty list rather than erroring.
#If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders to suppress this message. #If user code is building exclude_paths dynamically - they can check for this case themselves and avoid the call to subfolders1 to suppress this message.
puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" puts stderr "punk::path::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded"
return [list] return [list]
} }
if {[dict exists $received path]} { if {[dict exists $received path]} {
@ -806,9 +806,12 @@ namespace eval punk::path {
# **/test/** - would exclude any path with test as a segment and all its subfolders # **/test/** - would exclude any path with test as a segment and all its subfolders
#- but not paths with test as a segment that is the final segment #- but not paths with test as a segment that is the final segment
set folders [list]
set recurse_subdirs [list]
set omit_only_patterns [list] foreach f $all_subfolders {
set prune_base_patterns [list] set include_in_results 1
set allow_recurse 1
foreach pat $exclude_paths { foreach pat $exclude_paths {
set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test} set pat_parts [file split $pat] ;#note file split c:/test gives {c:/ test} but file split **/test gives {** test}
#also note that file split on windows treats forward slashes and backslashes the same. #also note that file split on windows treats forward slashes and backslashes the same.
@ -817,38 +820,18 @@ namespace eval punk::path {
#This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though #This is almost always a non-issue on windows since * and ? are not valid in path segments there, and is rarely an issue on unix even though
# * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc. # * and ? are technically valid in path segments, but it is inadvisable there anyway for compatibility with shells etc.
if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} {
#** at end of pattern - e.g /dir/etc/** set base_pat [file join {*}[lrange $pat_parts 0 end-1]]
#Convert ".../" to base "...", and prune descendants of that base.
lappend prune_base_patterns [file join {*}[lrange $pat_parts 0 end-1]]
} else {
lappend omit_only_patterns $pat
}
}
set folders [list]
set recurse_subdirs [list]
foreach f $all_subfolders {
set include_in_results 1
set allow_recurse 1
foreach pat $omit_only_patterns {
if {[globmatchpath $pat $f]} { if {[globmatchpath $pat $f]} {
set include_in_results 0 set include_in_results 0
break
}
}
if {$allow_recurse && [llength $prune_base_patterns]} {
foreach base_pat $prune_base_patterns {
#prune both the matched base node and its decendants.
if {[globmatchpath $base_pat $f]} {
set allow_recurse 0 set allow_recurse 0
break } elseif {[globmatchpath $base_pat $f]} {
set allow_recurse 0
} }
if {[globmatchpath "${base_pat}/**" $f]} { } elseif {[globmatchpath $pat $f]} {
set include_in_results 0 set include_in_results 0
set allow_recurse 0
break
} }
if {!$include_in_results && !$allow_recurse} {
break
} }
} }
if {$include_in_results} { if {$include_in_results} {
@ -860,337 +843,473 @@ namespace eval punk::path {
} }
if {$do_recursion} { if {$do_recursion} {
foreach subdir $recurse_subdirs { foreach subdir $recurse_subdirs {
lappend folders {*}[subfolders -exclude-paths $exclude_paths -recursive $subdir] lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir]
} }
} }
#if {[llength $exclude_paths]} {
# set folders [list]
# foreach f $all_subfolders {
# set skip 0
# foreach pat $exclude_paths {
# #review - this is slightly too simplistic.
# # for exclusion pattern **/dirname
# # this will exclude any path with dirname as final segment - but it will also exclude any path with dirname as a segment anywhere in the path - which is not intended.
# #puts stderr "Checking exclude pat '$pat' against '$f'"
# if {[globmatchpath $pat $f]} {
# set skip 1
# break
# }
# }
# if {!$skip} {
# lappend folders $f
# }
# }
#} else {
# set folders $all_subfolders
#}
#if {$do_recursion} {
# foreach subdir $folders {
# lappend folders {*}[subfolders -exclude-paths $exclude_paths -recursive $subdir]
# }
#}
return $folders return $folders
} }
#todo - treefolders with similar search caps as treefilenames namespace eval subfolder_priv {
proc classify_exclude_pattern {pat} {
set parts [file split $pat]
if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} {
set boundary_pat [file join {*}[lrange $parts 0 end-1]]
return [dict create \
pattern $pat \
kind subtree \
boundary_pat $boundary_pat \
descend_pat $pat]
}
if {[llength $parts] >= 2 && [lindex $parts end] eq "*"} {
return [dict create \
pattern $pat \
kind child_only \
match_pat $pat]
}
return [dict create \
pattern $pat \
kind exact \
match_pat $pat]
}
proc compile_exclude_rules {exclude_paths} {
set rules [list]
foreach pat $exclude_paths {
lappend rules [classify_exclude_pattern $pat]
}
return $rules
}
proc match_rule_at_node {rule path} {
set kind [dict get $rule kind]
switch -- $kind {
exact - child_only {
if {[::punk::path::globmatchpath [dict get $rule match_pat] $path]} {
return [dict create include_current 0 recurse_below 1 child_rules [list $rule]]
}
return [dict create include_current 1 recurse_below 1 child_rules [list $rule]]
}
subtree {
set descend_pat [dict get $rule descend_pat]
set boundary_pat [dict get $rule boundary_pat]
if {[::punk::path::globmatchpath $descend_pat $path]} {
return [dict create include_current 0 recurse_below 0 child_rules [list]]
}
if {[::punk::path::globmatchpath $boundary_pat $path]} {
return [dict create include_current 1 recurse_below 0 child_rules [list]]
}
return [dict create include_current 1 recurse_below 1 child_rules [list $rule]]
}
default {
error "Unknown exclude rule kind '$kind'"
}
}
}
proc walk_subfolders {path rules do_recursion} {
set all_subfolders [glob -nocomplain -directory $path -types d *]
set folders [list]
foreach f $all_subfolders {
set include_current 1
set recurse_below $do_recursion
set child_rules [list]
foreach rule $rules {
set outcome [match_rule_at_node $rule $f]
if {![dict get $outcome include_current]} {
set include_current 0
}
if {![dict get $outcome recurse_below]} {
set recurse_below 0
}
if {$do_recursion} {
lappend child_rules {*}[dict get $outcome child_rules]
}
if {!$include_current && !$recurse_below} {
break
}
}
if {$include_current} {
lappend folders $f
}
if {$do_recursion && $recurse_below} {
lappend folders {*}[walk_subfolders $f $child_rules $do_recursion]
}
}
return $folders
}
}
punk::args::define { punk::args::define {
@id -id ::punk::path::treefilenames @id -id ::punk::path::subfolders
@cmd -name punk::path::treefilenames\ @cmd -name punk::path::subfolders\
-summary\ -summary\
"List of filenames below supplied path."\ "Listing of directories below supplied path."\
-help\ -help\
"List of filenames below path. "List of folders below path.
The resulting list is unsorted." The resulting list is unsorted.
-directory -type directory -help\ "
"folder in which to begin recursive scan for files." @opts
-call-depth-internal -default 0 -type integer -help "internal use only - caller should not specify - used to track depth of recursive calls for internal logic" -recursive -type none -help\
-call-subvector -default {} -type list -help "internal use only - caller should not specify - used to track path vector of recursive calls for internal logic" ""
-call-allbelow -default 1 -type boolean -help "internal use only - caller should not specify - used to track whether we are in a subtree below a match for glob_paths (which means we can skip glob matching and antiglob_paths checks and just include all files below here)" -exclude-paths -type list -default {} -help\
-sort -type any -default natural -choices {none ascii dictionary natural} "list of path patterns to exclude from results.
-antiglob_paths -default {} -help\ May include * and ** path segments e.g /usr/**
"list of path patterns to exclude A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path.
may include * and ** path segments e.g
/usr/** (exclude subfolders based at /usr but not
files within /usr itself)
**/_aside (exclude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude all folders with _aside as a segment)"
-antiglob_files -default {}
-glob_paths -default {*} -help\
"list of path patterns to include
may include * and ** path segments e.g
/usr/** (include subfolders based at /usr but not
files within /usr itself)
**/_aside (include files where _aside is last segment)
**/_aside/* (include folders one below an _aside folder)
**/_aside/** (include all folders with _aside as a segment)"
@values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path
within the directory tree being searched."
}
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/**
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc
proc treefilenames {args} {
#*** !doctools
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options:
#[para] [opt -dir] <path>
#[para] defaults to [lb]pwd[rb] - base path for tree to search
#[para] [opt -antiglob_paths] <list>
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem
set argd [punk::args::parse $args withid ::punk::path::treefilenames] To exclude all paths with _aside as a segment anywhere: -exclude-paths { **/_aside/** **/_aside ./_aside/**}
lassign [dict values $argd] leaders opts values received "
set tailglobs [dict get $values tailglobs] #todo -depth
# -- --- --- --- --- --- --- @values -min 0 -max 1
set opt_sort [dict get $opts -sort] path -type directory -optional 1 -help\
set opt_antiglob_paths [dict get $opts -antiglob_paths] "Path of base folder. If not supplied current directory is used.
set opt_glob_paths [dict get $opts -glob_paths] This may be a relative or absolute path. Relative paths are treated as relative to current directory.
set opt_antiglob_files [dict get $opts -antiglob_files] When using relative paths - the result will also be relative paths with the same relative prefix.
(e.g if path is ../test - the results will be ../test/subfolder1 ../test/subfolder2 etc)
set CALLDEPTH [dict get $opts -call-depth-internal] Patterns in -exclude-paths are matched against the resulting paths
set callsubvector [dict get $opts -call-subvector] (so should be written to match the same relative prefix if path is relative)"
set callallbelow [dict get $opts -call-allbelow] ;#whether to return matches longer than the matched glob-path
# -- --- --- --- --- --- ---
# -- --- --- --- --- --- ---
if {"*" in $opt_glob_paths} {
#if we have a * in the default glob_paths - then any other entries are redundant.
set opt_glob_paths {*}
} }
set files [list] proc subfolders {args} {
if {$CALLDEPTH == 0} { set argd [punk::args::parse $args withid ::punk::path::subfolders]
if {$opt_sort eq "natural"} { lassign [dict values $argd] leaders opts values received
package require natsort set do_recursion [dict exists $received -recursive]
set exclude_paths [dict get $opts -exclude-paths]
if {"**" in $exclude_paths} {
puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded"
return [list]
} }
#set opts [dict merge $opts [list -directory $opt_dir]] if {[dict exists $received path]} {
if {[dict exists $received -directory]} { set path [dict get $values path]
set opt_dir [dict get $opts -directory]
} else { } else {
set path [pwd]
}
set compiled_rules [subfolder_priv::compile_exclude_rules $exclude_paths]
return [subfolder_priv::walk_subfolders $path $compiled_rules $do_recursion]
}
set opt_dir [pwd] namespace eval treefile_priv {
proc _pattern_prefix_viable_parts {pattern_parts path_parts} {
if {![llength $path_parts]} {
return 1
} }
if {![file isdirectory $opt_dir]} { if {![llength $pattern_parts]} {
return [list] return 0
} }
set pattern_head [lindex $pattern_parts 0]
set path_head [lindex $path_parts 0]
} else { if {$pattern_head eq "**"} {
#assume/require to exist in any recursive call if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} {
set opt_dir [dict get $opts -directory] return 1
}
return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]]
} }
#comment out to compare timings with treefilenames_zipfs if {[::punk::path::globmatchpath $pattern_head $path_head]} {
if {[string match //zipfs:/* $opt_dir]} { return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]]
return [treefilenames_zipfs {*}$args] }
return 0
} }
set skip 0 proc pattern_prefix_viable {pattern path} {
foreach anti $opt_antiglob_paths { return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]]
if {[globmatchpath $anti $opt_dir]} { }
set skip 1
proc pattern_boundary {pattern} {
set parts [file split $pattern]
if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} {
return [file join {*}[lrange $parts 0 end-1]]
}
return ""
}
proc directory_state {glob_paths path inherited_allbelow} {
if {$inherited_allbelow} {
return [dict create include_files 1 recurse_below 1 next_allbelow 1]
}
set include_files 0
set recurse_below 0
set next_allbelow 0
foreach gp $glob_paths {
if {[::punk::path::globmatchpath $gp $path]} {
set include_files 1
set recurse_below 1
set next_allbelow 1
break
}
set boundary [pattern_boundary $gp]
if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} {
set recurse_below 1
set next_allbelow 1
break break
} }
if {[pattern_prefix_viable $gp $path]} {
set recurse_below 1
} }
if {$skip} {
return [list]
} }
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? return [dict create {*}{
if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { } include_files $include_files {*}{
#we can get for example a permissions error } recurse_below $recurse_below {*}{
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" } next_allbelow $next_allbelow {*}{
set dirfiles [list]
} else {
set retained [list]
if {[llength $opt_antiglob_files]} {
foreach m $matches {
set skip 0
set ftail [file tail $m]
foreach anti $opt_antiglob_files {
if {[string match $anti $ftail]} {
set skip 1; break
} }
]
} }
if {!$skip} {
lappend retained $m proc child_path_state {glob_paths child_path inherited_allbelow} {
if {$inherited_allbelow} {
return 1
} }
foreach gp $glob_paths {
if {[pattern_prefix_viable $gp $child_path]} {
return 1
} }
} else {
set retained $matches
} }
switch -- $opt_sort { return 0
}
proc _sort_paths {paths sortmode} {
switch -- $sortmode {
ascii { ascii {
set dirfiles [lsort $retained] return [lsort $paths]
} }
dictionary { dictionary {
set dirfiles [lsort -dictionary $retained] return [lsort -dictionary $paths]
} }
natural { natural {
set dirfiles [natsort::sort $retained] return [natsort::sort $paths]
} }
default { default {
set dirfiles $retained return $paths
} }
} }
} }
lappend files {*}$dirfiles proc _path_matches_any {patterns path} {
if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { foreach pattern $patterns {
puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" if {[::punk::path::globmatchpath $pattern $path]} {
set dirdirs [list] return 1
} }
set okdirs [list]
foreach dir $dirdirs {
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} {
set skip 1
break
} }
return 0
} }
if {!$skip} {
lappend okdirs $dir proc _tailbase_relative {tailbase path} {
if {$tailbase eq ""} {
return $path
} }
return [::punk::path::relative $tailbase $path]
} }
if {$opt_glob_paths eq {*}} {
set matchdirs $okdirs
} else {
#** only significant when it is the trailing part of a segment eg /**/xxx /a**/xxx
proc _tailbase_match_path {tailbase path} {
set match_path [_tailbase_relative $tailbase $path]
if {$match_path eq "."} {
return ""
}
return $match_path
}
proc _tailbase_relative_list {tailbase paths} {
if {$tailbase eq ""} {
return $paths
}
set relative_paths [list]
foreach path $paths {
lappend relative_paths [_tailbase_relative $tailbase $path]
}
return $relative_paths
}
set matchdirs [list] proc _retain_files {matches exclude_files sortmode} {
foreach dir $okdirs { set retained [list]
foreach gp $opt_glob_paths { foreach match $matches {
if {[globmatchpath $gp $dir] || [globmatchpath "$gp/**" $dir]} { set skip 0
lappend matchdirs $dir set file_tail [file tail $match]
foreach anti $exclude_files {
if {[string match $anti $file_tail]} {
set skip 1
break
} }
} }
if {!$skip} {
lappend retained $match
} }
} }
if {[llength $matchdirs]} { return [_sort_paths $retained $sortmode]
switch -- $opt_sort {
ascii {
set finaldirs [lsort $matchdirs]
} }
dictionary {
set finaldirs [lsort -dictionary $matchdirs] proc _state_from_argd {argd} {
set opts [dict get $argd opts]
set values [dict get $argd values]
set received [dict get $argd received]
if {[dict exists $received -directory]} {
set directory [dict get $opts -directory]
} else {
set directory [pwd]
} }
natural {
set finaldirs [natsort::sort $matchdirs] set glob_paths [dict get $opts -include-paths]
if {"*" in $glob_paths} {
set glob_paths {*}
} }
default {
set finaldirs $matchdirs set sortmode [dict get $opts -sort]
if {$sortmode eq "natural"} {
package require natsort
}
return [dict create {*}{
depth 0
subvector {}
allbelow 0
} sort $sortmode {*}{
} directory $directory {*}{
} tailbase [dict get $opts -tailbase] {*}{
} exclude_paths [dict get $opts -exclude-paths] {*}{
} exclude_files [dict get $opts -exclude-files] {*}{
} glob_paths $glob_paths {*}{
} tailglobs [dict get $values tailglobs] {*}{
}
]
}
proc walk_treefilenames {state} {
set opt_dir [dict get $state directory]
set opt_tailbase [dict get $state tailbase]
set depth [dict get $state depth]
set subvector [dict get $state subvector]
set callallbelow [dict get $state allbelow]
set opt_sort [dict get $state sort]
set opt_exclude_paths [dict get $state exclude_paths]
set opt_exclude_files [dict get $state exclude_files]
set opt_glob_paths [dict get $state glob_paths]
set tailglobs [dict get $state tailglobs]
if {![file isdirectory $opt_dir]} {
return [list]
} }
if {[string match //zipfs:/* $opt_dir]} {
return [walk_treefilenames_zipfs $state]
} }
foreach dir $finaldirs { set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir]
set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} {
lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] return [list]
}
set files [list]
set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow]
if {[dict get $dir_state include_files]} {
if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} {
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches"
set dirfiles [list]
} else {
set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort]
} }
lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles]
} }
if {![dict get $dir_state recurse_below]} {
return $files return $files
} }
proc treefilenames_zipfs {args} {
#seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW
# is sort order the same?
set argd [punk::args::parse $args withid ::punk::path::treefilenames]
lassign [dict values $argd] leaders opts values received
set tailglobs [dict get $values tailglobs]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]
set opt_antiglob_files [dict get $opts -antiglob_files]
set opt_sort [dict get $opts -sort]
set CALLDEPTH [dict get $opts -call-depth-internal]
# -- --- --- --- --- --- ---
# -- --- --- --- --- --- ---
set files [list] if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} {
if {$CALLDEPTH == 0} { puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs"
if {$opt_sort eq "natural"} { set dirdirs [list]
package require natsort
} }
#set opts [dict merge $opts [list -directory $opt_dir]] set okdirs [list]
if {![dict exists $received -directory]} { foreach dir $dirdirs {
set opt_dir [pwd] if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} {
} else { lappend okdirs $dir
set opt_dir [dict get $opts -directory]
} }
if {![file isdirectory $opt_dir]} {
return [list]
} }
if {$opt_glob_paths eq "*"} {
set matchdirs $okdirs
} else { } else {
#assume/require to exist in any recursive call set matchdirs [list]
set opt_dir [dict get $opts -directory] foreach dir $okdirs {
if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} {
lappend matchdirs $dir
}
} }
if {![string match [zipfs root]* $opt_dir]} {
error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems"
} }
set dir [string trimright $opt_dir "/"] ;#e.g normalize //zipfs:/x/ to //zipfs:/x
set dirlen [string length $dir]
set skip 0 set finaldirs [_sort_paths $matchdirs $opt_sort]
foreach anti $opt_antiglob_paths { set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}]
if {[globmatchpath $anti $dir]} { set nextsubvector [list {*}$subvector [file tail $opt_dir]]
set skip 1 foreach dir $finaldirs {
break set child_state [dict merge $state [dict create {*}{} \
directory $dir \
depth [expr {$depth + 1}] \
subvector $nextsubvector \
allbelow $childallbelow]]
lappend files {*}[walk_treefilenames $child_state]
}
return $files
} }
proc walk_treefilenames_zipfs {state} {
set opt_dir [dict get $state directory]
set opt_tailbase [dict get $state tailbase]
set opt_exclude_paths [dict get $state exclude_paths]
set opt_exclude_files [dict get $state exclude_files]
set opt_glob_paths [dict get $state glob_paths]
set opt_sort [dict get $state sort]
set tailglobs [dict get $state tailglobs]
if {![string match [zipfs root]* $opt_dir]} {
error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems"
} }
if {$skip} { set dir [string trimright $opt_dir "/"]
if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} {
return [list] return [list]
} }
set dirlen [string length $dir]
set subpaths [zipfs list $dir/*] set subpaths [zipfs list $dir/*]
set dirlist [list] set dirlist [list]
set skipdirs [list] set skipdirs [list]
set filelist [list] set filelist [list]
#process in the order they came - sorting large list more expensive?? review
foreach sub $subpaths { foreach sub $subpaths {
set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash set tail [string range $sub $dirlen+1 end]
set tailparts [file split $tail] set tailparts [file split $tail]
set accum "" set accum ""
set skipdir 0 set skipdir 0
foreach tp [lrange $tailparts 0 end-1] { foreach tailpart [lrange $tailparts 0 end-1] {
append accum "/$tp" append accum "/$tailpart"
set superpath "${dir}${accum}" set superpath "${dir}${accum}"
if {$superpath in $skipdirs} { if {$superpath in $skipdirs} {
#subpart already in skipdirs
set skipdir 1 set skipdir 1
break break
} }
if {$superpath ni $dirlist} { if {$superpath ni $dirlist} {
set skip2 0 if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} {
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $superpath]} {
set skip2 1
lappend skipdirs $superpath lappend skipdirs $superpath
break
}
}
if {!$skip2} {
lappend dirlist $superpath
} else {
set skipdir 1 set skipdir 1
break break
} else {
lappend dirlist $superpath
} }
} }
} }
if {!$skipdir} { if {!$skipdir} {
#process final part of path
append accum "/[lindex $tailparts end]" append accum "/[lindex $tailparts end]"
set finalpart "${dir}${accum}" set finalpart "${dir}${accum}"
if {$finalpart ni $dirlist} { if {$finalpart ni $dirlist} {
if {[file type $finalpart] eq "file"} { if {[file type $finalpart] eq "file"} {
set ftail [lindex $tailparts end] set file_tail [lindex $tailparts end]
set match 0 set match 0
if {"*" ni $tailglobs} { if {"*" ni $tailglobs} {
foreach tg $tailglobs { foreach tailglob $tailglobs {
if {[string match $tg $ftail]} { if {[string match $tailglob $file_tail]} {
set match 1 set match 1
break break
} }
@ -1199,31 +1318,29 @@ namespace eval punk::path {
set match 1 set match 1
} }
if {$match} { if {$match} {
if {[llength $opt_antiglob_files]} { if {$opt_glob_paths ne "*"} {
set file_dir_match [_tailbase_match_path $opt_tailbase [file dirname $finalpart]]
set file_dir_state [directory_state $opt_glob_paths $file_dir_match 0]
set match [dict get $file_dir_state include_files]
}
}
if {$match} {
set skipfile 0 set skipfile 0
foreach anti $opt_antiglob_files { foreach anti $opt_exclude_files {
if {[string match $anti $ftail]} { if {[string match $anti $file_tail]} {
set skipfile 1; break set skipfile 1
break
} }
} }
if {!$skipfile} { if {!$skipfile} {
lappend filelist $finalpart lappend filelist [_tailbase_relative $opt_tailbase $finalpart]
}
} else {
lappend filelist $finalpart
} }
} }
} else { } else {
if {$finalpart ni $dirlist} { if {$finalpart ni $dirlist} {
set skip2 0 if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} {
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $finalpart]} {
set skip2 1
lappend skipdirs $finalpart lappend skipdirs $finalpart
break } else {
}
}
if {!$skip2} {
lappend dirlist $finalpart lappend dirlist $finalpart
} }
} }
@ -1231,21 +1348,81 @@ namespace eval punk::path {
} }
} }
} }
switch -- $opt_sort { return [_sort_paths $filelist $opt_sort]
ascii {
set finalfilelist [lsort $filelist]
} }
dictionary {
set finalfilelist [lsort -dictionary $filelist]
} }
natural {
set finalfilelist [natsort::sort $filelist] #todo - treefolders with similar search caps as treefilenames
punk::args::define {
@id -id ::punk::path::treefilenames
@cmd -name punk::path::treefilenames\
-summary\
"List of filenames below supplied path."\
-help\
"List of filenames below path.
The resulting list is unsorted.
The path globbing syntax supports *, ** and ? as glob characters in any segment of the path, with the following semantics:
* matches any single segment in the path
** matches 1 or more segments in the path (so /usr/**/bin will match /usr/x/bin and user/x/y/bin but not /usr/bin )
? matches any single character in a single segment of the path (so /usr/te?t will match /usr/test and /usr/text but not /usr/texxt)
"
-directory -type directory -help\
"folder in which to begin recursive scan for files."
-tailbase -type string -default "" -help\
"if supplied, only the relative path compared to the tailbase will be returned for each file.
So if tailbase is /usr and a file is found at /usr/x/y/file.txt, the returned path for that file would be x/y/file.txt.
If tailbase is not supplied, the full path to each file will be returned.
If tailbase is supplied, it should be a prefix of the directory supplied (or the directory itself)
The patterns in -exclude-paths should be written to match the returned paths (i.e with the tailbase prefix removed) if -tailbase is supplied.
If the tailbase is not a prefix of the directory supplied, the resulting paths may have /../ components in them to account for the difference,
but the behaviour is not well defined in this case and it is recommended to ensure tailbase is a prefix of the directory supplied if using -tailbase.
see: punk::path::relative to compute relative paths
"
-sort -type any -default natural -choices {none ascii dictionary natural}
-exclude-paths -default {} -help\
"list of path patterns to exclude
may include * and ** path segments e.g
/usr/** (exclude subfolders based at /usr but not
files within /usr itself)
**/_aside (exclude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude files in all folders with _aside as a segment)"
-exclude-files -default {}
-include-paths -default {**} -help\
"list of path patterns to include
may include * and ** path segments e.g
/usr/** (include files in subfolders based at /usr but not
files within /usr itself)
**/_aside (include files where _aside is last segment in the folder)
**/_aside/* (include files in folders one below an _aside folder)
**/_aside/** (include all files in folders with _aside as a segment)"
@values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path
within the directory tree being searched."
} }
default {
set finalfilelist $filelist #todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {args} {
set argd [punk::args::parse $args withid ::punk::path::treefilenames]
set state [treefile_priv::_state_from_argd $argd]
return [treefile_priv::walk_treefilenames $state]
} }
punk::args::set_idalias ::punk::path::treefilenames_zipfs ::punk::path::treefilenames
proc treefilenames_zipfs {args} {
#seems to be 2 or 3 times faster than treefilenames for //zipfs:/ paths - REVIEW
# is sort order the same?
set argd [punk::args::parse $args withid ::punk::path::treefilenames]
set state [treefile_priv::_state_from_argd $argd]
if {![file isdirectory [dict get $state directory]]} {
return [list]
} }
return $finalfilelist return [treefile_priv::walk_treefilenames_zipfs $state]
} }
#maint warning - also in punkcheck #maint warning - also in punkcheck

95
src/modules/punkcheck-999999.0a1.0.tm

@ -41,9 +41,9 @@ namespace eval punkcheck {
summarize_install_resultdict summarize_install_resultdict
} }
#antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators
variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"] variable default_exludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"]
variable default_antiglob_file_core "" variable default_excludefiletail_core ""
set has_twapi 0 set has_twapi 0
if {"windows" eq $::tcl_platform(platform)} { if {"windows" eq $::tcl_platform(platform)} {
@ -56,16 +56,16 @@ namespace eval punkcheck {
interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate
} }
proc default_antiglob_dir_core {} { proc default_excludedirseg_core {} {
variable default_antiglob_dir_core variable default_excludedirseg_core
return $default_antiglob_dir_core return $default_excludedirseg_core
} }
proc default_antiglob_file_core {} { proc default_excludefiletail_core {} {
variable default_antiglob_file_core variable default_excludefiletail_core
if {$default_antiglob_file_core eq ""} { if {$default_excludefiletail_core eq ""} {
set default_antiglob_file_core [list "*.swp" "*[punk::mix::util::magic_tm_version]*" "*-buildversion.txt" ".punkcheck"] set default_excludefiletail_core [list "*.swp" "*[punk::mix::util::tm_version_magic]*" "*-buildversion.txt" ".punkcheck"]
} }
return $default_antiglob_file_core return $default_excludefiletail_core
} }
@ -1268,7 +1268,7 @@ namespace eval punkcheck {
set defaults [list {*}{ set defaults [list {*}{
-glob *.tm -glob *.tm
-installer punkcheck::install_tm_files -installer punkcheck::install_tm_files
} -antiglob_file [list "*[punk::mix::util::magic_tm_version]*"] {*}{ } -exclude-filetails [list "*[punk::mix::util::tm_version_magic]*"] {*}{
} }
] ]
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
@ -1276,17 +1276,16 @@ namespace eval punkcheck {
} }
proc install_non_tm_files {srcdir basedir args} { proc install_non_tm_files {srcdir basedir args} {
#set keys [dict keys $args] #set keys [dict keys $args]
#adjust the default antiglob_dir_core entries so that .fossil-custom, .fossil-settings are copied #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied
set antiglob_dir_core [punkcheck::default_antiglob_dir_core] set excludedirseg_core [punkcheck::default_excludedirseg_core]
set posn [lsearch $antiglob_dir_core ".fossil*"] set posn [lsearch $excludedirseg_core ".fossil*"]
if {$posn >=0} { if {$posn >=0} {
#set antiglob_dir_core [lreplace $antiglob_dir_core $posn $posn] ledit excludedirseg_core $posn $posn
set antiglob_dir_core [lreplace $antiglob_dir_core[set antiglob_dir_core {}] $posn $posn]
} }
set defaults [list {*}{ set defaults [list {*}{
} -glob * {*}{ } -glob * {*}{
} -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{
} -antiglob_dir_core $antiglob_dir_core {*}{ } -exclude-dirsegment_core $excludedirseg_core {*}{
} -installer punkcheck::install_non_tm_files {*}{ } -installer punkcheck::install_non_tm_files {*}{
} }
] ]
@ -1334,10 +1333,10 @@ namespace eval punkcheck {
"Whether to create folders at target that had no matches for our glob" "Whether to create folders at target that had no matches for our glob"
-glob -type string -default "*" -help\ -glob -type string -default "*" -help\
"Pattern matching for source file(s) to copy. Can be glob based or exact match." "Pattern matching for source file(s) to copy. Can be glob based or exact match."
-antiglob_file_core -default {${[::punkcheck::default_antiglob_file_core]}} -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}}
-antiglob_file -default "" -exclude-filetails -default ""
-antiglob_dir_core -default {${[::punkcheck::default_antiglob_dir_core]}} -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}}
-antiglob_dir -default "" -exclude-dirsegments -default ""
-antiglob_paths -default {} -antiglob_paths -default {}
-overwrite -default no-targets\ -overwrite -default no-targets\
-choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\
@ -1417,10 +1416,10 @@ namespace eval punkcheck {
-createdir 0 -createdir 0
-createempty 0 -createempty 0
-glob * -glob *
-antiglob_file_core "\uFFFF" -exclude-filetails_core "\uFFFF"
-antiglob_file "" -exclude-filetails ""
-antiglob_dir_core "\uFFFF" -exclude-dirsegments_core "\uFFFF"
-antiglob_dir {} -exclude-dirsegments {}
-antiglob_paths {} -antiglob_paths {}
-overwrite no-targets -overwrite no-targets
-source_checksum comparestore -source_checksum comparestore
@ -1475,31 +1474,31 @@ namespace eval punkcheck {
#now the values we build from these will be properly cased #now the values we build from these will be properly cased
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_file_core [dict get $opts -antiglob_file_core] set opt_excludefiletail_core [dict get $opts -exclude-filetails_core]
if {$opt_antiglob_file_core eq "\uFFFF"} { if {$opt_excludefiletail_core eq "\uFFFF"} {
set opt_antiglob_file_core [default_antiglob_file_core] set opt_excludefiletail_core [default_excludefiletail_core]
dict set opts -antiglob_file_core $opt_antiglob_file_core dict set opts -exclude-filetails_core $opt_excludefiletail_core
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_file [dict get $opts -antiglob_file] set opt_excludefiletail [dict get $opts -exclude-filetails]
#validate no path seps #validate no path seps
foreach af $opt_antiglob_file { foreach af $opt_excludefiletail {
if {[llength [file split $af]] > 1} { if {[llength [file split $af]] > 1} {
error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" error "punkcheck::install received invalid -exclude-filetails entry '$af'. -exclude-filetails entries are meant to match to a file name at any level so cannot contain path separators"
} }
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core]
if {$opt_antiglob_dir_core eq "\uFFFF"} { if {$opt_excludedirseg_core eq "\uFFFF"} {
set opt_antiglob_dir_core [default_antiglob_dir_core] set opt_excludedirseg_core [default_excludedirseg_core]
dict set opts -antiglob_dir_core $opt_antiglob_dir_core dict set opts -exclude-dirsegments_core $opt_excludedirseg_core
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_dir [dict get $opts -antiglob_dir] set opt_excludedirseg [dict get $opts -exclude-dirsegments]
#validate no path seps #validate no path seps
foreach ad $opt_antiglob_dir { foreach ad $opt_excludedirseg {
if {[llength [file split $ad]] > 1} { if {[llength [file split $ad]] > 1} {
error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" error "punkcheck::install received invalid -exclude-dirsegments entry '$ad'. -exclude-dirsegments entries are meant to match to a directory name at any level so cannot contain path separators"
} }
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -1655,7 +1654,7 @@ namespace eval punkcheck {
set match_list [list] set match_list [list]
foreach m $candidate_list { foreach m $candidate_list {
set suppress 0 set suppress 0
foreach anti [concat $opt_antiglob_file_core $opt_antiglob_file] { foreach anti [concat $opt_excludefiletail_core $opt_excludefiletail] {
if {[string match $anti $m]} { if {[string match $anti $m]} {
#puts stderr "anti: $anti vs m:$m" #puts stderr "anti: $anti vs m:$m"
set suppress 1 set suppress 1
@ -1970,9 +1969,9 @@ namespace eval punkcheck {
#puts stderr "subdirs: $subdirs" #puts stderr "subdirs: $subdirs"
foreach d $subdirs { foreach d $subdirs {
set skipd 0 set skipd 0
foreach dg [concat $opt_antiglob_dir_core $opt_antiglob_dir] { foreach dg [concat $opt_excludedirseg_core $opt_excludedirseg] {
if {[string match $dg $d]} { if {[string match $dg $d]} {
#puts stdout "SKIPPING FOLDER $d due to antiglob_dir-match: $dg " #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg "
set skipd 1 set skipd 1
break break
} }
@ -2005,10 +2004,10 @@ namespace eval punkcheck {
} -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{
} -subdirlist [list {*}$subdirlist $d] {*}{ } -subdirlist [list {*}$subdirlist $d] {*}{
} -glob $fileglob {*}{ } -glob $fileglob {*}{
} -antiglob_file_core $opt_antiglob_file_core {*}{ } -exclude-filetails_core $opt_excludefiletail_core {*}{
} -antiglob_file $opt_antiglob_file {*}{ } -exclude-filetails $opt_excludefiletail {*}{
} -antiglob_dir_core $opt_antiglob_dir_core {*}{ } -exclude-dirsegments_core $opt_excludedirseg_core {*}{
} -antiglob_dir $opt_antiglob_dir {*}{ } -exclude-dirsegments $opt_excludedirseg {*}{
} -overwrite $overwrite_what {*}{ } -overwrite $overwrite_what {*}{
} -source_checksum $opt_source_checksum {*}{ } -source_checksum $opt_source_checksum {*}{
} -punkcheck_folder $punkcheck_folder {*}{ } -punkcheck_folder $punkcheck_folder {*}{

201
src/modules/shellfilter-999999.0a1.0.tm

@ -326,18 +326,34 @@ namespace eval shellfilter::chan {
#method flush {ch} { #method flush {ch} {
# return "" # return ""
#} #}
#method flush {transform_handle} {
# #puts stdout "<flush>"
# #review - just clear o_encbuf and emit nothing?
# #we wouldn't have a value there if it was convertable from the channel encoding?
# if {[string length $o_encbuf]} {
# #if we have data in the buffer that we haven't been able to convert to a string
# #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var?
# #REVIEW - log that we are discarding the buffer contents on flush?
# puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'"
# }
# set clear $o_encbuf
# set o_encbuf ""
# return $clear
#}
method flush {transform_handle} { method flush {transform_handle} {
#puts stdout "<flush>" #puts stderr "<flush> $transform_handle o_encbuf: '$o_encbuf' datavars: $o_datavars"
#review - just clear o_encbuf and emit nothing? set clear $o_encbuf
#we wouldn't have a value there if it was convertable from the channel encoding? if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} {
if {[string length $o_encbuf]} { #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes?
#if we have data in the buffer that we haven't been able to convert to a string # - probably not.
#- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? #REVIEW?
#REVIEW - log that we are discarding the buffer contents on flush? return ""
puts stderr "WARNING: flush called on tee_to_var with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'"
} }
set o_encbuf "" set o_encbuf ""
return "" foreach v $o_datavars {
append $v $stringdata
}
return $stringdata
} }
method write {ch bytes} { method write {ch bytes} {
#test with set x [string repeat " \U1f6c8" 2043] #test with set x [string repeat " \U1f6c8" 2043]
@ -442,16 +458,29 @@ namespace eval shellfilter::chan {
# flush $o_localchan # flush $o_localchan
# return $clear # return $clear
#} #}
#method flush {transform_handle} {
# #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding?
# if {[string length $o_encbuf]} {
# #if we have data in the buffer that we haven't been able to convert to a string
# #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var?
# #REVIEW - log that we are discarding the buffer contents on flush?
# puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'"
# }
# set clear $o_encbuf
# set o_encbuf ""
# return $clear
#}
method flush {transform_handle} { method flush {transform_handle} {
#we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? set clear $o_buffered$o_encbuf
if {[string length $o_encbuf]} { if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} {
#if we have data in the buffer that we haven't been able to convert to a string #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes?
#- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the channel or var? # - probably not.
#REVIEW - log that we are discarding the buffer contents on flush? #REVIEW?
puts stderr "WARNING: flush called on tee_to_pipe with non-empty buffer. This probably indicates an encoding mismatch between the channel encoding and the encoding expected by the transform. Discarding buffer contents: '$o_encbuf'" return ""
} }
set o_buffered ""
set o_encbuf "" set o_encbuf ""
return "" return $stringdata
} }
method write {transform_handle bytes} { method write {transform_handle bytes} {
#set logdata [tcl::encoding::convertfrom $o_enc $bytes] #set logdata [tcl::encoding::convertfrom $o_enc $bytes]
@ -533,11 +562,24 @@ namespace eval shellfilter::chan {
::shellfilter::log::write $o_logsource $logdata ::shellfilter::log::write $o_logsource $logdata
return $bytes return $bytes
} }
#method flush {transform_handle} {
# #return ""
# set clear $o_encbuf
# set o_encbuf ""
# #review
# return $clear
#}
method flush {transform_handle} { method flush {transform_handle} {
#return "" set clear $o_buffered$o_encbuf
set clear $o_encbuf if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} {
#if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes?
# - probably not.
#REVIEW?
return ""
}
set o_buffered ""
set o_encbuf "" set o_encbuf ""
return $o_encbuf return $stringdata
} }
method write {ch bytes} { method write {ch bytes} {
#set logdata [tcl::encoding::convertfrom $o_enc $bytes] #set logdata [tcl::encoding::convertfrom $o_enc $bytes]
@ -613,9 +655,21 @@ namespace eval shellfilter::chan {
my destroy my destroy
} }
#clear? #clear?
#method flush {transform_handle} {
# #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding?
# if {[string length $o_encbuf]} {
# #if we have data in the buffer that we haven't been able to convert to a string
# #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log?
# #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string.
# #This may be useful for debugging issues, but it may also result in garbage data in the log.
# ::shellfilter::log::write $o_logsource $o_encbuf
# set o_encbuf ""
# }
# return
#}
method flush {transform_handle} { method flush {transform_handle} {
#we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? set clear $o_buffered$o_encbuf
if {[string length $o_encbuf]} { if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} {
#if we have data in the buffer that we haven't been able to convert to a string #if we have data in the buffer that we haven't been able to convert to a string
#- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log? #- then we probably have some kind of encoding mismatch. Is it safer to discard it than to emit garbage chars to the log?
#REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string. #REVIEW. - we are writing the raw bytes to the log here because we can't convert them to a string.
@ -755,6 +809,110 @@ namespace eval shellfilter::chan {
} }
} }
#experimental
#applying this to stdout breaks console query/responses - why?
#- probably because we are splitting graphemes across writes and flushes and the console doesn't know how to handle that?
oo::class create unicode_normalize {
variable o_trecord
variable o_enc
variable o_encbuf
variable o_graphemebuf
variable o_mode
variable o_is_junction
constructor {tf} {
package require punk::ansi
set o_trecord $tf
set o_enc [::tcl::dict::get $tf -encoding]
set o_encbuf ""
set o_graphemebuf ""
set settingsdict [tcl::dict::get $tf -settings]
if {[dict exists $settingsdict -mode]} {
set o_mode [dict get $settingsdict -mode]
if {$o_mode ni {nfc nfd nfkc nfkd none}} {
error "unicode_normalize transform - invalid mode '$o_mode' in settings"
}
if {$o_mode ne "none"} {
#we get dll dependent load errors on windows sometimes - but still seems to work - REVIEW/FIX.
catch {::tcl::unsupported::loadIcu}
}
} else {
#if no mode specified - default to 'none' which just does grapheme splitting without any unicode normalization
set o_mode "none"
}
if {[::tcl::dict::exists $tf -junction]} {
set o_is_junction [::tcl::dict::get $tf -junction]
} else {
set o_is_junction 0
}
}
method initialize {transform_handle mode} {
return [list initialize write flush finalize]
}
method finalize {transform_handle} {
my destroy
}
method flush {transform_handle} {
#flush seems to do nothing - why?
set clear $o_encbuf[unset o_encbuf]
if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} {
#if we can't convert the buffer contents to a string - put it back and try again with more data later
#REVIEW?
set o_encbuf $clear
return ""
}
#review
set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata]
set outstring [join $graphemes ""]
#puts "outstring: '$outstring' graphemes: $graphemes"
if {$o_mode ne "none"} {
set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring]
}
set o_graphemebuf ""
return [tcl::encoding::convertto $o_enc $outstring]
}
method write {transform_handle bytes} {
set inputbytes $o_encbuf$bytes
set o_encbuf ""
set tail_offset 0
if {$inputbytes eq ""} {
#review - do we even get empty writes?
puts stderr "WARNING: write called on unicode_normalize with empty inputbytes. This may be a no-op, but it may also indicate an issue with the upstream transform or channel. Emitting no data for this write."
set stringdata ""
}
while {$tail_offset < [::tcl::string::length $inputbytes] && [catch {tcl::encoding::convertfrom $o_enc [::tcl::string::range $inputbytes 0 end-$tail_offset]} stringdata]} {
incr tail_offset
}
if {$tail_offset > 0} {
if {$tail_offset < [::tcl::string::length $inputbytes]} {
#stringdata from catch statement must be a valid result
set t [expr {$tail_offset - 1}]
set o_encbuf [::tcl::string::range $inputbytes end-$t end]
} else {
set stringdata ""
set o_encbuf $inputbytes
return ""
}
}
set graphemes [punk::char::grapheme_split $o_graphemebuf$stringdata]
set outstring [join [lrange $graphemes 0 end-1] ""]
set o_graphemebuf [lindex $graphemes end]
if {$o_mode ne "none"} {
set outstring [::tcl::unsupported::icu::normalize -mode $o_mode $outstring]
}
return [tcl::encoding::convertto $o_enc $outstring]
}
method meta_is_redirection {} {
return $o_is_junction
}
}
#a test #a test
oo::class create reconvert { oo::class create reconvert {
variable o_trecord variable o_trecord
@ -1114,7 +1272,6 @@ namespace eval shellfilter::chan {
# return $emit # return $emit
#} #}
method flush {transform_handle} { method flush {transform_handle} {
#return ""
set clear $o_buffered$o_encbuf set clear $o_buffered$o_encbuf
if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} { if {[catch {tcl::encoding::convertfrom $o_enc $clear} stringdata]} {
#if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes? #if we can't convert the buffer contents to a string - does it make sense to emit the raw bytes?

1
src/modules/test/#modpod-overtype-999999.0a1.0/overtype-999999.0a1.0.tm

@ -22,6 +22,7 @@ tcl::namespace::eval test::overtype {
set version 999999.0a1.0 set version 999999.0a1.0
package require packagetest package require packagetest
puts "test::overtype - packagetest version: [package provide packagetest]"
packagetest::makeAPI test::overtype $version overtype; #will package provide test::overtype $version packagetest::makeAPI test::overtype $version overtype; #will package provide test::overtype $version
package forget overtype package forget overtype
package require overtype package require overtype

95
src/modules/test/runtestmodules.tcl

@ -14,53 +14,96 @@ if {$modules_posn < 0} {
} }
set modules_base [string range $script_dir 0 $modules_posn-1] set modules_base [string range $script_dir 0 $modules_posn-1]
if {[file tail $modules_base] eq "src"} { if {[file tail $modules_base] eq "src"} {
set test_type "unbuilt"
set project_root [file dirname $modules_base] set project_root [file dirname $modules_base]
} else { } else {
set test_type "installed"
set project_root $modules_base set project_root $modules_base
} }
puts stderr "runtestmodules.tcl project_root: $project_root" puts stderr "runtestmodules.tcl project_root: $project_root"
#use the unbuilt modules/libraries under development rather than the installed versions.
#The unbuilt modules should have a higher version number (such as the magic version number 999999.0a1.0) than any installed versions to ensure they are preferred.
tcl::tm::add [file normalize $project_root/src/modules]
tcl::tm::add [file normalize $project_root/src/modules_tcl$tcl_major]
tcl::tm::add [file normalize $project_root/src/vendormodules]
tcl::tm::add [file normalize $project_root/src/vendormodules_tcl$tcl_major]
# 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. #review - punk::path may itself be a module under test.
#set subfolders [punk::path::subfolders -recursive [file normalize $project_root/src/modules] -match */#modpod-*-999999.0a1.0] #we should ideally be independent of the modules under test.
#'punk::path::subfolders' currently only supports negative matching with -exclude, so we have to filter for the positive match ourselves. #same goes for punk and punk::args.
set subfolders [punk::path::subfolders -recursive [file normalize $project_root/src/modules] -exclude {**/_build/** **/_build}] package require punk::path
foreach sub $subfolders {
if {$test_type eq "unbuilt"} {
#use the unbuilt modules/libraries under development rather than the installed versions.
#The unbuilt modules should have a higher version number (such as the magic version number 999999.0a1.0) than any installed versions to ensure they are preferred.
tcl::tm::add [file normalize $project_root/src/modules]
tcl::tm::add [file normalize $project_root/src/modules_tcl$tcl_major]
tcl::tm::add [file normalize $project_root/src/vendormodules]
tcl::tm::add [file normalize $project_root/src/vendormodules_tcl$tcl_major]
#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 [file normalize $project_root/src/modules] -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} [file normalize $project_root/src/modules]]
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-*-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. #so we use globmatchpath which treats * as matching any characters except path separators.
if {[globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { if {[punk::path::globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} {
set modname [file tail $sub] set modname [file tail $sub]
set modname [string range $modname 8 end-12] ;#strip off #modpod- and -999999.0a1.0 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"] 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 - calculate fully qualified module name based on path relative to the modules folder we added to the tcl::tm path. #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]} { if {[file exists $modpath]} {
puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $modname 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] package ifneeded $modname 999999.0a1.0 [list source $modpath]
} else { } else {
puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $modname at path $modpath" puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $fullmodname at path $modpath"
} }
} }
} }
#exit 1
set libdir [file normalize $project_root/src/lib] set libdir [file normalize $project_root/src/lib]
set libvdir [file normalize $project_root/src/lib/tcl$tcl_major] set libvdir [file normalize $project_root/src/lib/tcl$tcl_major]
set libvldir [file normalize $project_root/src/vendorlib] set libvldir [file normalize $project_root/src/vendorlib]
set libvlvdir [file normalize $project_root/src/vendorlib_tcl$tcl_major] set libvlvdir [file normalize $project_root/src/vendorlib_tcl$tcl_major]
foreach d [list $libdir $libvdir $libvldir $libvlvdir] { foreach d [list $libdir $libvdir $libvldir $libvlvdir] {
if {$d ni $::auto_path} { if {$d ni $::auto_path} {
lappend ::auto_path $d lappend ::auto_path $d
} }
}
#------------------------------------
puts stderr "runtestmodules.tcl ::auto_path: $::auto_path"
puts stderr "runtestmodules.tcl tcl::tm::list: [tcl::tm::list]"
} else {
tcl::tm::add [file normalize $project_root/modules]
tcl::tm::add [file normalize $project_root/modules_tcl$tcl_major]
tcl::tm::add [file normalize $project_root/vendormodules]
tcl::tm::add [file normalize $project_root/vendormodules_tcl$tcl_major]
set libdir [file normalize $project_root/lib]
set libvdir [file normalize $project_root/lib/tcl$tcl_major]
set libvldir [file normalize $project_root/vendorlib]
set libvlvdir [file normalize $project_root/vendorlib_tcl$tcl_major]
foreach d [list $libdir $libvdir $libvldir $libvlvdir] {
if {$d ni $::auto_path} {
lappend ::auto_path $d
}
}
#------------------------------------
puts stderr "runtestmodules.tcl ::auto_path: $::auto_path"
puts stderr "runtestmodules.tcl tcl::tm::list: [tcl::tm::list]"
} }
#------------------------------------
puts stderr "runtestmodules.tcl ::auto_path: $::auto_path"
puts stderr "runtestmodules.tcl tcl::tm::list: [tcl::tm::list]"
package require punk package require punk

66
src/tests/all.tcl

@ -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

0
src/tests/modules/opunk/str/tests/all.tcl → src/tests/modules/opunk/str/testsuites/tests/all.tcl

0
src/tests/modules/opunk/str/tests/str.test → src/tests/modules/opunk/str/testsuites/tests/str.test

33
src/tests/modules/punk/path/tests/path.test

@ -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.

5
src/tests/modules/punk/path/tests/all.tcl → src/tests/modules/punk/path/testsuites/tests/all.tcl

@ -19,6 +19,11 @@ set project_root [string range $script_dir 0 $src_tests_posn-1]
#The unbuilt modules should have a higher version number (such as the magic version number 999999.0a1.0) than any installed versions to ensure they are preferred. #The unbuilt modules should have a higher version number (such as the magic version number 999999.0a1.0) than any installed versions to ensure they are preferred.
tcl::tm::add [file normalize $project_root/src/modules] tcl::tm::add [file normalize $project_root/src/modules]
tcl::tm::add [file normalize $project_root/src/modules_tcl$tcl_major] tcl::tm::add [file normalize $project_root/src/modules_tcl$tcl_major]
#temp
puts "punk::path version: [package require punk::path]"
puts "Module search path: [tcl::tm::list]"
set libdir [file normalize $project_root/src/lib] set libdir [file normalize $project_root/src/lib]
set libvdir [file normalize $project_root/src/lib/tcl$tcl_major] set libvdir [file normalize $project_root/src/lib/tcl$tcl_major]
if {$libdir ni $::auto_path} { if {$libdir ni $::auto_path} {

410
src/tests/modules/punk/path/testsuites/tests/path.test

@ -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.

125
src/tests/runtests.tcl

@ -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

BIN
src/vendormodules/packagetest-0.1.7.tm

Binary file not shown.

BIN
src/vendormodules/packagetest-0.1.8.tm

Binary file not shown.
Loading…
Cancel
Save