You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1890 lines
86 KiB
1890 lines
86 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::path 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::path 0 999999.0a1.0] |
|
#[copyright "2023"] |
|
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] |
|
#[require punk::path] |
|
#[description] |
|
#[keywords module path filesystem] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::path |
|
#[para] Filesystem path utility functions |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::path |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require punk::args |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6-}] |
|
#[item] [package {punk::args}] |
|
|
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# oo::class namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#namespace eval punk::path::class { |
|
#*** !doctools |
|
#[subsection {Namespace punk::path::class}] |
|
#[para] class definitions |
|
#if {[info commands [namespace current]::interface_sample1] eq ""} { |
|
#*** !doctools |
|
#[list_begin enumerated] |
|
|
|
# oo::class create interface_sample1 { |
|
# #*** !doctools |
|
# #[enum] CLASS [class interface_sample1] |
|
# #[list_begin definitions] |
|
|
|
# method test {arg1} { |
|
# #*** !doctools |
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
|
# #[para] test method |
|
# puts "test: $arg1" |
|
# } |
|
|
|
# #*** !doctools |
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
|
# } |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end class enumeration ---}] |
|
#} |
|
#} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::path { |
|
namespace export {[a-z]*} |
|
#variable xyz |
|
|
|
#*** !doctools |
|
#[subsection {Namespace punk::path}] |
|
#[para] Core API functions for punk::path |
|
#[list_begin definitions] |
|
|
|
# -- --- |
|
#punk::path::normjoin |
|
# - simplify . and .. segments as far as possible whilst respecting specific types of root. |
|
# -- --- |
|
#a form of file normalize that supports //xxx to be treated as server path names |
|
#(ie regardless of unices ignoring (generally) leading double slashes, and regardless of windows volumerelative path syntax) |
|
#(sometimes //server.com used as a short form for urls - which doesn't seem too incompatible with this anyway) |
|
# -- --- |
|
#This is intended to be purely a string analysis - without reference to filesystem volumes or vfs or zipfs mountpoints etc |
|
#(but this also means we won't be able to resolve windows shortnames or dos device paths - so we will preserve those as they are) - review |
|
#(It also means we can't resolve per drive working directories on windows - so we will preserve c: as is rather than converting to absolute - review) |
|
# |
|
#TODO - option for caller to provide a -base below which we can't backtrack. |
|
#This is preferable to setting policy here for example regarding forcing no trackback below //servername/share |
|
#Our default is to allow trackback to: |
|
# <scheme>://<something> |
|
# <driveletter>:/ |
|
# //./<volume> (dos device volume) |
|
# //server (while normalizing //./UNC/server to same) |
|
# / (ordinary unix root) |
|
# ./../<repeated> - (track back indefinitely on relpath as we are not resolving to anything physical and can't fully simplify the leading backtracks) |
|
# |
|
#The caller should do the file/vfs operations to determine this - not us. |
|
# -- --- |
|
#simplify path with respect to /./ & /../ elements - independent of platform |
|
#NOTE: "anomalies" in standard tcl processing on windows: |
|
#e.g file normalize {//host} -> c:/host (or e.g d:/host if we happen to be on another volume) |
|
#file normalize {//host/share} -> //host/share |
|
#This is because //host is treated as volume-relative in cmd/powershell and Tcl quite reasonably follows suit. |
|
#This prevents cwd and windows commandlines from pointing to the server (above the share) |
|
#Explorer however does allow pointing to the //server level and seeing shares as if they are directory entries. |
|
#we are more interested in supporting the explorer-like behaviour - as while volumerelative paths are also useful on windows - they are lesser known. |
|
#REVIEW. |
|
#To get back to some consistent cross platform behaviour - we will treat //something as a root/volume i.e we can't backtrack above it with ".." |
|
#note too that file split on UNC paths doesn't give a clear indication of the root |
|
# file split //./UNC/server/share/subpath -> //./UNC server share subpath |
|
# file split //server/share/subpath -> //server/share subpath |
|
#TODO - disallow all change of root or change from relative path to absolute result. |
|
#e.g normjoin relpath/../d:/secret should not return d:/secret - but ./d:/secret |
|
# ================ |
|
#known issues: |
|
#1) |
|
# normjoin d://a//b//c -> d://a/b/c |
|
# This is because we don't detect specific schemes. ie it's treated the same as https://a/b/c -> https://a/b/c |
|
# Not considered a problem - just potentially surprising. |
|
# To avoid it we would have to enumerate possible schemes. |
|
# As it stands a unix system could define a 'scheme' that happens to match windows style driveletters. Consider a 'feature' ? review. |
|
# won't fix? |
|
#2) |
|
# normjoin https:///real.com/../fake.com -> https:///fake.com |
|
# The extra slash means effectively our servername is empty - this is potentially confusing but probably the right thing to do here. |
|
# It's a concern only if upstream treats the tripple slash in this case as valid and maps it to https:// - which would probably be bad anyway. |
|
# won't fix (review) |
|
#3) |
|
#similarly |
|
# normjoin //./UNC//server/share/subpath -> ///server/share/subpath (when 2 or more slashes directly after UNC) |
|
# normjoin ///server/share -> ///server/share |
|
#This is effectively an empty servername in the input with 'server' being pushed one level down - and the output is consistent |
|
# possibly won't fix - review |
|
#4) inconsistency |
|
# we return normalized //server/share for //./UNC/server share |
|
# but other dos device paths are maintained |
|
# e.g //./c:/etc |
|
# This is because such paths could contain alternate segment names (windows shortnames) which we aren't in a position to resolve. |
|
# caller should |
|
# #as with 'case' below - caller will need to run a post 'file normalize' |
|
#5) we don't normalize case like file normalize does on windows platform. |
|
# This is intentional. It could only be done with reference to underlying filesystem which we don't want here. |
|
# |
|
# ================ |
|
# |
|
#relpaths all end up with leading . - while not always the simplest form, this is ok. (helps stop inadvertent conversions to absolutes) |
|
# Tests - TODO |
|
# normjoin /d:/..//vfs:/test -> /vfs:/test (good - not converted to //vfs:/test) |
|
|
|
#normjoin c: should theoretically return current per drive working directory on c: |
|
# - would need to use win32 GetFullPathName to resolve this. |
|
proc normjoin {args} { |
|
set args [lmap a $args {string map "\\\\ /" $a}] |
|
set path [plainjoin {*}$args] |
|
switch -exact -- $path { |
|
"" { |
|
return "" |
|
} |
|
/ - // { |
|
#treated in unixlike manner - (but leading doubleslashes with subsequent data are server indication) |
|
#// not considered a servername indicator - but /// (for consistency) is. (empty servername?) |
|
return / |
|
} |
|
/// { |
|
#if this is effectively //$emptyservername/ |
|
#then for consistency we should trail //<servername with a slash too? |
|
#we can't transform to // or / |
|
return /// |
|
#assert - code below should return /// (empty server prefix) for any number of leading slashes >=3 |
|
#todo - shortcircuit that here? |
|
} |
|
} |
|
# /// |
|
set doubleslash1_posn [string first // $path] |
|
|
|
# -- --- --- temp warning on windows only - no x-platform difference in result |
|
#on windows //host is of type volumerelative |
|
# whereas //host/share is of type absolute |
|
if {"windows" eq $::tcl_platform(platform) && [file pathtype $path] eq "volumerelative"} { |
|
#volumerelative probably only occurs on windows anyway |
|
if {$doubleslash1_posn == 0} { |
|
#e.g //something where no further slashes |
|
#review - eventually get rid of this warning and require upstream to know the appropriate usecase |
|
puts stderr "Warning - ambiguous path $path - treating as server path - not 'volumerelative'" |
|
} else { |
|
# /something/etc |
|
# /mnt/c/stuff |
|
#output will retain leading / as if on unix. |
|
#on windows - the result would still be interpreted as volumerelative if the caller normalizes it |
|
} |
|
} |
|
# -- --- --- |
|
|
|
set is_relpath 0 |
|
|
|
#set path [string map [list \\ /] $path] |
|
set finalparts [list] |
|
set is_nonunc_dosdevice 0 |
|
if {[punk::winpath::is_dos_device_path $path]} { |
|
#review |
|
if {[string range $path 4 6] eq "UNC"} { |
|
#convert to 'standard' //server/... path for processing |
|
set path "/[string range $path 7 end]" ;# //server/... |
|
} else { |
|
#error "normjoin non-UNC dos device path '$path' not supported" |
|
#first segment after //./ or //?/ represents the volume or drive. |
|
#not applicable to unix - but unlikely to conflict with a genuine usecase there (review) |
|
#we should pass through and stop navigation below //./vol |
|
#!!! |
|
#not anomaly in tcl (continues in tcl9) |
|
#file exists //./c:/test -> 0 |
|
#file exists //?/c:/test -> 1 |
|
#file exists //./BootPartition/Windows -> 1 |
|
#file exists //?/BootPartition/Windows -> 0 |
|
set is_nonunc_dosdevice 1 |
|
} |
|
} |
|
|
|
if {$is_nonunc_dosdevice} { |
|
#dosdevice prefix //./ or //?/ - preserve it (without trailing slash which will be put back in with join) |
|
set prefix [string range $path 0 2] |
|
set tail [string range $path 4 end] |
|
set tailparts [split $tail /] |
|
set parts [concat [list $prefix] $tailparts] |
|
set rootindex 1 ;#disallow backtrack below //./<volume> |
|
} else { |
|
#note use of ordinary ::split vs file split is deliberate. |
|
if {$doubleslash1_posn == 0} { |
|
#this is handled differently on different platforms as far as 'file split' is concerned. |
|
#e.g for file split //sharehost/share/path/etc |
|
#e.g on windows: -> //sharehost/share path |
|
#e.g on freebsd: -> / sharehost share path etc |
|
#however..also on windows: file split //sharehost -> / sharehost |
|
#normalize by dropping leading slash before split - and then treating first 2 segments as a root |
|
#set parts [file split [string range $path 1 end]] |
|
set parts [split $path /] |
|
#assert parts here has {} {} as first 2 entries |
|
set rootindex 2 |
|
#currently prefer can backtrack to the //zipfs:/ scheme (below the mountpoint - to browse other mounts) |
|
#alternative handling for //zipfs:/path - don't go below mountpoint |
|
#but we can't determine just from string if mountpoint is direct subpath or a lower one e.g //zipfs:/arbitraryname/actualmountpoint |
|
#review - more generally //<mountmechanism>:/path ? |
|
#todo - make an option for zipfs and others to determine the 'base' |
|
#if {"zipfs:" eq [lindex $parts 2]} { |
|
# set rootindex 3 |
|
#} |
|
} else { |
|
#path may or may not begin with a single slash here. |
|
#treat same on unix and windows |
|
set rootindex 0 |
|
#set parts [file split $path] |
|
set parts [::split $path /] |
|
#e.g /a/b/c -> {} a b c |
|
#or relative path a/b/c -> a b c |
|
#or c:/a/b/c -> c: a b c |
|
if {[string match *: [lindex $parts 0]]} { |
|
if {[lindex $parts 1] eq ""} { |
|
#scheme://x splits to scheme: {} x |
|
set parts [concat [list [lindex $parts 0]/] [lrange $parts 2 end]] |
|
#e.g {scheme:/ x} |
|
set rootindex 1 ;#disallow below first element of scheme |
|
} else { |
|
set rootindex 0 |
|
} |
|
} elseif {[lindex $parts 0] ne ""} { |
|
#relpath a/b/c |
|
#set parts [linsert $parts 0 .] |
|
ledit parts -1 -1 . |
|
set rootindex 0 |
|
#allow backtracking arbitrarily for leading .. entries - simplify where possible |
|
#also need to stop possible conversion to absolute path |
|
set is_relpath 1 |
|
} |
|
} |
|
} |
|
set baseparts [lrange $parts 0 $rootindex] ;#base below which we can't retreat via ".." |
|
#puts stderr "-->baseparts:$baseparts" |
|
#ensure that if our rootindex already spans a dotted segment (after the first one) we remove it |
|
#must maintain initial . for relpaths to stop them converting to absolute via backtrack |
|
# |
|
set finalparts [list [lindex $baseparts 0]] |
|
foreach b [lrange $baseparts 1 end] { |
|
if {$b ni {. ..}} { |
|
lappend finalparts $b |
|
} |
|
} |
|
set baselen [expr {$rootindex + 1}] |
|
if {$is_relpath} { |
|
set i [expr {$rootindex+1}] |
|
foreach p [lrange $parts $i end] { |
|
switch -exact -- $p { |
|
. - "" {} |
|
.. { |
|
switch -exact -- [lindex $finalparts end] { |
|
. - .. { |
|
lappend finalparts .. |
|
} |
|
default { |
|
#lpop finalparts |
|
ledit finalparts end end |
|
} |
|
} |
|
} |
|
default { |
|
lappend finalparts $p |
|
} |
|
} |
|
incr i |
|
} |
|
} else { |
|
foreach p [lrange $parts $rootindex+1 end] { |
|
if {[llength $finalparts] <= $baselen} { |
|
if {$p ni {. .. ""}} { |
|
lappend finalparts $p |
|
} |
|
} else { |
|
switch -exact -- $p { |
|
. - "" {} |
|
.. { |
|
#lpop finalparts ;#uses punk::lib::compat::lpop if on < 8.7 |
|
ledit finalparts end end ;#uses punk::lib::compat::ledit if on < 8.7 |
|
} |
|
default { |
|
lappend finalparts $p |
|
} |
|
} |
|
} |
|
} |
|
} |
|
#puts "==>finalparts: '$finalparts'" |
|
# using join - {"" "" server share} -> //server/share and {a b} -> a/b |
|
if {[llength $finalparts] == 1 && [lindex $finalparts 0] eq ""} { |
|
#backtracking on unix-style path can end up with empty string as only member of finalparts |
|
#e.g /x/.. |
|
return / |
|
} |
|
set result [::join $finalparts /] |
|
#normalize volumes and mountschemes to have trailing slash if no subpath |
|
#e.g c: -> c:/ |
|
#//zipfs: -> //zipfs:/ |
|
if {[set lastchar [string index $result end]] eq ":"} { |
|
if {$result eq "//zipfs:"} { |
|
set result "//zipfs:/" |
|
} else { |
|
if {[string first / $result] < 0} { |
|
set result $result/ |
|
} |
|
} |
|
} elseif {[string match //* $result]} { |
|
if {![punk::winpath::is_dos_device_path $result]} { |
|
#server |
|
set tail [string range $result 2 end] |
|
set tailparts [split $tail /] |
|
if {[llength $tailparts] <=1} { |
|
#empty // or //servername |
|
append result / |
|
} |
|
} |
|
} elseif {[llength $finalparts] == 2} { |
|
if {[string range [lindex $finalparts 0] end-1 end] eq ":/"} { |
|
#e.g https://server/ -> finalparts {https:/ server} |
|
#e.g https:/// -> finalparts {https:/ ""} |
|
#scheme based path should always return trailing slash after server component - even if server component empty. |
|
lappend finalparts "" ;#force trailing / |
|
return [join $finalparts /] |
|
} |
|
} |
|
if {[file extension [lindex $finalparts end]] eq ".lnk"} { |
|
if {![catch {package require punk::winlnk}]} { |
|
if {![catch {punk::winlnk::target $result} path]} { |
|
return $path |
|
} |
|
} |
|
} |
|
return $result |
|
} |
|
|
|
proc trim_final_slash {str} { |
|
if {[string index $str end] eq "/"} { |
|
return [string range $str 0 end-1] |
|
} |
|
return $str |
|
} |
|
|
|
|
|
#x-platform - punk::path::pathtype - can be used in safe interps - different concept of pathtypes to 'file pathtype' |
|
# - no volumerelative |
|
# - no lookup of file volumes (volume is a windows concept - but with //zipfs:/ somewhat applicable to other platforms) |
|
# - /* as absolute (covers also //zipfs:/ (volume), //server , //./etc , //./UNC) |
|
# - xxx:// as absolute (scheme) |
|
# - xxx:/ or x:/ as absolute |
|
# - x: xxx: -> as absolute (volume-basic or volume-extended) |
|
|
|
#note also on windows - legacy name for COM devices |
|
# COM1 = COM1: |
|
# //./COM1 ?? review |
|
|
|
proc pathtype {str} { |
|
set str [string map "\\\\ /" $str] |
|
if {[string index $str 0] eq "/"} { |
|
#todo - look for //xxx:/ prefix (generalisation of //zipfs:/) as a 'volume' specifically {volume mount} ?? - review |
|
# look for //server prefix as {absolute server} |
|
# look for //./UNC/server or //?/UNC/server as {absolute server UNC} ? |
|
# look for //./<dosdevice> as {absolute dosdevice} |
|
return absolute |
|
} |
|
|
|
#only firstsegment with single colon at last position (after some non empty string) counts as volume or scheme - review |
|
#e.g a:b:/.. or a::/.. or :/.. is not treated as volume/scheme whereas ab:/ is. |
|
set firstslash [string first / $str] |
|
if {$firstslash == -1} { |
|
set firstsegment $str |
|
} else { |
|
set firstsegment [string range $str 0 $firstslash-1] |
|
} |
|
if {[set firstc [string first : $firstsegment]] > 0} { |
|
set lhs_firstsegment [string range $firstsegment 0 $firstc-1] |
|
set rhs_firstsegment [string range $firstsegment $firstc+1 end] ;#exclude a:b/ etc |
|
if {$rhs_firstsegment eq ""} { |
|
set rhs_entire_path [string range $str $firstc+1 end] |
|
#assert lhs_firstsegment not empty since firstc > 0 |
|
#count following / sequence |
|
set i 0 |
|
set slashes_after_firstsegment "" ;#run of slashes *directly* following first segment |
|
while {$i < [string length $rhs_entire_path]} { |
|
if {[string index $rhs_entire_path $i] eq "/"} { |
|
append slashes_after_firstsegment / |
|
} else { |
|
break |
|
} |
|
incr i |
|
} |
|
switch -exact -- $slashes_after_firstsegment { |
|
"" - / { |
|
if {[string length $lhs_firstsegment] == 1} { |
|
return {absolute volume basic} |
|
} else { |
|
return {absolute volume extended} |
|
} |
|
} |
|
default { |
|
#2 or more / |
|
#this will return 'scheme' even for c:// - even though that may look like a windows volume - review |
|
return {absolute scheme} |
|
} |
|
} |
|
} |
|
} |
|
#assert first element of any return has been absolute or relative |
|
return relative |
|
} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::path::scriptlib_resolve |
|
@cmd -name "punk::path::scriptlib_resolve"\ |
|
-summary\ |
|
"Resolve a scriptlib script name to a path using the punk kit search policy"\ |
|
-help\ |
|
"Resolves a relative script name (the part after a 'lib:' prefix |
|
in punk executable launch arguments) against the scriptlib |
|
locations, in the same order the punk shell uses: |
|
|
|
1. the kit vfs internal scriptlib (<zipfs-root>/app/scriptlib, |
|
or <exedir>/scriptlib for an unwrapped kit directory). |
|
Internal scripts are deliberately NOT overridable by |
|
external files (integrity and performance). |
|
2. <exedir-parent>/scriptlib - e.g <projectroot>/scriptlib for |
|
an executable in <projectroot>/bin. |
|
3. <exedir-grandparent>/scriptlib. |
|
|
|
If the name's extension (lowercased) is one of the known |
|
scriptlib extensions (.tcl .kit .py .pl .ps1 .sh), only that |
|
exact name is searched. Otherwise two spellings are tried within |
|
EACH location before moving to the next (so the kit-internal |
|
precedence above is never crossed by a spelling preference): |
|
1. the exact name as called - accepted only if the file's |
|
first lines identify it as a tcl script: a leading |
|
'# tcl' comment, a shebang naming tclsh/tclkit/wish, or |
|
the portable sh-trampoline ('#!/bin/sh' followed by a |
|
commented 'exec tclsh ...' in the next lines). |
|
2. the name with '.tcl' appended. |
|
An exact-name file that fails the tcl identification check is |
|
skipped (recorded in notes) and resolution falls through. |
|
|
|
Returns a dict with keys: |
|
path - resolved absolute path, or empty string if not found |
|
scriptname - the relative name that matched; when not found, |
|
the primary name searched for |
|
scripttype - resolved script type: the extension without its |
|
dot (tcl, kit, py, pl, ps1, sh), 'tcl' for an |
|
extensionless file that passed the identification |
|
check, or empty string when not found |
|
candidates - the locations that were (or would be) checked, |
|
for use in error messages |
|
notes - explanatory notes (e.g files skipped by the tcl |
|
identification check), for use in error messages. |
|
Raises an error if name is not a relative path." |
|
@leaders |
|
name -type string -optional 0 -help\ |
|
"relative script name, with or without a known extension |
|
(any leading lib: prefix should already be stripped)" |
|
}] |
|
} |
|
proc scriptlib_resolve {name} { |
|
#shared resolution policy for the 'lib:' script prefix - used by the punk |
|
#executable 'script' subcommand (app-punkscript) and the shell subcommand's |
|
#lib: handling (app-punkshell, app_shellrun). |
|
if {[lindex [pathtype $name] 0] ne "relative"} { |
|
error "punk::path::scriptlib_resolve name must be a relative path (got '$name')" |
|
} |
|
set known_extensions [list .tcl .kit .py .pl .ps1 .sh] |
|
#spellings: {relname needs_tcl_check} pairs tried in order within each |
|
#directory - the spelling matching the way the script was called wins |
|
#per-directory, and directory precedence (kit-internal first) is never |
|
#crossed by a spelling preference. |
|
if {[string tolower [file extension $name]] ni $known_extensions} { |
|
#extensionless (or unknown-extension) call: the exact name wins when |
|
#the file identifies as tcl, else fall through to the .tcl spelling. |
|
set spellings [list [list $name 1] [list $name.tcl 0]] |
|
set scriptname $name.tcl |
|
} else { |
|
set spellings [list [list $name 0]] |
|
set scriptname $name |
|
} |
|
set exepath [file dirname [file normalize [file join [info nameofexecutable] ___]]] ;#symlink resolve |
|
#1) kit-internal scriptlib - not overridable externally |
|
set has_zipfs_command [expr {[info commands ::tcl::zipfs::root] ne ""}] |
|
set kit_base "" |
|
if {$has_zipfs_command && [file exists [tcl::zipfs::root]]} { |
|
set kit_base [tcl::zipfs::root] |
|
} elseif {[file type $exepath] eq "directory"} { |
|
set kit_base $exepath |
|
} |
|
set kit_libdir "" |
|
if {$has_zipfs_command && $kit_base ne "" && [file exists $kit_base/app/scriptlib]} { |
|
set kit_libdir $kit_base/app/scriptlib |
|
} elseif {[file exists $exepath/scriptlib]} { |
|
set kit_libdir $exepath/scriptlib |
|
} |
|
set search_dirs [list] |
|
if {$kit_libdir ne ""} { |
|
lappend search_dirs $kit_libdir |
|
} |
|
#2,3) external scriptlib folders relative to the executable location |
|
set exedir [file dirname $exepath] |
|
lappend search_dirs [file join $exedir scriptlib] [file join [file dirname $exedir] scriptlib] |
|
|
|
set candidates [list] |
|
set notes [list] |
|
foreach dir $search_dirs { |
|
foreach spelling $spellings { |
|
lassign $spelling relname needs_tcl_check |
|
set fpath [file join $dir $relname] |
|
lappend candidates $fpath |
|
if {![file isfile $fpath]} { |
|
#isfile (not exists) - an extensionless call must not match a directory of the same name |
|
continue |
|
} |
|
if {$needs_tcl_check} { |
|
if {![punk::path::system::scriptfile_is_tcl $fpath]} { |
|
lappend notes "$fpath exists but its first lines do not identify it as tcl (leading '# tcl' comment or tcl shebang) - skipped" |
|
continue |
|
} |
|
set scripttype tcl |
|
} else { |
|
set scripttype [string range [string tolower [file extension $fpath]] 1 end] |
|
} |
|
return [dict create path $fpath scriptname $relname scripttype $scripttype candidates $candidates notes $notes] |
|
} |
|
} |
|
return [dict create path "" scriptname $scriptname scripttype "" candidates $candidates notes $notes] |
|
} |
|
|
|
proc plain {str} { |
|
set str [string map "\\\\ /" $str] |
|
set pathinfo [punk::path::pathtype $str] |
|
if {[lindex $pathinfo 0] eq "relative" && ![string match ./* $str]} { |
|
set str ./$str |
|
} |
|
if {[string index $str end] eq "/"} { |
|
if {[string map {/ ""} $str] eq ""} { |
|
#all slash segment |
|
return $str |
|
} else { |
|
if {[lindex $pathinfo 1] ni {volume scheme}} { |
|
return [string range $str 0 end-1] |
|
} |
|
} |
|
} |
|
return $str |
|
} |
|
#purely string based - no reference to filesystem knowledge |
|
#unix-style forward slash only |
|
proc plainjoin {args} { |
|
set args [lmap a $args {string map "\\\\ /" $a}] |
|
#if {[llength $args] == 1} { |
|
# return [lindex $args 0] |
|
#} |
|
set out "" |
|
foreach a $args { |
|
if {![string length $out]} { |
|
append out [plain $a] |
|
} else { |
|
set a [plain $a] |
|
if {[string map {/ ""} $out] eq ""} { |
|
set out [string range $out 0 end-1] |
|
} |
|
|
|
if {[string map {/ ""} $a] eq ""} { |
|
#all / segment |
|
append out [string range $a 0 end-1] |
|
} else { |
|
if {[string length $a] > 2 && [string match "./*" $a]} { |
|
set a [string range $a 2 end] |
|
} |
|
if {[string index $out end] eq "/"} { |
|
append out $a |
|
} else { |
|
append out / $a |
|
} |
|
} |
|
} |
|
} |
|
return $out |
|
} |
|
proc plainjoin1 {args} { |
|
if {[llength $args] == 1} { |
|
return [lindex $args 0] |
|
} |
|
set out [trim_final_slash [lindex $args 0]] |
|
foreach a [lrange $args 1 end] { |
|
set a [trim_final_slash $a] |
|
append out / $a |
|
} |
|
return $out |
|
} |
|
|
|
#intention? |
|
#proc filepath_dotted_dirname {path} { |
|
#} |
|
|
|
proc strip_prefixdepth {path prefix} { |
|
if {$prefix eq ""} { |
|
return [norm $path] |
|
} |
|
return [file join {*}{ |
|
} {*}[lrange {*}{ |
|
} [file split [norm $path]] {*}{ |
|
} [llength [file split [norm $prefix]]] {*}{ |
|
} end |
|
] |
|
] |
|
} |
|
|
|
|
|
## for comparison |
|
#proc nsglob_as_re {glob} { |
|
# #any segment that is not just * must match exactly one segment in the path |
|
# set pats [list] |
|
# foreach seg [nsparts_cached $glob] { |
|
# switch -exact -- $seg { |
|
# "" { |
|
# lappend pats "" |
|
# } |
|
# * { |
|
# #review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed |
|
# #lappend pats {[^:]*} |
|
# #negative lookahead |
|
# #any number of chars not followed by ::, followed by any number of non : |
|
# lappend pats {(?:.(?!::))*[^:]*} |
|
# } |
|
# ** { |
|
# lappend pats {.*} |
|
# } |
|
# default { |
|
# set seg [string map {. [.]} $seg] |
|
# if {[regexp {[*?]} $seg]} { |
|
# #set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] |
|
# set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] |
|
# lappend pats "$pat" |
|
# } else { |
|
# lappend pats "$seg" |
|
# } |
|
# } |
|
# } |
|
# } |
|
# return "^[join $pats ::]\$" |
|
#} |
|
proc pathglob_as_re {pathglob} { |
|
#*** !doctools |
|
#[call [fun pathglob_as_re] [arg pathglob]] |
|
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|**|***|? in any segment of the path structure |
|
#[para] Does not support square bracket globs or character classes. |
|
#[para] ** as a whole segment matches one or more segments. |
|
#[para] *** as a whole segment matches zero or more segments - e.g /etc/*** will match /etc itself as well as anything below it. (added 2026-07-20, G-093) |
|
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) |
|
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc |
|
#[para] any segment that does not contain ** must match exactly one segment in the path |
|
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc |
|
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. |
|
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals |
|
|
|
|
|
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * |
|
# - would require counting immediately-preceding backslashes |
|
set zom "\x00zom\x00" ;#zero-or-more-segments marker for whole-segment *** (segment regexes never contain \x00) |
|
set pats [list] |
|
foreach seg [file split $pathglob] { |
|
if {[string range $seg end end] eq "/"} { |
|
set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up |
|
} |
|
switch -- $seg { |
|
* {lappend pats {[^/]*}} |
|
** {lappend pats {.*}} |
|
*** { |
|
#zero or more whole segments - adjacent *** duplicates collapse to one |
|
if {[lindex $pats end] ne $zom} { |
|
lappend pats $zom |
|
} |
|
} |
|
default { |
|
set seg [string map [list ^ {\^} $ {\$} \[ {\[} \] {\]} ( {\(} ) {\)} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters (or tcl glob square bracket chars) in the input as literals |
|
#set seg [string map [list . {[.]}] $seg] |
|
set seg [string map {. [.]} $seg] |
|
if {[regexp {[*?]} $seg]} { |
|
set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] |
|
lappend pats "$pat" |
|
} else { |
|
lappend pats "$seg" |
|
} |
|
} |
|
} |
|
} |
|
#join with / - except around zero-or-more markers, which must absorb one adjacent |
|
#separator (a plain join cannot express 'zero segments'): |
|
# X/*** -> ^X(?:/.*)?$ (trailing marker absorbs the preceding separator) |
|
# ***/X a/***/b -> (?:.*/)?X ... (marker carries its trailing separator inside the |
|
# optional group; no separator follows the marker) |
|
# *** -> ^.*$ |
|
set n [llength $pats] |
|
set out "" |
|
for {set i 0} {$i < $n} {incr i} { |
|
set pat [lindex $pats $i] |
|
set is_zom [expr {$pat eq $zom}] |
|
set is_last [expr {$i == $n - 1}] |
|
if {$i > 0 && [lindex $pats $i-1] ne $zom && !($is_zom && $is_last)} { |
|
append out / |
|
} |
|
if {$is_zom} { |
|
if {$n == 1} { |
|
append out {.*} |
|
} elseif {$is_last} { |
|
append out {(?:/.*)?} |
|
} else { |
|
append out {(?:.*/)?} |
|
} |
|
} else { |
|
append out $pat |
|
} |
|
} |
|
return "^${out}\$" |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::path::globmatchpath |
|
@cmd -name punk::path::globmatchpath\ |
|
-summary\ |
|
"Match path to *|**|? glob patterns"\ |
|
-help\ |
|
"Return a boolean indicating whether the path matches the specialised glob pattern. |
|
A pattern such as /usr/*/bin will match any path that has /usr as the first segment and bin as the third segment, |
|
with any single segment in between. |
|
A pattern such as /usr/**/bin will match any path that has /usr as the first segment and bin as the last segment, |
|
with 1 or more segments in between (so it will not match /usr/bin). |
|
A pattern such as /usr/** will match any path that has /usr as the first segment, with 1 or more segments |
|
following (so it will not match /usr itself). |
|
A pattern such as /usr/*** will match /usr itself as well as any path below /usr |
|
- *** as a whole segment matches zero or more segments (added 2026-07-20, G-093). |
|
A pattern such as **/*.txt will match any path that ends with .txt, with 1 or more leading segments |
|
(so it will not match test.txt or .txt). Use ***/*.txt to also match a bare test.txt. |
|
A pattern such as ** will match any path. |
|
The glob characters * and ? (and the whole-segment forms ** and ***) are the only special characters in the pathglob syntax. |
|
- they are treated as glob characters regardless of where they appear in the pathglob string. |
|
Note that this is different from other Tcl glob contexts where square brackets can be used. |
|
The pathglob syntax treats other characters, including square brackets as literals. |
|
For example, the pattern /usr/te?t will match /usr/test and /usr/text but not /usr/texxt, and the pattern /usr/te*t |
|
will match /usr/test, /usr/teat, and /usr/teeeet but not /usr/te/t. |
|
The pathglob syntax does not support escaping of glob characters - any glob characters in the pathglob are treated |
|
as glob characters. For example, the pattern /usr/* will match any path that has /usr as the first segment and any |
|
single segment as the second segment, but there is no way to specify a pattern that matches any path that has /usr |
|
as the first segment and a literal * as the second segment. |
|
Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) |
|
|
|
options: |
|
-nocase 0|1 (default 0 - case sensitive) |
|
If -nocase is not supplied - default to case sensitive *except for driveletter* |
|
ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) |
|
Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. |
|
" |
|
@leaders |
|
pathglob -type string -help "glob pattern to match path against. See [fun pathglob_as_re] for syntax of glob patterns" |
|
path -type string -help "path to match against glob pattern" |
|
@opts |
|
-nocase -type boolean -default 0 -help\ |
|
"case insensitive matching (default false - case sensitive) |
|
- except for driveletter on windows which is always case insensitive |
|
unless -nocase 0 is explicitly specified" |
|
@values -min 0 -max 0 |
|
} |
|
# -id |
|
proc globmatchpath {pathglob path args} { |
|
#*** !doctools |
|
#[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] |
|
#[para] Return true if the pathglob matches the path |
|
#[para] see [fun pathglob_as_re] for pathglob description |
|
#[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) |
|
#[para] |
|
#[para] Known options: |
|
#[para] -nocase 0|1 (default 0 - case sensitive) |
|
#[para] If -nocase is not supplied - default to case sensitive *except for driveletter* |
|
#[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) |
|
#[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. |
|
|
|
set opts [dict create {*}{ |
|
-nocase \uFFFF |
|
}] |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-nocase { |
|
dict set opts $k $v |
|
} |
|
default { |
|
error "Unrecognised option '$k'. Known-options: [dict keys $opts]" |
|
} |
|
} |
|
} |
|
# -- --- --- --- --- --- |
|
set opt_nocase [dict get $opts -nocase] |
|
set explicit_nocase 1 ;#default to disprove |
|
if {$opt_nocase eq "\uFFFF"} { |
|
set opt_nocase 0 |
|
set explicit_nocase 0 |
|
} |
|
# -- --- --- --- --- --- |
|
if {$opt_nocase} { |
|
return [regexp -nocase [pathglob_as_re $pathglob] $path] |
|
} else { |
|
set re [pathglob_as_re $pathglob] |
|
if {$explicit_nocase} { |
|
set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter |
|
} else { |
|
#caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. |
|
#Direct head rewrite of the anchored regex: if the pattern begins with a windows |
|
#drive segment (^c:...) make just the drive letter class-insensitive. |
|
#(The previous file-split of the regex text broke on forms where a group is glued |
|
# to the drive - e.g ^c:(?:/.*)?$ from c:/*** - and allowed non-alpha 'drives'.) |
|
if {[regexp {^\^([A-Za-z]):(.*)$} $re _match driveletter rest]} { |
|
set re "^\[[string tolower $driveletter][string toupper $driveletter]\]:$rest" |
|
} |
|
#puts stderr "-->re: $re" |
|
set ismatch [regexp $re $path] |
|
} |
|
} |
|
return $ismatch |
|
} |
|
punk::args::define { |
|
@id -id ::punk::path::subfolders1 |
|
@cmd -name punk::path::subfolders1\ |
|
-summary\ |
|
"Listing of directories below supplied path."\ |
|
-help\ |
|
"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. |
|
|
|
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 |
|
|
|
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 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 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 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::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 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]} { |
|
set path [dict get $values path] |
|
} else { |
|
set path [pwd] |
|
} |
|
|
|
set all_subfolders [glob -nocomplain -directory $path -types d *] |
|
|
|
|
|
#example of expected exclude_paths pattern behaviour when recursion is enabled: |
|
# **/dirname -> omit /x/y/dirname, but still visit /x/y/dirname/* |
|
|
|
# **/dirname/* -> include /x/y/dirname and /x/y/dirname/a/b but omit directories that are a single level below /x/y/dirname such as /x/y/dirname/a |
|
|
|
#c:/** - would exclude all subfolders below c: but not c: itself |
|
|
|
# **/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 folders [list] |
|
set recurse_subdirs [list] |
|
|
|
foreach f $all_subfolders { |
|
set include_in_results 1 |
|
set allow_recurse 1 |
|
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 |
|
} 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} { |
|
lappend folders $f |
|
} |
|
if {$allow_recurse} { |
|
lappend recurse_subdirs $f |
|
} |
|
} |
|
if {$do_recursion} { |
|
foreach subdir $recurse_subdirs { |
|
lappend folders {*}[subfolders1 -exclude-paths $exclude_paths -recursive $subdir] |
|
} |
|
} |
|
return $folders |
|
} |
|
|
|
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::subfolders |
|
@cmd -name punk::path::subfolders\ |
|
-summary\ |
|
"Listing of directories below supplied path."\ |
|
-help\ |
|
"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. |
|
|
|
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 |
|
|
|
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 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] |
|
} |
|
|
|
namespace eval treefile_priv { |
|
proc _path_segment_matches {pattern_segment path_segment} { |
|
if {[::punk::path::globmatchpath $pattern_segment $path_segment]} { |
|
return 1 |
|
} |
|
if {[string range $pattern_segment end end] eq "/" && [string range $path_segment end end] eq "/"} { |
|
set root_probe __punk_path_root_probe__ |
|
return [::punk::path::globmatchpath [file join $pattern_segment $root_probe] [file join $path_segment $root_probe]] |
|
} |
|
return 0 |
|
} |
|
|
|
proc _pattern_prefix_viable_parts {pattern_parts path_parts} { |
|
if {![llength $path_parts]} { |
|
return 1 |
|
} |
|
if {![llength $pattern_parts]} { |
|
return 0 |
|
} |
|
|
|
set pattern_head [lindex $pattern_parts 0] |
|
set path_head [lindex $path_parts 0] |
|
|
|
if {$pattern_head eq "**" || $pattern_head eq "***"} { |
|
#both spanning forms admit consuming zero path segments here (viability only |
|
#asks whether a match below remains possible - *** additionally full-matches |
|
#with zero segments, which globmatchpath handles) |
|
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 {[_path_segment_matches $pattern_head $path_head]} { |
|
return [_pattern_prefix_viable_parts [lrange $pattern_parts 1 end] [lrange $path_parts 1 end]] |
|
} |
|
return 0 |
|
} |
|
|
|
proc pattern_prefix_viable {pattern path} { |
|
return [_pattern_prefix_viable_parts [file split $pattern] [file split $path]] |
|
} |
|
|
|
proc pattern_boundary {pattern} { |
|
#the directory at which a trailing-** pattern's subtree begins (that directory |
|
#itself does not full-match X/** - the boundary branch grants descent+allbelow |
|
#without including its files). Trailing-*** patterns need no boundary: they |
|
#full-match their base directory directly. |
|
set parts [file split $pattern] |
|
if {[llength $parts] >= 2 && [lindex $parts end] eq "**"} { |
|
return [file join {*}[lrange $parts 0 end-1]] |
|
} |
|
return "" |
|
} |
|
|
|
proc pattern_tail_spans {pattern} { |
|
#1 when the pattern's final segment is ** or *** - a directory matching such a |
|
#pattern implies every deeper directory also matches it (basis for the include |
|
#allbelow shortcut and the exclude subtree prune). An exact or single-segment-glob |
|
#tail does not extend below its match, keeping the in-dir (X), one-below (X/*), |
|
#one-or-more-below (X/**) and zero-or-more-below (X/***) forms separable. |
|
set last [lindex [file split $pattern] end] |
|
return [expr {$last eq "**" || $last eq "***"}] |
|
} |
|
|
|
proc exclude_state {exclude_paths path} { |
|
#Directory-oriented exclusion classification (separability fix 2026-07-20, G-093 - |
|
#previously ANY matching pattern pruned the whole subtree, so an exact exclude |
|
#like **/_aside also killed everything below _aside, contradicting the argdoc's |
|
#distinct **/_aside vs **/_aside/** forms and the punk::path::subfolders precedent): |
|
# subtree - a matching pattern's final segment is **|*** : prune path and all below |
|
# files - matched by non-spanning pattern(s) only: exclude the files directly in |
|
# path, but keep walking below it |
|
# none - not excluded |
|
set state none |
|
foreach xp $exclude_paths { |
|
if {[::punk::path::globmatchpath $xp $path]} { |
|
if {[pattern_tail_spans $xp]} { |
|
return subtree |
|
} |
|
set state files |
|
} |
|
} |
|
return $state |
|
} |
|
|
|
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 |
|
if {[pattern_tail_spans $gp]} { |
|
#trailing **|*** - every deeper directory also matches this pattern |
|
set next_allbelow 1 |
|
break |
|
} |
|
#exact or single-segment-glob tail: this match includes only the files |
|
#directly here - later patterns may still grant descent/allbelow |
|
#(previously any full match set next_allbelow and broke, dragging the |
|
# whole subtree in for exact/X-star patterns - separability fix 2026-07-20, |
|
# G-093; the zipfs walk already behaved separably) |
|
continue |
|
} |
|
|
|
set boundary [pattern_boundary $gp] |
|
if {$boundary ne "" && [::punk::path::globmatchpath $boundary $path]} { |
|
set recurse_below 1 |
|
set next_allbelow 1 |
|
continue |
|
} |
|
|
|
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 |
|
} |
|
} |
|
return 0 |
|
} |
|
|
|
proc _sort_paths {paths sortmode} { |
|
switch -- $sortmode { |
|
ascii { |
|
return [lsort $paths] |
|
} |
|
dictionary { |
|
return [lsort -dictionary $paths] |
|
} |
|
natural { |
|
return [natsort::sort $paths] |
|
} |
|
default { |
|
return $paths |
|
} |
|
} |
|
} |
|
|
|
proc _tailbase_relative {tailbase path} { |
|
if {$tailbase eq ""} { |
|
return $path |
|
} |
|
return [::punk::path::relative $tailbase $path] |
|
} |
|
|
|
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 |
|
} |
|
|
|
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] |
|
} |
|
|
|
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] |
|
} |
|
|
|
#-include-paths patterns are taken as-is: a bare * is the one-below lattice form, |
|
#not a legacy match-everything alias (special-case collapse removed 2026-07-20, |
|
#G-093 - use ** or *** for match-everything) |
|
set glob_paths [dict get $opts -include-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] {*}{ |
|
} |
|
] |
|
} |
|
|
|
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] |
|
set dir_exclude_state [exclude_state $opt_exclude_paths $opt_dir_match] |
|
if {$dir_exclude_state eq "subtree"} { |
|
return [list] |
|
} |
|
|
|
set files [list] |
|
set dir_state [directory_state $opt_glob_paths $opt_dir_match $callallbelow] |
|
if {[dict get $dir_state include_files] && $dir_exclude_state eq "none"} { |
|
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 { |
|
#also match hidden files (e.g dotfiles on windows where glob -type f misses them) |
|
if {![catch {glob -nocomplain -dir $opt_dir -types {hidden f} -- {*}$tailglobs} hidden_matches]} { |
|
foreach h $hidden_matches { |
|
if {$h ni $matches} { |
|
lappend matches $h |
|
} |
|
} |
|
} |
|
set dirfiles [_retain_files $matches $opt_exclude_files $opt_sort] |
|
} |
|
lappend files {*}[_tailbase_relative_list $opt_tailbase $dirfiles] |
|
} |
|
|
|
if {![dict get $dir_state recurse_below]} { |
|
return $files |
|
} |
|
|
|
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] |
|
} |
|
#also match hidden directories |
|
if {![catch {glob -nocomplain -dir $opt_dir -types {hidden d} *} hidden_dirdirs]} { |
|
foreach h $hidden_dirdirs { |
|
#glob -dir returns full paths; compare the tail so '.' and '..' are filtered on all platforms |
|
switch -- [file tail $h] { |
|
"." - ".." {continue} |
|
default { |
|
if {$h ni $dirdirs} { |
|
lappend dirdirs $h |
|
} |
|
} |
|
} |
|
} |
|
} |
|
set okdirs [list] |
|
foreach dir $dirdirs { |
|
#only subtree exclusions prune descent here - a child matched by a |
|
#non-spanning exclude still walks (its own entry pass drops its files) |
|
if {[exclude_state $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]] ne "subtree"} { |
|
lappend okdirs $dir |
|
} |
|
} |
|
|
|
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 child_state [dict merge $state [dict create {*}{ |
|
} directory $dir {*}{ |
|
} depth [expr {$depth + 1}] {*}{ |
|
} subvector $nextsubvector {*}{ |
|
} allbelow $childallbelow {*}{ |
|
} |
|
]] |
|
lappend files {*}[walk_treefilenames $child_state] |
|
} |
|
return $files |
|
} |
|
|
|
proc walk_treefilenames_zipfs {state} { |
|
set opt_dir [dict get $state directory] |
|
set opt_tailbase [dict get $state tailbase] |
|
set opt_exclude_paths [dict get $state exclude_paths] |
|
set opt_exclude_files [dict get $state exclude_files] |
|
set opt_glob_paths [dict get $state glob_paths] |
|
set opt_sort [dict get $state sort] |
|
set tailglobs [dict get $state tailglobs] |
|
|
|
if {![string match [zipfs root]* $opt_dir]} { |
|
error "treefilenames_zipfs can only be used on paths beginning with [zipfs root] on this systems" |
|
} |
|
set dir [string trimright $opt_dir "/"] |
|
if {[exclude_state $opt_exclude_paths [_tailbase_match_path $opt_tailbase $dir]] eq "subtree"} { |
|
return [list] |
|
} |
|
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 {[exclude_state $opt_exclude_paths [_tailbase_match_path $opt_tailbase $superpath]] eq "subtree"} { |
|
lappend skipdirs $superpath |
|
set skipdir 1 |
|
break |
|
} else { |
|
lappend dirlist $superpath |
|
} |
|
} |
|
} |
|
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 |
|
} |
|
if {$match} { |
|
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 && [exclude_state $opt_exclude_paths $file_dir_match] ne "none"} { |
|
#files-level exclusion of the immediate directory |
|
#(subtree exclusions were pruned via the superpath loop) |
|
set match 0 |
|
} |
|
} |
|
if {$match} { |
|
set skipfile 0 |
|
foreach anti $opt_exclude_files { |
|
if {[string match $anti $file_tail]} { |
|
set skipfile 1 |
|
break |
|
} |
|
} |
|
if {!$skipfile} { |
|
lappend filelist [_tailbase_relative $opt_tailbase $finalpart] |
|
} |
|
} |
|
} else { |
|
if {$finalpart ni $dirlist} { |
|
if {[exclude_state $opt_exclude_paths [_tailbase_match_path $opt_tailbase $finalpart]] eq "subtree"} { |
|
lappend skipdirs $finalpart |
|
} else { |
|
lappend dirlist $finalpart |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return [_sort_paths $filelist $opt_sort] |
|
} |
|
} |
|
|
|
#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 |
|
** as a whole segment 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 ) |
|
*** as a whole segment matches 0 or more segments in the path (so /usr/*** will match /usr itself as well as anything below it) |
|
? 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 directory path patterns to exclude |
|
may include *, ** and *** path segments e.g |
|
/usr (exclude files directly within /usr; subfolders |
|
are still walked) |
|
/usr/* (exclude files in folders exactly one below /usr) |
|
/usr/** (exclude the subtrees based at /usr but not |
|
files within /usr itself) |
|
/usr/*** (exclude files within /usr and all its subfolders) |
|
**/_aside (exclude files where _aside is last segment) |
|
**/_aside/** (exclude everything below any _aside segment) |
|
Patterns whose final segment is ** or *** prune the matched |
|
subtree; other matches exclude only the files directly in the |
|
matching folder. Exclusion wins over inclusion for the same file." |
|
-exclude-files -default {} |
|
-include-paths -default {**} -help\ |
|
"list of directory path patterns to include |
|
may include *, ** and *** path segments e.g |
|
/usr (include files directly within /usr only) |
|
/usr/* (include files in folders exactly one below /usr) |
|
/usr/** (include files in subfolders based at /usr but not |
|
files within /usr itself) |
|
/usr/*** (include files within /usr and all its subfolders) |
|
**/_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) |
|
A directory matching a pattern contributes the files directly within |
|
it; patterns whose final segment is ** or *** also include everything |
|
below their match. The /usr, /usr/*, /usr/** and /usr/*** forms are |
|
deliberately separable." |
|
@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 [treefile_priv::walk_treefilenames_zipfs $state] |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::path::relative |
|
@cmd -name punk::path::relative\ |
|
-summary\ |
|
"Compute the relative path from a reference path to a location path."\ |
|
-help\ |
|
"Taking two directory paths, a reference and a location, computes the path |
|
of the location relative to the reference. |
|
|
|
Will return a single dot '.' if the paths are the same. |
|
|
|
Both paths must be the same type - ie both absolute or both relative. |
|
|
|
Matching is case sensitive. On windows, the drive-letter component (only) is |
|
not case sensitive, so punk::path::relative c:/etc C:/etc returns '.'. |
|
The part following the driveletter is case sensitive, so |
|
punk::path::relative c:/etc C:/Etc returns ../Etc. |
|
|
|
On windows, if the paths are absolute and specify different volumes, |
|
only the location will be returned." |
|
@leaders -min 2 -max 2 |
|
reference -type string -help\ |
|
"The path from which the relative path to location is determined." |
|
location -type string -help\ |
|
"The location path which may be above or below the reference path." |
|
} |
|
#maint warning - also in punkcheck |
|
proc relative {reference location} { |
|
#see also kettle |
|
# Modified copy of ::fileutil::relative (tcllib) |
|
# Adapted to 8.5 ({*}). |
|
|
|
#review - check volume info on windows.. UNC paths? |
|
if {[file pathtype $reference] ne [file pathtype $location]} { |
|
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" |
|
} |
|
|
|
#avoid normalizing if possible (file normalize *very* expensive on windows) |
|
set do_normalize 0 |
|
if {[file pathtype $reference] eq "relative"} { |
|
#if reference is relative so is location |
|
if {[regexp {[.]{2}} [list $reference $location]]} { |
|
set do_normalize 1 |
|
} |
|
if {[regexp {[.]/} [list $reference $location]]} { |
|
set do_normalize 1 |
|
} |
|
} else { |
|
set do_normalize 1 |
|
} |
|
if {$do_normalize} { |
|
set reference [file normalize $reference] |
|
set location [file normalize $location] |
|
} |
|
|
|
set save $location |
|
set reference [file split $reference] |
|
set location [file split $location] |
|
|
|
while {[lindex $location 0] eq [lindex $reference 0]} { |
|
set location [lrange $location 1 end] |
|
set reference [lrange $reference 1 end] |
|
if {![llength $location]} {break} |
|
} |
|
|
|
set location_len [llength $location] |
|
set reference_len [llength $reference] |
|
|
|
if {($location_len == 0) && ($reference_len == 0)} { |
|
# Cases: |
|
# (a) reference == location |
|
|
|
set location . |
|
} else { |
|
# Cases: |
|
# (b) ref is: ref/sub = sub |
|
# loc is: ref = {} |
|
|
|
# (c) ref is: ref = {} |
|
# loc is: ref/sub = sub |
|
|
|
while {$reference_len > 0} { |
|
#set location [linsert $location 0 ..] |
|
ledit location -1 -1 .. |
|
incr reference_len -1 |
|
} |
|
set location [file join {*}$location] |
|
} |
|
return $location |
|
} |
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::path ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::path::lib { |
|
namespace export * |
|
namespace path [namespace parent] |
|
#*** !doctools |
|
#[subsection {Namespace punk::path::lib}] |
|
#[para] Secondary functions that are part of the API |
|
#[list_begin definitions] |
|
|
|
|
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::path::lib ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[section Internal] |
|
namespace eval punk::path::system { |
|
#*** !doctools |
|
#[subsection {Namespace punk::path::system}] |
|
#[para] Internal functions that are not part of the API |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::path::system::scriptfile_is_tcl |
|
@cmd -name "punk::path::system::scriptfile_is_tcl"\ |
|
-summary\ |
|
"Test whether a script file's first lines identify it as a tcl script"\ |
|
-help\ |
|
"Reads a small bounded chunk (512 bytes) of the file and reports 1 if |
|
the first line is a '# tcl'-prefixed comment (case-insensitive), a |
|
shebang naming tclsh/tclkit/wish, or any other shebang whose next |
|
few lines contain the portable sh-trampoline 'exec tclsh ...' idiom. |
|
A UTF-8 BOM and CRLF line endings are tolerated. Returns 0 for |
|
unreadable files and anything not identified as tcl. |
|
Used by punk::path::scriptlib_resolve to allow extensionless tcl |
|
scripts to be called via the lib: prefix." |
|
@leaders |
|
fpath -type string -optional 0 -help\ |
|
"path of the file to examine" |
|
}] |
|
} |
|
proc scriptfile_is_tcl {fpath} { |
|
if {[catch {open $fpath r} fd]} { |
|
return 0 |
|
} |
|
set chunk "" |
|
catch {chan configure $fd -encoding utf-8} |
|
catch {set chunk [read $fd 512]} |
|
catch {close $fd} |
|
if {[string index $chunk 0] eq "\uFEFF"} { |
|
#utf-8 BOM as decoded above |
|
set chunk [string range $chunk 1 end] |
|
} |
|
set lines [lmap ln [lrange [split $chunk \n] 0 3] {string trimright $ln \r}] |
|
set line1 [lindex $lines 0] |
|
if {[string index $line1 0] ne "#"} { |
|
return 0 |
|
} |
|
if {[regexp {^#!.*\m(tclsh|tclkit|wish)} $line1]} { |
|
#shebang naming a tcl interpreter e.g #!/usr/bin/env tclsh, #!/usr/bin/tclsh9.0 |
|
return 1 |
|
} |
|
if {[regexp -nocase {^#\s*tcl} $line1]} { |
|
#'# tcl' marker comment (prefix match - '# tclscript' etc also accepted) |
|
return 1 |
|
} |
|
if {[string range $line1 0 1] eq "#!"} { |
|
#any other shebang (e.g #!/bin/sh): accept the portable sh-trampoline idiom |
|
# #!/bin/sh |
|
# # \ |
|
# exec tclsh "$0" ${1+"$@"} |
|
#(the backslash-continued comment hides the exec line from tcl but not from sh) |
|
foreach ln [lrange $lines 1 end] { |
|
if {[regexp {^\s*exec\s.*\m(tclsh|tclkit|wish)} $ln]} { |
|
return 1 |
|
} |
|
} |
|
} |
|
return 0 |
|
} |
|
} |
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
#documentation-only PUNKARGS registration - discovered lazily if/when punk::args loads |
|
lappend ::punk::args::register::NAMESPACES ::punk::path::argdoc ::punk::path::system::argdoc |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::path [namespace eval punk::path { |
|
variable pkg punk::path |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|