diff --git a/src/modules/punk-999999.0a1.0.tm b/src/modules/punk-999999.0a1.0.tm index 964855b0..ae2a5e76 100644 --- a/src/modules/punk-999999.0a1.0.tm +++ b/src/modules/punk-999999.0a1.0.tm @@ -7719,7 +7719,7 @@ namespace eval punk { } 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 { @dynamic @id -id ::punk::LOC @@ -7737,11 +7737,11 @@ namespace eval punk { @opts -return -default showdict -choices {dict showdict} -dir -default "\uFFFF" - -exclude_dupfiles -default 1 -type boolean + -no-dupfiles -default 1 -type boolean + -no-punctlines -default 1 -type boolean ${$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_punctlines -default 1 -type boolean -show_largest -default 0 -type integer -help\ "Report the top largest linecount 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_exclude_dupfiles [dict get $opts -exclude_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_dupfiles [dict get $opts -no-dupfiles] + 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_largest [dict get $opts -show_largest] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] + set opt_exclude_paths [dict get $opts -exclude-paths] + 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 dupfileloc 0 set seentails [dict create] @@ -7792,7 +7792,7 @@ namespace eval punk { set notes "" if {$has_hashfunc} { 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" } else { 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 } set lines [linelist -line {trimright} -block {trimall} $contents] - if {!$opt_exclude_punctlines} { + if {!$opt_no_punctlines} { set floc [llength $lines] set comparedlines $lines } else { @@ -7852,7 +7852,7 @@ namespace eval punk { incr dupfileloc $floc } } - if {!$isdupfile || ($isdupfile && !$opt_exclude_dupfiles)} { + if {!$isdupfile || ($isdupfile && !$opt_no_dupfiles)} { incr loc $floc incr purepunctlines $fpurepunctlines } @@ -7881,11 +7881,11 @@ namespace eval punk { ] dupfileloc $dupfileloc {*}[ ] dupinfo $dupinfo {*}[ ] 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 {*}[ ] notes $notes {*}[ ]] - if {!$opt_exclude_punctlines} { + if {!$opt_no_punctlines} { dict unset result purepunctuationlines } diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 111d1bf5..8723d8f4 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -10349,8 +10349,9 @@ tcl::namespace::eval punk::ansi::ansistring { 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 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 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? diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 0fd284b4..ae6e5ac4 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/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 :/ #todo - tk::startOfCluster / tk::endOfCluster - try to get it brought into Tcl #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) set components [list] set csplits [combiner_split $text] foreach {pt combiners} [lrange $csplits 0 end-1] { 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 {*}[lrange $clist 0 end-1] #lappend components [tcl::string::cat [lindex $clist end] $combiners] @@ -3183,7 +3185,11 @@ tcl::namespace::eval punk::char { if {$current_cluster ne ""} { lappend graphemes $current_cluster } - return $graphemes + if {$return eq "list"} { + 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 { proc about {} { diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 208e0050..f6b72cb9 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -138,36 +138,29 @@ tcl::namespace::eval punk::lib::check { if {"windows" ne $::tcl_platform(platform)} { set bug 0 } else { - if {![catch {file tempdir} tmpdir]} { - #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) + set tmpdir [punk::lib::tempdir_newfolder] ;#uses 'file tempdir' on tcl9+ or fallback to env vars or current directory on older versions + set testfile [file join $tmpdir "bugtest"] + + try { + set fd [open $testfile w] + puts $fd test + close $fd + set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] + if {[file exists $testfile]} { + file delete $testfile + } + foreach r $globresult { + if {$r ne "bugtest"} { + set bug 1 break } } - if {$tmpdir eq ""} { - #no env vars - fallback to current directory - set tmpdir [pwd] + } finally { + if {[file exists $testfile]} { + file delete $testfile } - set testfile [file join $tmpdir "bugtest"] - } - - set fd [open $testfile w] - puts $fd test - close $fd - set globresult [glob -nocomplain -directory $tmpdir -types f -tail BUGTEST {BUGTES{T}} {[B]UGTEST} {\BUGTEST} BUGTES? BUGTEST*] - if {[file exists $testfile]} { - file delete $testfile - } - foreach r $globresult { - if {$r ne "bugtest"} { - set bug 1 - break + if {[file exists $tmpdir]} { + file delete -force $tmpdir } } } @@ -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 @@ -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" } } + 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 # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm index e6ef2a90..8c46d7c0 100644 --- a/src/modules/punk/mix/cli-999999.0a1.0.tm +++ b/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 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] if {[file tail [file dirname $srcdir]] ne "src"} { diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index aa4b2344..846d829c 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -362,7 +362,7 @@ namespace eval punk::mix::commandset::module { file mkdir $modulefolder 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 diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index aecbc39c..e4dff443 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/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" set resultdict [dict create] - set antipaths [list\ - src/doc/*\ - src/doc/include/*\ - src/PROJECT_LAYOUTS_*\ - ] - - #set antiglob_dir [list\ - # _ignore_*\ - #] - set antiglob_dir [list\ - ] - - #default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized + set antipaths [list {*}{ + src/doc/* + src/doc/include/* + src/PROJECT_LAYOUTS_* + }] + + #set exclude_dirsegments [list {*}{ + # _ignore_* + #}] + set exclude_dirsegments [list {*}{ + }] + + #default -exclude-dirsegments_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized if {$opt_force} { 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 { 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] @@ -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. #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*"] - set override_antiglob_dir_core [list #* _aside .git] + ## default_exclude_dirsegments_core [list "#*" "_aside" ".git" ".fossil*"] + set override_exclude_dirsegments_core [list #* _aside .git] if {[file exists $layout_path/.fossil-custom]} { 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] } else { 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]} { 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] } else { 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]} { foreach m $opt_modules { #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 podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$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::tm_version_magic]/$m-[punk::mix::util::tm_version_magic].tm set has_tm [file exists $tmfile] set has_pod [file exists $podfile] diff --git a/src/modules/punk/mix/util-999999.0a1.0.tm b/src/modules/punk/mix/util-999999.0a1.0.tm index be0ef25d..10ef9235 100644 --- a/src/modules/punk/mix/util-999999.0a1.0.tm +++ b/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? - 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! #we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version return ${magicbase}.0a1.0 diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index b7e1a8d5..e37115e1 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/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. #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} { diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 351c0af4..7aca41ed 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -740,10 +740,10 @@ namespace eval punk::path { return $ismatch } punk::args::define { - @id -id ::punk::path::subfolders - @cmd -name punk::path::subfolders\ + @id -id ::punk::path::subfolders1 + @cmd -name punk::path::subfolders1\ -summary\ - "Listing of directories within supplied path."\ + "Listing of directories below supplied path."\ -help\ "List of folders below path. 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)" } - 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. - #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/** #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 set do_recursion [dict exists $received -recursive] set exclude_paths [dict get $opts -exclude-paths] if {"**" in $exclude_paths} { #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. - #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. - puts stderr "punk::path::subfolders Warning - exclude_paths contains '**' - all paths will be excluded" + #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::subfolders1 Warning - exclude_paths contains '**' - all paths will be excluded" return [list] } if {[dict exists $received path]} { @@ -806,49 +806,32 @@ namespace eval punk::path { # **/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 - - set omit_only_patterns [list] - set prune_base_patterns [list] - foreach pat $exclude_paths { - 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. - #by using file split, we gain some flexibility in syntax of paths and patterns, - #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. - #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. - if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { - #** at end of pattern - e.g /dir/etc/** - #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]} { - 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 - break - } - if {[globmatchpath "${base_pat}/**" $f]} { + foreach pat $exclude_paths { + 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. + #by using file split, we gain some flexibility in syntax of paths and patterns, + #but lose the ability to use backslashes as escapes to allow literal glob characters in path segments. + #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. + if {[llength $pat_parts] >= 2 && [lindex $pat_parts end] eq "**"} { + set base_pat [file join {*}[lrange $pat_parts 0 end-1]] + if {[globmatchpath $pat $f]} { set include_in_results 0 set allow_recurse 0 - break + } elseif {[globmatchpath $base_pat $f]} { + set allow_recurse 0 } + } elseif {[globmatchpath $pat $f]} { + set include_in_results 0 + } + if {!$include_in_results && !$allow_recurse} { + break } } if {$include_in_results} { @@ -860,392 +843,586 @@ namespace eval punk::path { } if {$do_recursion} { 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 } - #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 { - @id -id ::punk::path::treefilenames - @cmd -name punk::path::treefilenames\ + @id -id ::punk::path::subfolders + @cmd -name punk::path::subfolders\ -summary\ - "List of filenames below supplied path."\ + "Listing of directories below supplied path."\ -help\ - "List of filenames below path. - The resulting list is unsorted." - -directory -type directory -help\ - "folder in which to begin recursive scan for files." - -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" - -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)" - -sort -type any -default natural -choices {none ascii dictionary natural} - -antiglob_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 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." - } + "List of folders below path. + The resulting list is unsorted. + " + @opts + -recursive -type none -help\ + "" + -exclude-paths -type list -default {} -help\ + "list of path patterns to exclude from results. + May include * and ** path segments e.g /usr/** + A single /*/ will match any single segment in the path, and a single /**/ will match any number of segments in the path. - #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} { - #*** !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] - #[para] defaults to [lb]pwd[rb] - base path for tree to search - #[para] [opt -antiglob_paths] - #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** - #[para]no natsorting - so order is dependent on filesystem + e.g to exclude any path with _aside as a segment in the middle: -exclude-paths **/_aside/** + i.e this would exclude /usr/_aside/etc and /usr/x/_aside/etc but not /usr/x/_aside or _aside/etc - 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/**} + " + #todo -depth + @values -min 0 -max 1 + path -type directory -optional 1 -help\ + "Path of base folder. If not supplied current directory is used. + This may be a relative or absolute path. Relative paths are treated as relative to current directory. + 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) + Patterns in -exclude-paths are matched against the resulting paths + (so should be written to match the same relative prefix if path is relative)" + } + + proc subfolders {args} { + set argd [punk::args::parse $args withid ::punk::path::subfolders] lassign [dict values $argd] leaders opts values received - set tailglobs [dict get $values tailglobs] - # -- --- --- --- --- --- --- - set opt_sort [dict get $opts -sort] - set opt_antiglob_paths [dict get $opts -antiglob_paths] - set opt_glob_paths [dict get $opts -glob_paths] - set opt_antiglob_files [dict get $opts -antiglob_files] - - set CALLDEPTH [dict get $opts -call-depth-internal] - set callsubvector [dict get $opts -call-subvector] - 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 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] } + if {[dict exists $received path]} { + set path [dict get $values path] + } 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 files [list] - if {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort - } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {[dict exists $received -directory]} { - set opt_dir [dict get $opts -directory] - } else { - - 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]} { - return [list] + if {![llength $pattern_parts]} { + return 0 } + set pattern_head [lindex $pattern_parts 0] + set path_head [lindex $path_parts 0] - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] + if {$pattern_head eq "**"} { + if {[_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] $path_parts]} { + return 1 + } + return [_pattern_prefix_viable_parts $pattern_parts [lrange $path_parts 1 end]] + } + + if {[::punk::path::globmatchpath $pattern_head $path_head]} { + return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] + } + return 0 } - #comment out to compare timings with treefilenames_zipfs - if {[string match //zipfs:/* $opt_dir]} { - return [treefilenames_zipfs {*}$args] + proc pattern_prefix_viable {pattern path} { + return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] } - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $opt_dir]} { - set skip 1 - break + 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]] } - } - if {$skip} { - return [list] + return "" } - #todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? - if {[catch {glob -nocomplain -dir $opt_dir -type f {*}$tailglobs} matches]} { - #we can get for example a permissions error - puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches" - 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 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 + } + + if {[pattern_prefix_viable $gp $path]} { + set recurse_below 1 + } + } + + return [dict create {*}{ + } include_files $include_files {*}{ + } recurse_below $recurse_below {*}{ + } next_allbelow $next_allbelow {*}{ } + ] + } + + 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 { - set dirfiles [lsort $retained] + return [lsort $paths] } dictionary { - set dirfiles [lsort -dictionary $retained] + return [lsort -dictionary $paths] } natural { - set dirfiles [natsort::sort $retained] + return [natsort::sort $paths] } default { - set dirfiles $retained + return $paths } } } - lappend files {*}$dirfiles - if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { - puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" - set dirdirs [list] - } - set okdirs [list] - foreach dir $dirdirs { - set skip 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break + proc _path_matches_any {patterns path} { + foreach pattern $patterns { + if {[::punk::path::globmatchpath $pattern $path]} { + return 1 } } - if {!$skip} { - lappend okdirs $dir + return 0 + } + + 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] - foreach dir $okdirs { - foreach gp $opt_glob_paths { - if {[globmatchpath $gp $dir] || [globmatchpath "$gp/**" $dir]} { - lappend matchdirs $dir + proc _retain_files {matches exclude_files sortmode} { + set retained [list] + foreach match $matches { + set skip 0 + 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 + } } + return [_sort_paths $retained $sortmode] } - if {[llength $matchdirs]} { - switch -- $opt_sort { - ascii { - set finaldirs [lsort $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] + } + + set glob_paths [dict get $opts -include-paths] + if {"*" in $glob_paths} { + set glob_paths {*} + } + + 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] {*}{ } - dictionary { - set finaldirs [lsort -dictionary $matchdirs] + ] + } + + 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] + } + set opt_dir_match [_tailbase_match_path $opt_tailbase $opt_dir] + if {[_path_matches_any $opt_exclude_paths $opt_dir_match]} { + 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] } - natural { - set finaldirs [natsort::sort $matchdirs] + lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] + } + + if {![dict get $dir_state recurse_below]} { + return $files + } + + if {[catch {glob -nocomplain -dir $opt_dir -type d *} dirdirs]} { + puts stderr "treefilenames error while listing subdirs in dir $opt_dir\n $dirdirs" + set dirdirs [list] + } + set okdirs [list] + foreach dir $dirdirs { + if {![_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { + lappend okdirs $dir } - default { - set finaldirs $matchdirs + } + + if {$opt_glob_paths eq "*"} { + set matchdirs $okdirs + } else { + set matchdirs [list] + foreach dir $okdirs { + if {$callallbelow || [child_path_state $opt_glob_paths [_tailbase_match_path $opt_tailbase $dir] $callallbelow]} { + lappend matchdirs $dir + } } } + + set finaldirs [_sort_paths $matchdirs $opt_sort] + set childallbelow [expr {$callallbelow || [dict get $dir_state next_allbelow]}] + set nextsubvector [list {*}$subvector [file tail $opt_dir]] foreach dir $finaldirs { - set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] - lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] + 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 } - 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 {$CALLDEPTH == 0} { - if {$opt_sort eq "natural"} { - package require natsort - } - #set opts [dict merge $opts [list -directory $opt_dir]] - if {![dict exists $received -directory]} { - set opt_dir [pwd] - } else { - set opt_dir [dict get $opts -directory] + + 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 {![file isdirectory $opt_dir]} { + set dir [string trimright $opt_dir "/"] + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]]} { return [list] } - } else { - #assume/require to exist in any recursive call - set opt_dir [dict get $opts -directory] - } - 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 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $dir]} { - set skip 1 - break - } - } - if {$skip} { - return [list] - } - set subpaths [zipfs list $dir/*] - set dirlist [list] - set skipdirs [list] - set filelist [list] - #process in the order they came - sorting large list more expensive?? review - foreach sub $subpaths { - set tail [string range $sub $dirlen+1 end] ;#dirlen is without trailing slash - set tailparts [file split $tail] - set accum "" - set skipdir 0 - foreach tp [lrange $tailparts 0 end-1] { - append accum "/$tp" - set superpath "${dir}${accum}" - if {$superpath in $skipdirs} { - #subpart already in skipdirs - set skipdir 1 - break - } - if {$superpath ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $superpath]} { - set skip2 1 + set dirlen [string length $dir] + set subpaths [zipfs list $dir/*] + set dirlist [list] + set skipdirs [list] + set filelist [list] + foreach sub $subpaths { + set tail [string range $sub $dirlen+1 end] + set tailparts [file split $tail] + set accum "" + set skipdir 0 + foreach tailpart [lrange $tailparts 0 end-1] { + append accum "/$tailpart" + set superpath "${dir}${accum}" + if {$superpath in $skipdirs} { + set skipdir 1 + break + } + if {$superpath ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]]} { lappend skipdirs $superpath + set skipdir 1 break + } else { + lappend dirlist $superpath } } - if {!$skip2} { - lappend dirlist $superpath - } else { - set skipdir 1 - break - } } - } - if {!$skipdir} { - #process final part of path - append accum "/[lindex $tailparts end]" - set finalpart "${dir}${accum}" - if {$finalpart ni $dirlist} { - if {[file type $finalpart] eq "file"} { - set ftail [lindex $tailparts end] - set match 0 - if {"*" ni $tailglobs} { - foreach tg $tailglobs { - if {[string match $tg $ftail]} { - set match 1 - break + if {!$skipdir} { + append accum "/[lindex $tailparts end]" + set finalpart "${dir}${accum}" + if {$finalpart ni $dirlist} { + if {[file type $finalpart] eq "file"} { + set file_tail [lindex $tailparts end] + set match 0 + if {"*" ni $tailglobs} { + foreach tailglob $tailglobs { + if {[string match $tailglob $file_tail]} { + set match 1 + break + } } + } else { + set match 1 } - } else { - set match 1 - } - if {$match} { - if {[llength $opt_antiglob_files]} { + if {$match} { + 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 - foreach anti $opt_antiglob_files { - if {[string match $anti $ftail]} { - set skipfile 1; break + foreach anti $opt_exclude_files { + if {[string match $anti $file_tail]} { + set skipfile 1 + break } } if {!$skipfile} { - lappend filelist $finalpart + lappend filelist [_tailbase_relative $opt_tailbase $finalpart] } - } else { - lappend filelist $finalpart } - } - } else { - if {$finalpart ni $dirlist} { - set skip2 0 - foreach anti $opt_antiglob_paths { - if {[globmatchpath $anti $finalpart]} { - set skip2 1 + } else { + if {$finalpart ni $dirlist} { + if {[_path_matches_any $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]]} { lappend skipdirs $finalpart - break + } else { + lappend dirlist $finalpart } } - if {!$skip2} { - lappend dirlist $finalpart - } } } } } + return [_sort_paths $filelist $opt_sort] } - switch -- $opt_sort { - ascii { - set finalfilelist [lsort $filelist] - } - dictionary { - set finalfilelist [lsort -dictionary $filelist] - } - natural { - set finalfilelist [natsort::sort $filelist] - } - default { - set finalfilelist $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." + } + + #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 diff --git a/src/modules/punkcheck-999999.0a1.0.tm b/src/modules/punkcheck-999999.0a1.0.tm index 9d5ffd84..8097e910 100644 --- a/src/modules/punkcheck-999999.0a1.0.tm +++ b/src/modules/punkcheck-999999.0a1.0.tm @@ -41,9 +41,9 @@ namespace eval punkcheck { summarize_install_resultdict } - #antiglob_dir & antiglob_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_antiglob_file_core "" + #exclude-dir & exclude-file entries match the pattern at any level - should not contain path separators + variable default_exludedirseg_core [list "#*" "_aside" "_build" ".git" ".fossil*"] + variable default_excludefiletail_core "" set has_twapi 0 if {"windows" eq $::tcl_platform(platform)} { @@ -56,16 +56,16 @@ namespace eval punkcheck { interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate } - proc default_antiglob_dir_core {} { - variable default_antiglob_dir_core - return $default_antiglob_dir_core + proc default_excludedirseg_core {} { + variable default_excludedirseg_core + return $default_excludedirseg_core } - proc default_antiglob_file_core {} { - variable default_antiglob_file_core - if {$default_antiglob_file_core eq ""} { - set default_antiglob_file_core [list "*.swp" "*[punk::mix::util::magic_tm_version]*" "*-buildversion.txt" ".punkcheck"] + proc default_excludefiletail_core {} { + variable default_excludefiletail_core + if {$default_excludefiletail_core eq ""} { + 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 {*}{ -glob *.tm -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] @@ -1276,17 +1276,16 @@ namespace eval punkcheck { } proc install_non_tm_files {srcdir basedir args} { #set keys [dict keys $args] - #adjust the default antiglob_dir_core entries so that .fossil-custom, .fossil-settings are copied - set antiglob_dir_core [punkcheck::default_antiglob_dir_core] - set posn [lsearch $antiglob_dir_core ".fossil*"] + #adjust the default excludedirseg_core entries so that .fossil-custom, .fossil-settings are copied + set excludedirseg_core [punkcheck::default_excludedirseg_core] + set posn [lsearch $excludedirseg_core ".fossil*"] if {$posn >=0} { - #set antiglob_dir_core [lreplace $antiglob_dir_core $posn $posn] - set antiglob_dir_core [lreplace $antiglob_dir_core[set antiglob_dir_core {}] $posn $posn] + ledit excludedirseg_core $posn $posn } set defaults [list {*}{ } -glob * {*}{ - } -antiglob_file [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ - } -antiglob_dir_core $antiglob_dir_core {*}{ + } -exclude-filetails [list "*.tm" "*-buildversion.txt" "*.exe"] {*}{ + } -exclude-dirsegment_core $excludedirseg_core {*}{ } -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" -glob -type string -default "*" -help\ "Pattern matching for source file(s) to copy. Can be glob based or exact match." - -antiglob_file_core -default {${[::punkcheck::default_antiglob_file_core]}} - -antiglob_file -default "" - -antiglob_dir_core -default {${[::punkcheck::default_antiglob_dir_core]}} - -antiglob_dir -default "" + -exclude-filetails_core -default {${[::punkcheck::default_excludefiltail_core]}} + -exclude-filetails -default "" + -exclude-dirsegments_core -default {${[::punkcheck::default_excludedirseg_core]}} + -exclude-dirsegments -default "" -antiglob_paths -default {} -overwrite -default no-targets\ -choices {no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets}\ @@ -1417,10 +1416,10 @@ namespace eval punkcheck { -createdir 0 -createempty 0 -glob * - -antiglob_file_core "\uFFFF" - -antiglob_file "" - -antiglob_dir_core "\uFFFF" - -antiglob_dir {} + -exclude-filetails_core "\uFFFF" + -exclude-filetails "" + -exclude-dirsegments_core "\uFFFF" + -exclude-dirsegments {} -antiglob_paths {} -overwrite no-targets -source_checksum comparestore @@ -1475,31 +1474,31 @@ namespace eval punkcheck { #now the values we build from these will be properly cased } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - set opt_antiglob_file_core [dict get $opts -antiglob_file_core] - if {$opt_antiglob_file_core eq "\uFFFF"} { - set opt_antiglob_file_core [default_antiglob_file_core] - dict set opts -antiglob_file_core $opt_antiglob_file_core + set opt_excludefiletail_core [dict get $opts -exclude-filetails_core] + if {$opt_excludefiletail_core eq "\uFFFF"} { + set opt_excludefiletail_core [default_excludefiletail_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 - foreach af $opt_antiglob_file { + foreach af $opt_excludefiletail { 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] - if {$opt_antiglob_dir_core eq "\uFFFF"} { - set opt_antiglob_dir_core [default_antiglob_dir_core] - dict set opts -antiglob_dir_core $opt_antiglob_dir_core + set opt_excludedirseg_core [dict get $opts -exclude-dirsegments_core] + if {$opt_excludedirseg_core eq "\uFFFF"} { + set opt_excludedirseg_core [default_excludedirseg_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 - foreach ad $opt_antiglob_dir { + foreach ad $opt_excludedirseg { 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] foreach m $candidate_list { 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]} { #puts stderr "anti: $anti vs m:$m" set suppress 1 @@ -1970,9 +1969,9 @@ namespace eval punkcheck { #puts stderr "subdirs: $subdirs" foreach d $subdirs { 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]} { - #puts stdout "SKIPPING FOLDER $d due to antiglob_dir-match: $dg " + #puts stdout "SKIPPING FOLDER $d due to excludedirseg-match: $dg " set skipd 1 break } @@ -2002,19 +2001,19 @@ namespace eval punkcheck { set sub_opts_1 [list {*}{ - } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ - } -subdirlist [list {*}$subdirlist $d] {*}{ - } -glob $fileglob {*}{ - } -antiglob_file_core $opt_antiglob_file_core {*}{ - } -antiglob_file $opt_antiglob_file {*}{ - } -antiglob_dir_core $opt_antiglob_dir_core {*}{ - } -antiglob_dir $opt_antiglob_dir {*}{ - } -overwrite $overwrite_what {*}{ - } -source_checksum $opt_source_checksum {*}{ - } -punkcheck_folder $punkcheck_folder {*}{ - } -punkcheck_eventid $punkcheck_eventid {*}{ - } -punkcheck_records $punkcheck_records {*}{ - } -installer $opt_installer {*}{ + } -call-depth-internal [expr {$CALLDEPTH + 1}] {*}{ + } -subdirlist [list {*}$subdirlist $d] {*}{ + } -glob $fileglob {*}{ + } -exclude-filetails_core $opt_excludefiletail_core {*}{ + } -exclude-filetails $opt_excludefiletail {*}{ + } -exclude-dirsegments_core $opt_excludedirseg_core {*}{ + } -exclude-dirsegments $opt_excludedirseg {*}{ + } -overwrite $overwrite_what {*}{ + } -source_checksum $opt_source_checksum {*}{ + } -punkcheck_folder $punkcheck_folder {*}{ + } -punkcheck_eventid $punkcheck_eventid {*}{ + } -punkcheck_records $punkcheck_records {*}{ + } -installer $opt_installer {*}{ } ] set sub_opts [list {*}{ diff --git a/src/modules/shellfilter-999999.0a1.0.tm b/src/modules/shellfilter-999999.0a1.0.tm index 2174e99c..2e2ffc01 100644 --- a/src/modules/shellfilter-999999.0a1.0.tm +++ b/src/modules/shellfilter-999999.0a1.0.tm @@ -326,18 +326,34 @@ namespace eval shellfilter::chan { #method flush {ch} { # return "" #} + #method flush {transform_handle} { + # #puts stdout "" + # #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} { - #puts stdout "" - #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'" + #puts stderr " $transform_handle o_encbuf: '$o_encbuf' datavars: $o_datavars" + 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_encbuf "" - return "" + foreach v $o_datavars { + append $v $stringdata + } + return $stringdata } method write {ch bytes} { #test with set x [string repeat " \U1f6c8" 2043] @@ -442,16 +458,29 @@ namespace eval shellfilter::chan { # flush $o_localchan # 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} { - #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_buffered$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 "" - return "" + return $stringdata } method write {transform_handle bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -533,11 +562,24 @@ namespace eval shellfilter::chan { ::shellfilter::log::write $o_logsource $logdata return $bytes } + #method flush {transform_handle} { + # #return "" + # set clear $o_encbuf + # set o_encbuf "" + # #review + # return $clear + #} method flush {transform_handle} { - #return "" - set clear $o_encbuf + set clear $o_buffered$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 "" - return $o_encbuf + return $stringdata } method write {ch bytes} { #set logdata [tcl::encoding::convertfrom $o_enc $bytes] @@ -613,9 +655,21 @@ namespace eval shellfilter::chan { my destroy } #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} { - #we wouldn't have a value in o_encbuf if it was convertable from the channel encoding? - if {[string length $o_encbuf]} { + set clear $o_buffered$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 #- 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. @@ -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 oo::class create reconvert { variable o_trecord @@ -1114,7 +1272,6 @@ namespace eval shellfilter::chan { # return $emit #} method flush {transform_handle} { - #return "" set clear $o_buffered$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? diff --git a/src/modules/test/#modpod-overtype-999999.0a1.0/overtype-999999.0a1.0.tm b/src/modules/test/#modpod-overtype-999999.0a1.0/overtype-999999.0a1.0.tm index e52ddb65..61f10545 100644 --- a/src/modules/test/#modpod-overtype-999999.0a1.0/overtype-999999.0a1.0.tm +++ b/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 package require packagetest + puts "test::overtype - packagetest version: [package provide packagetest]" packagetest::makeAPI test::overtype $version overtype; #will package provide test::overtype $version package forget overtype package require overtype @@ -64,7 +65,7 @@ tcl::namespace::eval test::overtype { # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { + punk::args::lib::tstr [string trim { package test::overtype test suite for overtype module } \n] diff --git a/src/modules/test/runtestmodules.tcl b/src/modules/test/runtestmodules.tcl index 3d46cea0..47ee5d7c 100644 --- a/src/modules/test/runtestmodules.tcl +++ b/src/modules/test/runtestmodules.tcl @@ -14,53 +14,96 @@ if {$modules_posn < 0} { } set modules_base [string range $script_dir 0 $modules_posn-1] if {[file tail $modules_base] eq "src"} { + set test_type "unbuilt" set project_root [file dirname $modules_base] } else { + set test_type "installed" set project_root $modules_base } + 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. -#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 [file normalize $project_root/src/modules] -exclude {**/_build/** **/_build}] -foreach sub $subfolders { - #In most cases we could use string match - but the * within modpod-*-999999.0a1.0 could match a forward slash which could then match some other file under a #modpod- folder structure, - #so we use globmatchpath which treats * as matching any characters except path separators. - if {[globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { - set modname [file tail $sub] - set modname [string range $modname 8 end-12] ;#strip off #modpod- and -999999.0a1.0 - set modpath [file join $sub "$modname-999999.0a1.0.tm"] - #!!!! - #todo - calculate fully qualified module name based on path relative to the modules folder we added to the tcl::tm path. - if {[file exists $modpath]} { - puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $modname at path $modpath" - package ifneeded $modname 999999.0a1.0 [list source $modpath] - } else { - puts stderr "runtestmodules.tcl warning: expected mod.tcl not found for modpod module $modname at path $modpath" + +#review - punk::path may itself be a module under test. +#we should ideally be independent of the modules under test. +#same goes for punk and punk::args. +package require punk::path + + +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, + #so we use globmatchpath which treats * as matching any characters except path separators. + if {[punk::path::globmatchpath "**/#modpod-*-999999.0a1.0" $sub]} { + set modname [file tail $sub] + set modname [string range $modname 8 end-13] ;#strip off #modpod- and -999999.0a1.0 + set modpath [file join $sub "$modname-999999.0a1.0.tm"] + #calculate fully qualified module name based on path relative to the modules folder we added to the tcl::tm path. + set relpath [punk::path::relative $project_root/src/modules [file dirname $sub]] + if {$relpath eq "."} { + set relpath "" + set fullmodname $modname + } else { + set components [file split $relpath] + set fullmodname [join $components ::]::$modname + } + #!!!! + #todo - review whether we also need to add the path to the module's folder to the auto_path to ensure that any 'package require' calls within the module will find the unbuilt version of any dependencies. + #we probably do need to do this - otherwise if there is an installed version of a dependency it could be loaded instead of the unbuilt version which is likely not what we want when running tests against unbuilt modules. + + if {[file exists $modpath]} { + puts stderr "runtestmodules.tcl adding package ifneeded for modpod module $fullmodname at path $modpath" + package ifneeded $modname 999999.0a1.0 [list source $modpath] + } else { + 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 libvdir [file normalize $project_root/src/lib/tcl$tcl_major] + set libvldir [file normalize $project_root/src/vendorlib] + set libvlvdir [file normalize $project_root/src/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]" +} 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/src/lib] -set libvdir [file normalize $project_root/src/lib/tcl$tcl_major] -set libvldir [file normalize $project_root/src/vendorlib] -set libvlvdir [file normalize $project_root/src/vendorlib_tcl$tcl_major] -foreach d [list $libdir $libvdir $libvldir $libvlvdir] { - if {$d ni $::auto_path} { - lappend ::auto_path $d + 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 diff --git a/src/tests/all.tcl b/src/tests/all.tcl deleted file mode 100644 index 66c8e779..00000000 --- a/src/tests/all.tcl +++ /dev/null @@ -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 /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 \ No newline at end of file diff --git a/src/tests/modules/opunk/str/tests/all.tcl b/src/tests/modules/opunk/str/testsuites/tests/all.tcl similarity index 100% rename from src/tests/modules/opunk/str/tests/all.tcl rename to src/tests/modules/opunk/str/testsuites/tests/all.tcl diff --git a/src/tests/modules/opunk/str/tests/str.test b/src/tests/modules/opunk/str/testsuites/tests/str.test similarity index 100% rename from src/tests/modules/opunk/str/tests/str.test rename to src/tests/modules/opunk/str/testsuites/tests/str.test diff --git a/src/tests/modules/punk/path/tests/path.test b/src/tests/modules/punk/path/tests/path.test deleted file mode 100644 index a20eb5a4..00000000 --- a/src/tests/modules/punk/path/tests/path.test +++ /dev/null @@ -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. \ No newline at end of file diff --git a/src/tests/modules/punk/path/tests/all.tcl b/src/tests/modules/punk/path/testsuites/tests/all.tcl similarity index 88% rename from src/tests/modules/punk/path/tests/all.tcl rename to src/tests/modules/punk/path/testsuites/tests/all.tcl index cdee0917..0e004025 100644 --- a/src/tests/modules/punk/path/tests/all.tcl +++ b/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. tcl::tm::add [file normalize $project_root/src/modules] 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 libvdir [file normalize $project_root/src/lib/tcl$tcl_major] if {$libdir ni $::auto_path} { diff --git a/src/tests/modules/punk/path/testsuites/tests/path.test b/src/tests/modules/punk/path/testsuites/tests/path.test new file mode 100644 index 00000000..f14fbf6f --- /dev/null +++ b/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. \ No newline at end of file diff --git a/src/tests/runtests.tcl b/src/tests/runtests.tcl new file mode 100644 index 00000000..111916c9 --- /dev/null +++ b/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 /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 /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 \ No newline at end of file diff --git a/src/vendormodules/packagetest-0.1.7.tm b/src/vendormodules/packagetest-0.1.7.tm index 658d45a4..6dd409dd 100644 Binary files a/src/vendormodules/packagetest-0.1.7.tm and b/src/vendormodules/packagetest-0.1.7.tm differ diff --git a/src/vendormodules/packagetest-0.1.8.tm b/src/vendormodules/packagetest-0.1.8.tm new file mode 100644 index 00000000..5ab00010 Binary files /dev/null and b/src/vendormodules/packagetest-0.1.8.tm differ