20 changed files with 8475 additions and 249 deletions
@ -0,0 +1,24 @@
|
||||
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||
It could include other files necessary for this process. |
||||
|
||||
The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. |
||||
|
||||
The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. |
||||
The modules can be your own, or 3rd party such as individual items from tcllib. |
||||
|
||||
You can copy modules from a running punk shell to this location using the pmix command. |
||||
|
||||
e.g |
||||
>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport |
||||
|
||||
The pmix command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. |
||||
|
||||
e.g the result might be a file such as |
||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||
|
||||
The originating library may not yet be in .tm form. |
||||
You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. |
||||
|
||||
Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. |
||||
|
||||
|
||||
@ -0,0 +1,200 @@
|
||||
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||
# similar to the sum(1) command but the algorithm is better defined and |
||||
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||
# |
||||
# This command has been verified against the cksum command from the GNU |
||||
# textutils package version 2.0 |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.2; # tcl minimum version |
||||
|
||||
namespace eval ::crc { |
||||
namespace export cksum |
||||
|
||||
variable cksum_tbl [list 0x0 \ |
||||
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||
|
||||
variable uid |
||||
if {![info exists uid]} {set uid 0} |
||||
} |
||||
|
||||
# crc::CksumInit -- |
||||
# |
||||
# Create and initialize a cksum context. This is cleaned up when we |
||||
# call CksumFinal to obtain the result. |
||||
# |
||||
proc ::crc::CksumInit {} { |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
array set state {t 0 l 0} |
||||
return $token |
||||
} |
||||
|
||||
proc ::crc::CksumUpdate {token data} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
binary scan $data c* r |
||||
foreach {n} $r { |
||||
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||
# Since the introduction of built-in bigInt support with Tcl |
||||
# 8.5, bit-shifting $t to the left no longer overflows, |
||||
# keeping it 32 bits long. The value grows bigger and bigger |
||||
# instead - a severe hit on performance. For this reason we |
||||
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||
# value within limits. |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
incr state(l) |
||||
} |
||||
set state(t) $t |
||||
return |
||||
} |
||||
|
||||
proc ::crc::CksumFinal {token} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
} |
||||
unset state |
||||
return [expr {~$t & 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# crc::Pop -- |
||||
# |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::crc::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# Description: |
||||
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||
# Options: |
||||
# -filename name - return a checksum for the specified file. |
||||
# -format string - return the checksum using this format string. |
||||
# -chunksize size - set the chunking read size |
||||
# |
||||
proc ::crc::cksum {args} { |
||||
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||
-format %u -command {}] |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-chan* { set opts(-channel) [Pop args 1] } |
||||
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||
-for* { set opts(-format) [Pop args 1] } |
||||
-command { set opts(-command) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||
set err [join [lsort [array names opts -*]] ", "] |
||||
return -code error "bad option \"option\": must be $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
cksum ?-format string?\ |
||||
-channel chan | -filename file | string" |
||||
} |
||||
set tok [CksumInit] |
||||
CksumUpdate $tok [lindex $args 0] |
||||
set r [CksumFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [CksumInit] |
||||
while {![eof $opts(-channel)]} { |
||||
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||
} |
||||
set r [CksumFinal $tok] |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
return [format $opts(-format) $r] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide cksum 1.1.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,207 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Copyright (c) 2008-2009 ActiveState Software Inc., Andreas Kupries |
||||
## 2016 Andreas Kupries |
||||
## BSD License |
||||
## |
||||
# Package to help the writing of file decoders. Provides generic |
||||
# low-level support commands. |
||||
|
||||
package require Tcl 8.4 |
||||
|
||||
namespace eval ::fileutil::decode { |
||||
namespace export mark go rewind at |
||||
namespace export byte short-le long-le nbytes skip |
||||
namespace export unsigned match recode getval |
||||
namespace export clear get put putloc setbuf |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::open {fname} { |
||||
variable chan |
||||
set chan [::open $fname r] |
||||
fconfigure $chan \ |
||||
-translation binary \ |
||||
-encoding binary \ |
||||
-eofchar {} |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::close {} { |
||||
variable chan |
||||
::close $chan |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::mark {} { |
||||
variable chan |
||||
variable mark |
||||
set mark [tell $chan] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::go {to} { |
||||
variable chan |
||||
seek $chan $to start |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::rewind {} { |
||||
variable chan |
||||
variable mark |
||||
if {$mark == {}} { |
||||
return -code error \ |
||||
-errorcode {FILE DECODE NO MARK} \ |
||||
"No mark to rewind to" |
||||
} |
||||
seek $chan $mark start |
||||
set mark {} |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::at {} { |
||||
variable chan |
||||
return [tell $chan] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::byte {} { |
||||
variable chan |
||||
variable mask 0xff |
||||
variable val [read $chan 1] |
||||
binary scan $val c val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::short-le {} { |
||||
variable chan |
||||
variable mask 0xffff |
||||
variable val [read $chan 2] |
||||
binary scan $val s val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::long-le {} { |
||||
variable chan |
||||
variable mask 0xffffffff |
||||
variable val [read $chan 4] |
||||
binary scan $val i val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::nbytes {n} { |
||||
variable chan |
||||
variable mask {} |
||||
variable val [read $chan $n] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::skip {n} { |
||||
variable chan |
||||
#read $chan $n |
||||
seek $chan $n current |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::unsigned {} { |
||||
variable val |
||||
if {$val >= 0} return |
||||
variable mask |
||||
if {$mask eq {}} { |
||||
return -code error \ |
||||
-errorcode {FILE DECODE ILLEGAL UNSIGNED} \ |
||||
"Unsigned not possible here" |
||||
} |
||||
set val [format %u [expr {$val & $mask}]] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::match {eval} { |
||||
variable val |
||||
|
||||
#puts "Match: Expected $eval, Got: [format 0x%08x $val]" |
||||
|
||||
if {$val == $eval} {return 1} |
||||
rewind |
||||
return 0 |
||||
} |
||||
|
||||
proc ::fileutil::decode::recode {cmdpfx} { |
||||
variable val |
||||
lappend cmdpfx $val |
||||
set val [uplevel 1 $cmdpfx] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::getval {} { |
||||
variable val |
||||
return $val |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::clear {} { |
||||
variable buf {} |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::get {} { |
||||
variable buf |
||||
return $buf |
||||
} |
||||
|
||||
proc ::fileutil::decode::setbuf {list} { |
||||
variable buf $list |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::put {name} { |
||||
variable buf |
||||
variable val |
||||
lappend buf $name $val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::putloc {name} { |
||||
variable buf |
||||
variable chan |
||||
lappend buf $name [tell $chan] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
namespace eval ::fileutil::decode { |
||||
# Stream to read from |
||||
variable chan {} |
||||
|
||||
# Last value read from the stream, or modified through decoder |
||||
# operations. |
||||
variable val {} |
||||
|
||||
# Remembered location in the stream |
||||
variable mark {} |
||||
|
||||
# Buffer for accumulating structured results |
||||
variable buf {} |
||||
|
||||
# Mask for trimming a value to unsigned. |
||||
# Size-dependent |
||||
variable mask {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
package provide fileutil::decode 0.2.1 |
||||
return |
||||
@ -0,0 +1,28 @@
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# (c) 2007 Andreas Kupries. |
||||
|
||||
# Multi file operations. Singleton based on the multiop processor. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require fileutil::multi::op |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API & Implementation |
||||
|
||||
namespace eval ::fileutil {} |
||||
|
||||
# Create the multiop processor object and make its do method the main |
||||
# command of this package. |
||||
::fileutil::multi::op ::fileutil::multi::obj |
||||
|
||||
proc ::fileutil::multi {args} { |
||||
return [uplevel 1 [linsert $args 0 ::fileutil::multi::obj do]] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::multi 0.1 |
||||
@ -0,0 +1,645 @@
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# (c) 2007-2008 Andreas Kupries. |
||||
|
||||
# DSL allowing the easy specification of multi-file copy and/or move |
||||
# and/or deletion operations. Alternate names would be scatter/gather |
||||
# processor, or maybe even assembler. |
||||
|
||||
# Examples: |
||||
# (1) copy |
||||
# into [installdir_of tls] |
||||
# from c:/TDK/PrivateOpenSSL/bin |
||||
# the *.dll |
||||
# |
||||
# (2) move |
||||
# from /sources |
||||
# into /scratch |
||||
# the * |
||||
# but not *.html |
||||
# (Alternatively: except for *.html) |
||||
# |
||||
# (3) into /scratch |
||||
# from /sources |
||||
# move |
||||
# as pkgIndex.tcl |
||||
# the index |
||||
# |
||||
# (4) in /scratch |
||||
# remove |
||||
# the *.txt |
||||
|
||||
# The language is derived from the parts of TclApp's option language |
||||
# dealing with files and their locations, yet not identical. In parts |
||||
# simplified, in parts more capable, keyword names were changed |
||||
# throughout. |
||||
|
||||
# Language commands |
||||
|
||||
# From the examples |
||||
# |
||||
# into DIR : Specify destination directory. |
||||
# in DIR : See 'into'. |
||||
# from DIR : Specify source directory. |
||||
# the PATTERN (...) : Specify files to operate on. |
||||
# but not PATTERN : Specify exceptions to 'the'. |
||||
# but exclude PATTERN : Specify exceptions to 'the'. |
||||
# except for PATTERN : See 'but not'. |
||||
# as NAME : New name for file. |
||||
# move : Move files. |
||||
# copy : Copy files. |
||||
# remove : Delete files. |
||||
# |
||||
# Furthermore |
||||
# |
||||
# reset : Force to defaults. |
||||
# cd DIR : Change destination to subdirectory. |
||||
# up : Change destination to parent directory. |
||||
# ( : Save a copy of the current state. |
||||
# ) : Restore last saved state and make it current. |
||||
|
||||
# The main active element is the command 'the'. In other words, this |
||||
# command not only specifies the files to operate on, but also |
||||
# executes the operation as defined in the current state. All other |
||||
# commands modify the state to set the operation up, and nothing |
||||
# else. To allow for a more natural syntax the active command also |
||||
# looks ahead for the commands 'as', 'but', and 'except', and executes |
||||
# them, like qualifiers, so that they take effect as if they had been |
||||
# written before. The command 'but' and 'except use identical |
||||
# constructions to handle their qualifiers, i.e. 'not' and 'for'. |
||||
|
||||
# Note that the fact that most commands just modify the state allows |
||||
# us to use more off forms as specifications instead of just natural |
||||
# language sentences For example the example 2 can re-arranged into: |
||||
# |
||||
# (5) from /sources |
||||
# into /scratch |
||||
# but not *.html |
||||
# move |
||||
# the * |
||||
# |
||||
# and the result is still a valid specification. |
||||
|
||||
# Further note that the information collected by 'but', 'except', and |
||||
# 'as' is automatically reset after the associated 'the' was |
||||
# executed. However no other state is reset in that manner, allowing |
||||
# the user to avoid repetitions of unchanging information. Lets us for |
||||
# example merge the examples 2 and 3. The trivial merge is: |
||||
|
||||
# (6) move |
||||
# into /scratch |
||||
# from /sources |
||||
# the * |
||||
# but not *.html not index |
||||
# move |
||||
# into /scratch |
||||
# from /sources |
||||
# the index |
||||
# as pkgIndex.tcl |
||||
# |
||||
# With less repetitions |
||||
# |
||||
# (7) move |
||||
# into /scratch |
||||
# from /sources |
||||
# the * |
||||
# but not *.html not index |
||||
# the index |
||||
# as pkgIndex.tcl |
||||
|
||||
# I have not yet managed to find a suitable syntax to specify when to |
||||
# add a new extension to the moved/copied files, or have to strip all |
||||
# extensions, a specific extension, or even replace extensions. |
||||
|
||||
# Other possibilities to muse about: Load the patterns for 'not'/'for' |
||||
# from a file ... Actually, load the whole exceptions from a file, |
||||
# with its contents a proper interpretable word list. Which makes it |
||||
# general processing of include files. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
# This processor uses the 'wip' word list interpreter as its |
||||
# foundation. |
||||
|
||||
package require fileutil ; # File testing |
||||
package require snit ; # OO support |
||||
package require struct::stack ; # Context stack |
||||
package require wip ; # DSL execution core |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API & Implementation |
||||
|
||||
snit::type ::fileutil::multi::op { |
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
constructor {args} {} ; # create processor |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API - Implementation. |
||||
|
||||
constructor {args} { |
||||
install stack using struct::stack ${selfns}::stack |
||||
$self wip_setup |
||||
|
||||
# Mapping dsl commands to methods. |
||||
defdva \ |
||||
reset Reset ( Push ) Pop \ |
||||
into Into in Into from From \ |
||||
cd ChDir up ChUp as As \ |
||||
move Move copy Copy remove Remove \ |
||||
but But not Exclude the The \ |
||||
except Except for Exclude exclude Exclude \ |
||||
to Into -> Save the-set TheSet \ |
||||
recursive Recursive recursively Recursive \ |
||||
for-win ForWindows for-unix ForUnix \ |
||||
for-windows ForWindows expand Expand \ |
||||
invoke Invoke strict Strict !strict NotStrict \ |
||||
files Files links Links all Everything \ |
||||
dirs Directories directories Directories \ |
||||
state? QueryState from? QueryFrom into? QueryInto \ |
||||
excluded? QueryExcluded as? QueryAs type? QueryType \ |
||||
recursive? QueryRecursive operation? QueryOperation \ |
||||
strict? QueryStrict !recursive NotRecursive |
||||
|
||||
$self Reset |
||||
runl $args |
||||
return |
||||
} |
||||
|
||||
destructor { |
||||
$mywip destroy |
||||
return |
||||
} |
||||
|
||||
method do {args} { |
||||
return [runl $args] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## DSL Implementation |
||||
wip::dsl |
||||
|
||||
# General reset of processor state |
||||
method Reset {} { |
||||
$stack clear |
||||
set base "" |
||||
set alias "" |
||||
set op "" |
||||
set recursive 0 |
||||
set src "" |
||||
set excl "" |
||||
set types {} |
||||
set strict 0 |
||||
return |
||||
} |
||||
|
||||
# Stack manipulation |
||||
method Push {} { |
||||
$stack push [list $base $alias $op $opcmd $recursive $src $excl $types $strict] |
||||
return |
||||
} |
||||
|
||||
method Pop {} { |
||||
if {![$stack size]} { |
||||
return -code error {Stack underflow} |
||||
} |
||||
foreach {base alias op opcmd recursive src excl types strict} [$stack pop] break |
||||
return |
||||
} |
||||
|
||||
# Destination directory |
||||
method Into {dir} { |
||||
if {$dir eq ""} {set dir [pwd]} |
||||
if {$strict && ![fileutil::test $dir edr msg {Destination directory}]} { |
||||
return -code error $msg |
||||
} |
||||
set base $dir |
||||
return |
||||
} |
||||
|
||||
method ChDir {dir} { $self Into [file join $base $dir] ; return } |
||||
method ChUp {} { $self Into [file dirname $base] ; return } |
||||
|
||||
# Detail |
||||
method As {fname} { |
||||
set alias [ForceRelative $fname] |
||||
return |
||||
} |
||||
|
||||
# Operations |
||||
method Move {} { set op move ; return } |
||||
method Copy {} { set op copy ; return } |
||||
method Remove {} { set op remove ; return } |
||||
method Expand {} { set op expand ; return } |
||||
|
||||
method Invoke {cmdprefix} { |
||||
set op invoke |
||||
set opcmd $cmdprefix |
||||
return |
||||
} |
||||
|
||||
# Operation qualifier |
||||
method Recursive {} { set recursive 1 ; return } |
||||
method NotRecursive {} { set recursive 0 ; return } |
||||
|
||||
# Source directory |
||||
method From {dir} { |
||||
if {$dir eq ""} {set dir [pwd]} |
||||
if {![fileutil::test $dir edr msg {Source directory}]} { |
||||
return -code error $msg |
||||
} |
||||
set src $dir |
||||
return |
||||
} |
||||
|
||||
# Exceptions |
||||
method But {} { run_next_while {not exclude} ; return } |
||||
method Except {} { run_next_while {for} ; return } |
||||
|
||||
method Exclude {pattern} { |
||||
lappend excl $pattern |
||||
return |
||||
} |
||||
|
||||
# Define the files to operate on, and perform the operation. |
||||
method The {pattern} { |
||||
run_next_while {as but except exclude from into in to files dirs directories links all} |
||||
|
||||
switch -exact -- $op { |
||||
invoke {Invoke [Resolve [Remember [Exclude [Expand $src $pattern]]]]} |
||||
move {Move [Resolve [Remember [Exclude [Expand $src $pattern]]]]} |
||||
copy {Copy [Resolve [Remember [Exclude [Expand $src $pattern]]]]} |
||||
remove {Remove [Remember [Exclude [Expand $base $pattern]]] } |
||||
expand { Remember [Exclude [Expand $base $pattern]] } |
||||
} |
||||
|
||||
# Reset the per-pattern flags of the resolution context back |
||||
# to their defaults, for the next pattern. |
||||
|
||||
set alias {} |
||||
set excl {} |
||||
set recursive 0 |
||||
return |
||||
} |
||||
|
||||
# Like 'The' above, except that the fileset is taken from the |
||||
# specified variable. Semi-complementary to 'Save' below. |
||||
# Exclusion data and recursion info do not apply for this, this is |
||||
# already implicitly covered by the set, when it was generated. |
||||
|
||||
method TheSet {varname} { |
||||
# See 'Save' for the levels we jump here. |
||||
upvar 5 $varname var |
||||
|
||||
run_next_while {as from into in to} |
||||
|
||||
switch -exact -- $op { |
||||
invoke {Invoke [Resolve $var]} |
||||
move {Move [Resolve $var]} |
||||
copy {Copy [Resolve $var]} |
||||
remove {Remove $var } |
||||
expand { |
||||
return -code error "Expansion does not make sense\ |
||||
when we already have a set of files." |
||||
} |
||||
} |
||||
|
||||
# Reset the per-pattern flags of the resolution context back |
||||
# to their defaults, for the next pattern. |
||||
|
||||
set alias {} |
||||
return |
||||
} |
||||
|
||||
# Save the last expansion result to a variable for use by future commands. |
||||
|
||||
method Save {varname} { |
||||
# Levels to jump. Brittle. |
||||
# 5: Caller |
||||
# 4: object do ... |
||||
# 3: runl |
||||
# 2: wip::runl |
||||
# 1: run_next |
||||
# 0: Here |
||||
upvar 5 $varname v |
||||
set v $lastexpansion |
||||
return |
||||
} |
||||
|
||||
# Platform conditionals ... |
||||
|
||||
method ForUnix {} { |
||||
global tcl_platform |
||||
if {$tcl_platform(platform) eq "unix"} return |
||||
# Kill the remaining code. This effectively aborts processing. |
||||
replacel {} |
||||
return |
||||
} |
||||
|
||||
method ForWindows {} { |
||||
global tcl_platform |
||||
if {$tcl_platform(platform) eq "windows"} return |
||||
# Kill the remaining code. This effectively aborts processing. |
||||
replacel {} |
||||
return |
||||
} |
||||
|
||||
# Strictness |
||||
|
||||
method Strict {} { |
||||
set strict 1 |
||||
return |
||||
} |
||||
|
||||
method NotStrict {} { |
||||
set strict 0 |
||||
return |
||||
} |
||||
|
||||
# Type qualifiers |
||||
|
||||
method Files {} { |
||||
set types files |
||||
return |
||||
} |
||||
|
||||
method Links {} { |
||||
set types links |
||||
return |
||||
} |
||||
|
||||
method Directories {} { |
||||
set types dirs |
||||
return |
||||
} |
||||
|
||||
method Everything {} { |
||||
set types {} |
||||
return |
||||
} |
||||
|
||||
# State interogation |
||||
|
||||
method QueryState {} { |
||||
return [list \ |
||||
from $src \ |
||||
into $base \ |
||||
as $alias \ |
||||
op $op \ |
||||
excluded $excl \ |
||||
recursive $recursive \ |
||||
type $types \ |
||||
strict $strict \ |
||||
] |
||||
} |
||||
method QueryExcluded {} { |
||||
return $excl |
||||
} |
||||
method QueryFrom {} { |
||||
return $src |
||||
} |
||||
method QueryInto {} { |
||||
return $base |
||||
} |
||||
method QueryAs {} { |
||||
return $alias |
||||
} |
||||
method QueryOperation {} { |
||||
return $op |
||||
} |
||||
method QueryRecursive {} { |
||||
return $recursive |
||||
} |
||||
method QueryType {} { |
||||
return $types |
||||
} |
||||
method QueryStrict {} { |
||||
return $strict |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## DSL State |
||||
|
||||
component stack ; # State stack - ( ) |
||||
variable base "" ; # Destination dir - into, in, cd, up |
||||
variable alias "" ; # Detail - as |
||||
variable op "" ; # Operation - move, copy, remove, expand, invoke |
||||
variable opcmd "" ; # Command prefix for invoke. |
||||
variable recursive 0 ; # Op. qualifier: recursive expansion? |
||||
variable src "" ; # Source dir - from |
||||
variable excl "" ; # Excluded files - but not|exclude, except for |
||||
# incl ; # Included files - the (immediate use) |
||||
variable types {} ; # Limit glob/find to specific types (f, l, d). |
||||
variable strict 0 ; # Strictness of into/Expand |
||||
|
||||
variable lastexpansion "" ; # Area for last expansion result, for 'Save' to take from. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal -- Path manipulation helpers. |
||||
|
||||
proc ForceRelative {path} { |
||||
set pathtype [file pathtype $path] |
||||
switch -exact -- $pathtype { |
||||
relative { |
||||
return $path |
||||
} |
||||
absolute { |
||||
# Chop off the first element in the path, which is the |
||||
# root, either '/' or 'x:/'. If this was the only |
||||
# element assume an empty path. |
||||
|
||||
set path [lrange [file split $path] 1 end] |
||||
if {![llength $path]} {return {}} |
||||
return [eval [linsert $path 0 file join]] |
||||
} |
||||
volumerelative { |
||||
return -code error {Unable to handle volumerelative path, yet} |
||||
} |
||||
} |
||||
|
||||
return -code error \ |
||||
"file pathtype returned unknown type \"$pathtype\"" |
||||
} |
||||
|
||||
proc ForceAbsolute {path} { |
||||
return [file join [pwd] $path] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal - Operation execution helpers |
||||
|
||||
proc Invoke {files} { |
||||
upvar 1 base base src src opcmd opcmd |
||||
uplevel #0 [linsert $opcmd end $src $base $files] |
||||
return |
||||
} |
||||
|
||||
proc Move {files} { |
||||
upvar 1 base base src src |
||||
|
||||
foreach {s d} $files { |
||||
set s [file join $src $s] |
||||
set d [file join $base $d] |
||||
|
||||
file mkdir [file dirname $d] |
||||
file rename -force $s $d |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc Copy {files} { |
||||
upvar 1 base base src src |
||||
|
||||
foreach {s d} $files { |
||||
set s [file join $src $s] |
||||
set d [file join $base $d] |
||||
|
||||
file mkdir [file dirname $d] |
||||
if { |
||||
[file isdirectory $s] && |
||||
[file exists $d] && |
||||
[file isdirectory $d] |
||||
} { |
||||
# Special case: source and destination are |
||||
# directories, and the latter exists. This puts the |
||||
# source under the destination, and may even prevent |
||||
# copying at all. The semantics of the operation is |
||||
# that the source is the destination. We avoid the |
||||
# trouble by copying the contents of the source, |
||||
# instead of the directory itself. |
||||
foreach path [glob -directory $s *] { |
||||
file copy -force $path $d |
||||
} |
||||
} else { |
||||
file copy -force $s $d |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc Remove {files} { |
||||
upvar 1 base base |
||||
|
||||
foreach f $files { |
||||
file delete -force [file join $base $f] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal -- Resolution helper commands |
||||
|
||||
typevariable tmap -array { |
||||
files {f TFile} |
||||
links {l TLink} |
||||
dirs {d TDir} |
||||
{} {{} {}} |
||||
} |
||||
|
||||
proc Expand {dir pattern} { |
||||
upvar 1 recursive recursive strict strict types types tmap tmap |
||||
# FUTURE: struct::list filter ... |
||||
|
||||
set files {} |
||||
if {$recursive} { |
||||
# Recursion through the entire directory hierarchy, save |
||||
# all matching paths. |
||||
|
||||
set filter [lindex $tmap($types) 1] |
||||
if {$filter ne ""} { |
||||
set filter [myproc $filter] |
||||
} |
||||
|
||||
foreach f [fileutil::find $dir $filter] { |
||||
if {![string match $pattern [file tail $f]]} continue |
||||
lappend files [fileutil::stripPath $dir $f] |
||||
} |
||||
} else { |
||||
# No recursion, just scan the whole directory for matching paths. |
||||
# check for specific types integrated. |
||||
|
||||
set filter [lindex $tmap($types) 0] |
||||
if {$filter ne ""} { |
||||
foreach f [glob -nocomplain -directory $dir -types $filter -- $pattern] { |
||||
lappend files [fileutil::stripPath $dir $f] |
||||
} |
||||
} else { |
||||
foreach f [glob -nocomplain -directory $dir -- $pattern] { |
||||
lappend files [fileutil::stripPath $dir $f] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[llength $files]} {return $files} |
||||
if {!$strict} {return {}} |
||||
|
||||
return -code error \ |
||||
"No files matching pattern \"$pattern\" in directory \"$dir\"" |
||||
} |
||||
|
||||
proc TFile {f} {file isfile $f} |
||||
proc TDir {f} {file isdirectory $f} |
||||
proc TLink {f} {expr {[file type $f] eq "link"}} |
||||
|
||||
proc Exclude {files} { |
||||
upvar 1 excl excl |
||||
|
||||
# FUTURE: struct::list filter ... |
||||
set res {} |
||||
foreach f $files { |
||||
if {[IsExcluded $f $excl]} continue |
||||
lappend res $f |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc IsExcluded {f patterns} { |
||||
foreach p $patterns { |
||||
if {[string match $p $f]} {return 1} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
proc Resolve {files} { |
||||
upvar 1 alias alias |
||||
set res {} |
||||
foreach f $files { |
||||
|
||||
# Remember alias for processing and auto-invalidate to |
||||
# prevent contamination of the next file. |
||||
|
||||
set thealias $alias |
||||
set alias "" |
||||
|
||||
if {$thealias eq ""} { |
||||
set d $f |
||||
} else { |
||||
set d [file dirname $f] |
||||
if {$d eq "."} { |
||||
set d $thealias |
||||
} else { |
||||
set d [file join $d $thealias] |
||||
} |
||||
} |
||||
|
||||
lappend res $f $d |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc Remember {files} { |
||||
upvar 1 lastexpansion lastexpansion |
||||
set lastexpansion $files |
||||
return $files |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::multi::op 0.5.3 |
||||
@ -0,0 +1,74 @@
|
||||
# paths.tcl -- |
||||
# |
||||
# Manage lists of search paths. |
||||
# |
||||
# Copyright (c) 2009-2019 Andreas Kupries <andreas_kupries@sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
# Each object instance manages a list of paths. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.4 |
||||
package require snit |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
snit::type ::fileutil::paths { |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Options :: None |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Creation, destruction |
||||
|
||||
# Default constructor. |
||||
# Default destructor. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Methods :: Querying and manipulating the list of paths. |
||||
|
||||
method paths {} { |
||||
return $mypaths |
||||
} |
||||
|
||||
method add {path} { |
||||
set pos [lsearch $mypaths $path] |
||||
if {$pos >= 0 } return |
||||
lappend mypaths $path |
||||
return |
||||
} |
||||
|
||||
method remove {path} { |
||||
set pos [lsearch $mypaths $path] |
||||
if {$pos < 0} return |
||||
set mypaths [lreplace $mypaths $pos $pos] |
||||
return |
||||
} |
||||
|
||||
method clear {} { |
||||
set mypaths {} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal methods :: None |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State :: List of paths. |
||||
|
||||
variable mypaths {} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::paths 1 |
||||
return |
||||
@ -0,0 +1,504 @@
|
||||
# traverse.tcl -- |
||||
# |
||||
# Directory traversal. |
||||
# |
||||
# Copyright (c) 2006-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.3 |
||||
|
||||
# OO core |
||||
if {[package vsatisfies [package present Tcl] 8.5]} { |
||||
# Use new Tcl 8.5a6+ features to specify the allowed packages. |
||||
# We can use anything above 1.3. This means v2 as well. |
||||
package require snit 1.3- |
||||
} else { |
||||
# For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible. |
||||
package require snit 1.3 |
||||
} |
||||
package require control ; # Helpers for control structures |
||||
package require fileutil ; # -> fullnormalize |
||||
|
||||
snit::type ::fileutil::traverse { |
||||
|
||||
# Incremental directory traversal. |
||||
|
||||
# API |
||||
# create %AUTO% basedirectory options... -> object |
||||
# next filevar -> boolean |
||||
# foreach filevar script |
||||
# files -> list (path ...) |
||||
|
||||
# Options |
||||
# -prefilter command-prefix |
||||
# -filter command-prefix |
||||
# -errorcmd command-prefix |
||||
|
||||
# Use cases |
||||
# |
||||
# (a) Basic incremental |
||||
# - Create and configure a traversal object. |
||||
# - Execute 'next' to retrieve one path at a time, |
||||
# until the command returns False, signaling that |
||||
# the iterator has exhausted the supply of paths. |
||||
# (The path is stored in the named variable). |
||||
# |
||||
# The execution of 'next' can be done in a loop, or via event |
||||
# processing. |
||||
|
||||
# (b) Basic loop |
||||
# - Create and configure a traversal object. |
||||
# - Run a script for each path, using 'foreach'. |
||||
# This is a convenient standard wrapper around 'next'. |
||||
# |
||||
# The loop properly handles all possible Tcl result codes. |
||||
|
||||
# (c) Non-incremental, non-looping. |
||||
# - Create and configure a traversal object. |
||||
# - Retrieve a list of all paths via 'files'. |
||||
|
||||
# The -prefilter callback is executed for directories. Its result |
||||
# determines if the traverser recurses into the directory or not. |
||||
# The default is to always recurse into all directories. The call- |
||||
# back is invoked with a single argument, the path of the |
||||
# directory. |
||||
# |
||||
# The -filter callback is executed for all paths. Its result |
||||
# determines if the current path is a valid result, and returned |
||||
# by 'next'. The default is to accept all paths as valid. The |
||||
# callback is invoked with a single argument, the path to check. |
||||
|
||||
# The -errorcmd callback is executed for all paths the traverser |
||||
# has trouble with. Like being unable to cd into them, get their |
||||
# status, etc. The default is to ignore any such problems. The |
||||
# callback is invoked with a two arguments, the path for which the |
||||
# error occured, and the error message. Errors thrown by the |
||||
# filter callbacks are handled through this callback too. Errors |
||||
# thrown by the error callback itself are not caught and ignored, |
||||
# but allowed to pass to the caller, usually of 'next'. |
||||
|
||||
# Note: Low-level functionality, version and platform dependent is |
||||
# implemented in procedures, and conditioally defined for optimal |
||||
# use of features, etc. ... |
||||
|
||||
# Note: Traversal is done in depth-first pre-order. |
||||
|
||||
# Note: The options are handled only during |
||||
# construction. Afterward they are read-only and attempts to |
||||
# modify them will cause the system to throw errors. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Implementation |
||||
|
||||
option -filter -default {} -readonly 1 |
||||
option -prefilter -default {} -readonly 1 |
||||
option -errorcmd -default {} -readonly 1 |
||||
|
||||
constructor {basedir args} { |
||||
set _base $basedir |
||||
$self configurelist $args |
||||
return |
||||
} |
||||
|
||||
method files {} { |
||||
set files {} |
||||
$self foreach f {lappend files $f} |
||||
return $files |
||||
} |
||||
|
||||
method foreach {fvar body} { |
||||
upvar 1 $fvar currentfile |
||||
|
||||
# (Re-)initialize the traversal state on every call. |
||||
$self Init |
||||
|
||||
while {[$self next currentfile]} { |
||||
set code [catch {uplevel 1 $body} result] |
||||
|
||||
# decide what to do upon the return code: |
||||
# |
||||
# 0 - the body executed successfully |
||||
# 1 - the body raised an error |
||||
# 2 - the body invoked [return] |
||||
# 3 - the body invoked [break] |
||||
# 4 - the body invoked [continue] |
||||
# everything else - return and pass on the results |
||||
# |
||||
switch -exact -- $code { |
||||
0 {} |
||||
1 { |
||||
return -errorinfo [::control::ErrorInfoAsCaller uplevel foreach] \ |
||||
-errorcode $::errorCode -code error $result |
||||
} |
||||
3 { |
||||
# FRINK: nocheck |
||||
return |
||||
} |
||||
4 {} |
||||
default { |
||||
return -code $code $result |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
method next {fvar} { |
||||
upvar 1 $fvar currentfile |
||||
|
||||
# Initialize on first call. |
||||
if {!$_init} { |
||||
$self Init |
||||
} |
||||
|
||||
# We (still) have valid paths in the result stack, return the |
||||
# next one. |
||||
|
||||
if {[llength $_results]} { |
||||
set top [lindex $_results end] |
||||
set _results [lreplace $_results end end] |
||||
set currentfile $top |
||||
return 1 |
||||
} |
||||
|
||||
# Take the next directory waiting in the processing stack and |
||||
# fill the result stack with all valid files and sub- |
||||
# directories contained in it. Extend the processing queue |
||||
# with all sub-directories not yet seen already (!circular |
||||
# symlinks) and accepted by the prefilter. We stop iterating |
||||
# when we either have no directories to process anymore, or |
||||
# the result stack contains at least one path we can return. |
||||
|
||||
while {[llength $_pending]} { |
||||
set top [lindex $_pending end] |
||||
set _pending [lreplace $_pending end end] |
||||
|
||||
# Directory accessible? Skip if not. |
||||
if {![ACCESS $top]} { |
||||
Error $top "Inacessible directory" |
||||
continue |
||||
} |
||||
|
||||
# Expand the result stack with all files in the directory, |
||||
# modulo filtering. |
||||
|
||||
foreach f [GLOBF $top] { |
||||
if {![Valid $f]} continue |
||||
lappend _results $f |
||||
} |
||||
|
||||
# Expand the result stack with all sub-directories in the |
||||
# directory, modulo filtering. Further expand the |
||||
# processing stack with the same directories, if not seen |
||||
# yet and modulo pre-filtering. |
||||
|
||||
foreach f [GLOBD $top] { |
||||
if { |
||||
[string equal [file tail $f] "."] || |
||||
[string equal [file tail $f] ".."] |
||||
} continue |
||||
|
||||
if {[Valid $f]} { |
||||
lappend _results $f |
||||
} |
||||
|
||||
Enter $top $f |
||||
if {[Cycle $f]} continue |
||||
|
||||
if {[Recurse $f]} { |
||||
lappend _pending $f |
||||
} |
||||
} |
||||
|
||||
# Stop expanding if we have paths to return. |
||||
|
||||
if {[llength $_results]} { |
||||
set top [lindex $_results end] |
||||
set _results [lreplace $_results end end] |
||||
set currentfile $top |
||||
return 1 |
||||
} |
||||
} |
||||
|
||||
# Allow re-initialization with next call. |
||||
|
||||
set _init 0 |
||||
return 0 |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Traversal state |
||||
|
||||
# * Initialization flag. Checked in 'next', reset by next when no |
||||
# more files are available. Set in 'Init'. |
||||
# * Base directory (or file) to start the traversal from. |
||||
# * Stack of prefiltered unknown directories waiting for |
||||
# processing, i.e. expansion (TOP at end). |
||||
# * Stack of valid paths waiting to be returned as results. |
||||
# * Set of directories already visited (normalized paths), for |
||||
# detection of circular symbolic links. |
||||
|
||||
variable _init 0 ; # Initialization flag. |
||||
variable _base {} ; # Base directory. |
||||
variable _pending {} ; # Processing stack. |
||||
variable _results {} ; # Result stack. |
||||
|
||||
# sym link handling (to break cycles, while allowing the following of non-cycle links). |
||||
# Notes |
||||
# - path parent tracking is lexical. |
||||
# - path identity tracking is based on the normalized path, i.e. the path with all |
||||
# symlinks resolved. |
||||
# Maps |
||||
# - path -> parent (easier to follow the list than doing dirname's) |
||||
# - path -> normalized (cache to avoid redundant calls of fullnormalize) |
||||
# cycle <=> A parent's normalized form (NF) is identical to the current path's NF |
||||
|
||||
variable _parent -array {} |
||||
variable _norm -array {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal helpers. |
||||
|
||||
proc Enter {parent path} { |
||||
#puts ___E|$path |
||||
upvar 1 _parent _parent _norm _norm |
||||
set _parent($path) $parent |
||||
set _norm($path) [fileutil::fullnormalize $path] |
||||
} |
||||
|
||||
proc Cycle {path} { |
||||
upvar 1 _parent _parent _norm _norm |
||||
set nform $_norm($path) |
||||
set paren $_parent($path) |
||||
while {$paren ne {}} { |
||||
if {$_norm($paren) eq $nform} { return yes } |
||||
set paren $_parent($paren) |
||||
} |
||||
return no |
||||
} |
||||
|
||||
method Init {} { |
||||
array unset _parent * |
||||
array unset _norm * |
||||
|
||||
# Path ok as result? |
||||
if {[Valid $_base]} { |
||||
lappend _results $_base |
||||
} |
||||
|
||||
# Expansion allowed by prefilter? |
||||
if {[file isdirectory $_base] && [Recurse $_base]} { |
||||
Enter {} $_base |
||||
lappend _pending $_base |
||||
} |
||||
|
||||
# System is set up now. |
||||
set _init 1 |
||||
return |
||||
} |
||||
|
||||
proc Valid {path} { |
||||
#puts ___V|$path |
||||
upvar 1 options options |
||||
if {![llength $options(-filter)]} {return 1} |
||||
set path [file normalize $path] |
||||
set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid] |
||||
if {!$code} {return $valid} |
||||
Error $path $valid |
||||
return 0 |
||||
} |
||||
|
||||
proc Recurse {path} { |
||||
#puts ___X|$path |
||||
upvar 1 options options _norm _norm |
||||
if {![llength $options(-prefilter)]} {return 1} |
||||
set path [file normalize $path] |
||||
set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid] |
||||
if {!$code} {return $valid} |
||||
Error $path $valid |
||||
return 0 |
||||
} |
||||
|
||||
proc Error {path msg} { |
||||
upvar 1 options options |
||||
if {![llength $options(-errorcmd)]} return |
||||
set path [file normalize $path] |
||||
uplevel \#0 [linsert $options(-errorcmd) end $path $msg] |
||||
return |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# The next three helper commands for the traverser depend strongly on |
||||
# the version of Tcl, and partially on the platform. |
||||
|
||||
# 1. In Tcl 8.3 using -types f will return only true files, but not |
||||
# links to files. This changed in 8.4+ where links to files are |
||||
# returned as well. So for 8.3 we have to handle the links |
||||
# separately (-types l) and also filter on our own. |
||||
# Note that Windows file links are hard links which are reported by |
||||
# -types f, but not -types l, so we can optimize that for the two |
||||
# platforms. |
||||
# |
||||
# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on |
||||
# a known file") when trying to perform 'glob -types {hidden f}' on |
||||
# a directory without e'x'ecute permissions. We code around by |
||||
# testing if we can cd into the directory (stat might return enough |
||||
# information too (mode), but possibly also not portable). |
||||
# |
||||
# For Tcl 8.2 and 8.4+ glob simply delivers an empty result |
||||
# (-nocomplain), without crashing. For them this command is defined |
||||
# so that the bytecode compiler removes it from the bytecode. |
||||
# |
||||
# This bug made the ACCESS helper necessary. |
||||
# We code around the problem by testing if we can cd into the |
||||
# directory (stat might return enough information too (mode), but |
||||
# possibly also not portable). |
||||
|
||||
if {[package vsatisfies [package present Tcl] 8.5]} { |
||||
# Tcl 8.5+. |
||||
# We have to check readability of "current" on our own, glob |
||||
# changed to error out instead of returning nothing. |
||||
|
||||
proc ::fileutil::traverse::ACCESS {args} {return 1} |
||||
|
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
if {![file readable $current] || |
||||
[BadLink $current]} { |
||||
return {} |
||||
} |
||||
|
||||
set res [lsort -unique [concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]]] |
||||
|
||||
# Look for broken links (They are reported as neither file nor directory). |
||||
foreach l [lsort -unique [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *]]] { |
||||
if {[file isfile $l]} continue |
||||
if {[file isdirectory $l]} continue |
||||
lappend res $l |
||||
} |
||||
return [lsort -unique $res] |
||||
} |
||||
|
||||
proc ::fileutil::traverse::GLOBD {current} { |
||||
if {![file readable $current] || |
||||
[BadLink $current]} { |
||||
return {} |
||||
} |
||||
|
||||
lsort -unique [concat \ |
||||
[glob -nocomplain -directory $current -types d -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden d} -- *]] |
||||
} |
||||
|
||||
proc ::fileutil::traverse::BadLink {current} { |
||||
if {[file type $current] ne "link"} { return no } |
||||
|
||||
set dst [file join [file dirname $current] [file readlink $current]] |
||||
|
||||
if {![file exists $dst] || |
||||
![file readable $dst]} { |
||||
return yes |
||||
} |
||||
|
||||
return no |
||||
} |
||||
|
||||
} elseif {[package vsatisfies [package present Tcl] 8.4]} { |
||||
# Tcl 8.4+. |
||||
# (Ad 1) We have -directory, and -types, |
||||
# (Ad 2) Links are returned for -types f/d if they refer to files/dirs. |
||||
# (Ad 3) No bug to code around |
||||
|
||||
proc ::fileutil::traverse::ACCESS {args} {return 1} |
||||
|
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
set res [concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||
|
||||
# Look for broken links (They are reported as neither file nor directory). |
||||
foreach l [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *] ] { |
||||
if {[file isfile $l]} continue |
||||
if {[file isdirectory $l]} continue |
||||
lappend res $l |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::fileutil::traverse::GLOBD {current} { |
||||
concat \ |
||||
[glob -nocomplain -directory $current -types d -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden d} -- *] |
||||
} |
||||
|
||||
} else { |
||||
# 8.3. |
||||
# (Ad 1) We have -directory, and -types, |
||||
# (Ad 2) Links are NOT returned for -types f/d, collect separately. |
||||
# No symbolic file links on Windows. |
||||
# (Ad 3) Bug to code around. |
||||
|
||||
proc ::fileutil::traverse::ACCESS {current} { |
||||
if {[catch { |
||||
set h [pwd] ; cd $current ; cd $h |
||||
}]} {return 0} |
||||
return 1 |
||||
} |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||
} |
||||
} else { |
||||
proc ::fileutil::traverse::GLOBF {current} { |
||||
set l [concat \ |
||||
[glob -nocomplain -directory $current -types f -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden f} -- *]] |
||||
|
||||
foreach x [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *]] { |
||||
if {[file isdirectory $x]} continue |
||||
# We have now accepted files, links to files, and broken links. |
||||
lappend l $x |
||||
} |
||||
|
||||
return $l |
||||
} |
||||
} |
||||
|
||||
proc ::fileutil::traverse::GLOBD {current} { |
||||
set l [concat \ |
||||
[glob -nocomplain -directory $current -types d -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden d} -- *]] |
||||
|
||||
foreach x [concat \ |
||||
[glob -nocomplain -directory $current -types l -- *] \ |
||||
[glob -nocomplain -directory $current -types {hidden l} -- *]] { |
||||
if {![file isdirectory $x]} continue |
||||
lappend l $x |
||||
} |
||||
|
||||
return $l |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::traverse 0.6 |
||||
@ -0,0 +1,789 @@
|
||||
# -*- 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::du 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
namespace eval punk::du { |
||||
variable has_twapi 0 |
||||
} |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {[catch {package require twapi}]} { |
||||
puts stderr "Warning: punk::du - unable to load twapi. Disk operations may be much slower on windows without the twapi package" |
||||
} else { |
||||
set punk::du::has_twapi 1 |
||||
} |
||||
package require punk::winpath |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::du { |
||||
|
||||
|
||||
proc dirlisting {{folderpath {}}} { |
||||
if {[lib::pathcharacterlen $folderpath] == 0} { |
||||
set folderpath [pwd] |
||||
} elseif {[file pathtype $folderpath] ne "absolute"} { |
||||
#file normalize relativelly slow - avoid in inner loops |
||||
#set folderpath [file normalize $folderpath] |
||||
|
||||
} |
||||
#run whichever of du_dirlisting_twapi, du_dirlisting_generic, du_dirlisting_unix has been activated |
||||
set dirinfo [active::du_dirlisting $folderpath] |
||||
} |
||||
|
||||
|
||||
|
||||
#Note that unix du seems to do depth-first - which makese sense when piping.. as output can be emitted as we go rather than requiring sort at end. |
||||
#breadth-first with sort can be quite fast .. but memory usage can easily get out of control |
||||
proc du { args } { |
||||
variable has_twapi |
||||
package require struct::set |
||||
|
||||
|
||||
if 0 { |
||||
switch -exact [llength $args] { |
||||
0 { |
||||
set dir . |
||||
set switch -k |
||||
} |
||||
1 { |
||||
set dir $args |
||||
set switch -k |
||||
} |
||||
2 { |
||||
set switch [lindex $args 0] |
||||
set dir [lindex $args 1] |
||||
} |
||||
default { |
||||
set msg "only one switch and one dir " |
||||
append msg "currently supported" |
||||
return -code error $msg |
||||
} |
||||
} |
||||
|
||||
set switch [string tolower $switch] |
||||
|
||||
set -b 1 |
||||
set -k 1024 |
||||
set -m [expr 1024*1024] |
||||
} |
||||
|
||||
|
||||
set opts $args |
||||
# flags in args are solos (or longopts --something=somethingelse) or sometimes pairopts |
||||
# we don't currently support mashopts (ie -xy vs separate -x -y) |
||||
|
||||
|
||||
#------------------------------------------------------- |
||||
# process any pairopts first and remove the pair |
||||
# (may also process some solo-opts) |
||||
|
||||
set opt_depth -1 |
||||
if {[set posn [lsearch $opts -d]] >= 0} { |
||||
set opt_depth [lindex $opts $posn+1] |
||||
set opts [lreplace $opts $posn $posn+1] |
||||
} |
||||
foreach o $opts { |
||||
if {[string match --max-depth=* $o]} { |
||||
set opt_depth [lindex [split $o =] 1] |
||||
if {![string is integer -strict $opt_depth]} { |
||||
error "--max-depth=n n must be an integer" |
||||
} |
||||
} |
||||
} |
||||
#------------------------------------------------------- |
||||
#only solos and longopts remain in the opts now |
||||
|
||||
|
||||
set lastarg [lindex $opts end] |
||||
if {[string length $lastarg] && (![string match -* $lastarg])} { |
||||
set dir $lastarg |
||||
set opts [lrange $opts 0 end-1] |
||||
} else { |
||||
set dir . |
||||
set opts $opts |
||||
} |
||||
foreach a $opts { |
||||
if {![string match -* $a]} { |
||||
error "unrecognized option '$a'" |
||||
} |
||||
} |
||||
|
||||
set -b 1 |
||||
set -k 1024 |
||||
set -m [expr 1024*1024] |
||||
set switch -k ;#default (same as unix) |
||||
set lc_opts [string tolower $opts] |
||||
|
||||
|
||||
|
||||
if {"-b" in $lc_opts} { |
||||
set switch -b |
||||
} elseif {"-k" in $lc_opts} { |
||||
set switch -k |
||||
} elseif {"-m" in $lc_opts} { |
||||
set switch -m |
||||
} |
||||
set opt_progress 0 |
||||
if {"--prog" in $lc_opts || "--progress" in $lc_opts} { |
||||
set opt_progress 1 |
||||
} |
||||
set opt_extra 0 |
||||
if {"--extra" in $lc_opts} { |
||||
set opt_extra 1 |
||||
} |
||||
set opt_vfs 0 |
||||
if {"--vfs" in $lc_opts} { |
||||
set opt_vfs 1 |
||||
} |
||||
|
||||
|
||||
|
||||
set result [list] |
||||
|
||||
set dir_depths_remaining [list] |
||||
|
||||
set is_windows [expr {$::tcl_platform(platform) eq "windows"}] |
||||
set zero [expr {0}] |
||||
|
||||
# ## ### ### ### ### |
||||
# containerid and itemid |
||||
set folders [list] ;#we lookup string by index |
||||
lappend folders [file dirname $dir] |
||||
lappend folders $dir ;#itemindex 1 |
||||
# ## ### ### ### ### |
||||
if {![file isdirectory $dir]} { |
||||
lappend dir_depths_remaining [list $zero $zero [expr {1}] [lib::du_lit [file tail $dir]] [file size $dir]] |
||||
#set ary($dir,bytes) [file size $dir] |
||||
set leveldircount 0 |
||||
} else { |
||||
lappend dir_depths_remaining [list $zero $zero [expr {1}] [lib::du_lit [file tail $dir]] $zero] |
||||
set leveldircount 1 |
||||
} |
||||
set level [expr {0}] |
||||
set nextlevel [expr {1}] |
||||
#dir_depths list structure |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#0 1 2 3 4 5 |
||||
#i_depth i_containerid i_itemid i_item i_size i_index |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set i_depth [expr {0}] |
||||
set i_containerid [expr {1}] |
||||
set i_itemid [expr {2}] |
||||
set i_item [expr {3}] |
||||
set i_size [expr {4}] |
||||
set i_index [expr {5}] |
||||
|
||||
|
||||
set listlength [llength $dir_depths_remaining] |
||||
set diridx 0 |
||||
#this is a breadth-first algorithm |
||||
while {$leveldircount > 0} { |
||||
set leveldirs 0 |
||||
set levelfiles 0 |
||||
for {set i $diridx} {$i < $listlength} {incr i} { |
||||
#lassign [lindex $dir_depths_remaining $i] _d containeridx folderidx itm bytecount |
||||
set folderidx [lindex $dir_depths_remaining $i $i_itemid] |
||||
set folderpath [lindex $folders $folderidx] |
||||
#puts stderr ->$folderpath |
||||
#if {$i >= 20} { |
||||
#return |
||||
#} |
||||
|
||||
#twapi supports gathering file sizes during directory contents traversal |
||||
#for dirlisting methods that return an empty list in filesizes whilst files has entries - we will need to populate it below |
||||
#e.g tcl glob based dirlisting doesn't support gathering file sizes at the same time |
||||
|
||||
set in_vfs 0 |
||||
if {$opt_vfs} { |
||||
foreach vfsmount [vfs::filesystem info] { |
||||
if {[punk::repo::path_a_atorbelow_b $folderpath $vfsmount]} { |
||||
set in_vfs 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$in_vfs} { |
||||
set du_info [lib::du_dirlisting_tclvfs $folderpath] |
||||
} else { |
||||
#run the activated function (proc imported to active namespace and renamed) |
||||
set du_info [active::du_dirlisting $folderpath] |
||||
} |
||||
|
||||
|
||||
set dirs [dict get $du_info dirs] |
||||
set files [dict get $du_info files] |
||||
set filesizes [dict get $du_info filesizes] |
||||
|
||||
|
||||
incr leveldirs [llength $dirs] |
||||
incr levelfiles [llength $files] |
||||
|
||||
#lappend dir_depths_remaining {*}[lmap d $dirs {::list $nextdepth [lib::du_lit $cont/$itm] $d $zero}] |
||||
#folderidx is parent index for new dirs |
||||
lappend dir_depths_remaining {*}[lib::du_new_eachdir $dirs $nextlevel $folderidx] |
||||
|
||||
#we don't need to sort files (unless we add an option such as -a to du (?)) |
||||
set bytecount [expr {0}] |
||||
|
||||
if {[llength $files] && ![llength $filesizes]} { |
||||
#listing mechanism didn't supply corresponding sizes |
||||
foreach filename $files { |
||||
#incr bytecount [file size [file join $folderpath $filename] |
||||
incr bytecount [file size $filename] |
||||
} |
||||
} else { |
||||
set filesizes [lsearch -all -inline -not $filesizes[unset filesizes] na] ;#only legal non-number is na |
||||
set bytecount [tcl::mathop::+ {*}$filesizes] |
||||
} |
||||
|
||||
|
||||
#we can safely assume initial count was zero |
||||
lset dir_depths_remaining $i $i_size $bytecount |
||||
#incr diridx |
||||
} |
||||
#puts stdout "level: $level dirs: $leveldirs" |
||||
if {$opt_extra} { |
||||
puts stdout "level: $level dircount: $leveldirs filecount: $levelfiles" |
||||
} |
||||
incr level ;#zero based |
||||
set nextlevel [expr {$level + 1}] |
||||
set leveldircount [expr {[llength $dir_depths_remaining] - $listlength }]; #current - previous - while loop terminates when zero |
||||
#puts "diridx: $diridx i: $i rem: [llength $dir_depths_remaining] listlenth:$listlength levldircount: $leveldircount" |
||||
set diridx $i |
||||
set listlength [llength $dir_depths_remaining] |
||||
} |
||||
#puts stdout ">>> loop done" |
||||
#flush stdout |
||||
#puts stdout $dir_depths_remaining |
||||
set dirs_as_encountered $dir_depths_remaining ;#index is in sync with 'folders' list |
||||
set dir_depths_longfirst $dirs_as_encountered |
||||
|
||||
#store the index before sorting |
||||
for {set i 0} {$i < [llength $dir_depths_remaining]} {incr i} { |
||||
lset dir_depths_longfirst $i $i_index $i |
||||
} |
||||
set dir_depths_longfirst [lsort -integer -index 0 -decreasing $dir_depths_longfirst[set dir_depths_longfirst {}]] |
||||
|
||||
#store main index in the reducing list |
||||
set dir_depths_remaining $dir_depths_longfirst |
||||
for {set i 0} {$i < [llength $dir_depths_remaining]} {incr i} { |
||||
#stored index at position 3 |
||||
lset dir_depths_remaining $i $i_index $i |
||||
} |
||||
|
||||
#index 3 |
||||
#dir_depths_remaining -> dir_depths_longfirst -> dirs_as_encountered |
||||
|
||||
#puts stdout "initial dir_depths_remaining: $dir_depths_remaining" |
||||
|
||||
|
||||
#summing performance is not terrible but significant on large tree - the real time is for large trees in the main loop above |
||||
#update - on really large trees the reverse is true especiallyl now that twapi fixed the original speed issues.. todo - rework/simplify below - review natsort |
||||
# |
||||
#TODO - reconsider sorting by depth.. lreverse dirs_as_encountered should work.. |
||||
if {[llength $dir_depths_longfirst] > 1} { |
||||
set i 0 |
||||
foreach dd $dir_depths_longfirst { |
||||
lassign $dd d parentidx folderidx item bytecount |
||||
#set nm $cont/$item |
||||
set nm [lindex $folders $folderidx] |
||||
set dnext [expr {$d +1}] |
||||
set nextdepthposns [lsearch -all -integer -index 0 $dir_depths_remaining $dnext] |
||||
set nextdepthposns [lsort -integer -decreasing $nextdepthposns[set nextdepthposns {}]];#remove later elements first |
||||
foreach posn $nextdepthposns { |
||||
set id [lindex $dir_depths_remaining $posn $i_itemid] |
||||
set ndirname [lindex $folders $id] |
||||
#set ndirname $cont/$item |
||||
#set item [lindex $dir_depths_remaining $posn $i_item] |
||||
#set ndirname [lindex $ndir 1] |
||||
if {[string match $nm/* $ndirname]} { |
||||
#puts stdout "dir $nm adding subdir size $ndirname" |
||||
#puts stdout "incr $nm from $ary($nm,bytes) plus $ary($ndirname,bytes)" |
||||
incr bytecount [lindex $dir_depths_remaining $posn $i_size] |
||||
set dir_depths_remaining [lreplace $dir_depths_remaining[set dir_depths_remaining {}] $posn $posn] |
||||
} |
||||
} |
||||
lset dir_depths_longfirst $i $i_size $bytecount |
||||
set p [lsearch -index $i_index -integer $dir_depths_remaining $i] |
||||
lset dir_depths_remaining $p $i_size $bytecount |
||||
#set ary($nm,bytes) $bytecount |
||||
incr i |
||||
} |
||||
} |
||||
#set dir_depths_longfirst [lsort -index 1 -decreasing $dir_depths_longfirst] |
||||
# |
||||
|
||||
set retval [list] |
||||
#copy across the bytecounts |
||||
for {set i 0} {$i < [llength $dir_depths_longfirst]} {incr i} { |
||||
set posn [lindex $dir_depths_longfirst $i $i_index] |
||||
set bytes [lindex $dir_depths_longfirst $i $i_size] |
||||
lset dirs_as_encountered $posn $i_size $bytes |
||||
} |
||||
foreach dirinfo [lreverse $dirs_as_encountered] { |
||||
set id [lindex $dirinfo $i_itemid] |
||||
set depth [lindex $dirinfo $i_depth] |
||||
if {($opt_depth >= 0) && $depth > $opt_depth} { |
||||
continue |
||||
} |
||||
set path [lindex $folders $id] |
||||
#set path $cont/$item |
||||
set item [lindex $dirinfo $i_item] |
||||
set bytes [lindex $dirinfo $i_size] |
||||
set size [expr {$bytes / [set $switch]}] |
||||
lappend retval [list $size $path] |
||||
} |
||||
# copyright 2002 by The LIGO Laboratory |
||||
return $retval |
||||
} |
||||
namespace eval active { |
||||
variable functions [list du_dirlisting ""] |
||||
variable functions_known [dict create] |
||||
|
||||
#known functions from lib namespace |
||||
dict set functions_known du_dirlisting [list du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix] |
||||
|
||||
proc show_functions {} { |
||||
variable functions |
||||
variable functions_known |
||||
set msg "" |
||||
dict for {callname implementations} $functions_known { |
||||
append msg "callname: $callname" \n |
||||
foreach imp $implementations { |
||||
if {[dict get $functions $callname] eq $imp} { |
||||
append msg " $imp (active)" \n |
||||
} else { |
||||
append msg " $imp" \n |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
} |
||||
proc set_active_function {callname implementation} { |
||||
variable functions |
||||
variable functions_known |
||||
if {$callname ni [dict keys $functions_known]} { |
||||
error "unknown function callname $callname" |
||||
} |
||||
if {$implementation ni [dict get $functions_known $callname]} { |
||||
error "unknown implementation $implementation for callname $callname" |
||||
} |
||||
dict set functions $callname $implementation |
||||
|
||||
catch {rename ::punk::du::active::$callname ""} |
||||
namespace eval ::punk::du::active [string map [list %imp% $implementation %call% $callname] { |
||||
namespace import ::punk::du::lib::%imp% |
||||
rename %imp% %call% |
||||
}] |
||||
|
||||
return $implementation |
||||
} |
||||
proc get_active_function {callname} { |
||||
variable functions |
||||
variable functions_known |
||||
if {$callname ni [dict keys $functions_known]} { |
||||
error "unknown function callname $callname known functions: [dict keys $functions_known]" |
||||
} |
||||
return [dict get $functions $callname] |
||||
} |
||||
|
||||
|
||||
#where we import & the appropriate du_listing.. function for the platform |
||||
} |
||||
namespace eval lib { |
||||
variable du_literal |
||||
variable winfile_attributes [list 16 directory 32 archive 1024 reparse_point 18 [list directory hidden] 34 [list archive hidden] ] |
||||
#caching this is faster than calling twapi api each time.. unknown if twapi is calculating from bitmask - or calling windows api |
||||
#we could work out all flags and calculate from bitmask.. but it's not necessarily going to be faster than some simple caching mechanism like this |
||||
|
||||
namespace export du_dirlisting_twapi du_dirlisting_generic du_dirlisting_unix |
||||
# get listing without using unix-tools (may not be installed on the windows system) |
||||
# this dirlisting is customised for du - so only retrieves dirs,files,filesizes (minimum work needed to perform du function) |
||||
proc du_dirlisting_twapi {folderpath} { |
||||
set altname "" ;#possible we have to use a different name e.g short windows name or dos-device path //?/ |
||||
# return it so it can be stored and tried as an alternative for problem paths |
||||
try { |
||||
set iterator [twapi::find_file_open [file join $folderpath *] -detail basic] ;# -detail full only adds data to the altname field |
||||
} on error args { |
||||
try { |
||||
if {[string match "*denied*" $args]} { |
||||
#output similar format as unixy du |
||||
puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args" |
||||
return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] |
||||
} |
||||
if {[string match "*TWAPI_WIN32 59*" $::errorCode]} { |
||||
puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (possibly blocked by permissions or share config e.g follow symlinks = no on samba)" |
||||
puts stderr " (errorcode: $::errorCode)\n" |
||||
return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
if {[set plen [pathcharacterlen $folderpath]] >= 250} { |
||||
set errmsg "error reading folder: $folderpath (len:$plen)\n" |
||||
append errmsg "error: $args" \n |
||||
append errmsg "errorcode: $::errorCode" \n |
||||
# re-fetch this folder with altnames |
||||
#file normalize - aside from being slow - will have problems with long paths - so this won't work. |
||||
#this function should only accept absolute paths |
||||
# |
||||
# |
||||
#Note: using -detail full only helps if the last segment of path has an altname.. |
||||
#To properly shorten we need to have kept track of altname all the way from the root! |
||||
#We can .. for now call Tcl's file attributes to get shortname of the whole path - it is *expensive* e.g 5ms for a long path on local ssd |
||||
#### SLOW |
||||
set fixedpath [dict get [file attributes $folderpath] -shortname] |
||||
#### SLOW |
||||
|
||||
|
||||
append errmsg "retrying with with windows altname '$fixedpath'" |
||||
puts stderr $errmsg |
||||
} else { |
||||
set errmsg "error reading folder: $folderpath (len:$plen)\n" |
||||
append errmsg "error: $args" \n |
||||
append errmsg "errorcode: $::errorCode" \n |
||||
#possibly an illegal windows filename - easily happens on a machine with WSL or with drive mapped to unix share |
||||
#we can use //?/path dos device path - but not with tcl functions |
||||
#unfortunately we can't call find_file_open directly on the problem name - we have to call the parent folder and iterate through again.. |
||||
#this gets problematic as we go deeper unless we rewrite the .. but we can get at least one level further here |
||||
|
||||
set parent [file dirname $folderpath] |
||||
set badtail [file tail $folderpath] |
||||
set iterator [twapi::find_file_open [file join $parent *] -detail full] ;#retrieve with altnames |
||||
set fixedtail "" |
||||
while {[twapi::find_file_next $iterator iteminfo]} { |
||||
set nm [dict get $iteminfo name] |
||||
if {$nm eq $badtail} { |
||||
set fixedtail [dict get $iteminfo altname] |
||||
break |
||||
} |
||||
} |
||||
|
||||
if {![string length $fixedtail]} { |
||||
puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args (Unable to retrieve altname to progress further with path - returning no contents for this folder)" |
||||
return [list dirs {} vfsmounts {} links {} files {} filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] |
||||
} |
||||
#twapi as at 2023-08 doesn't seem to support //?/ dos device paths.. |
||||
#Tcl can test only get as far as testing existence of illegal name by prefixing with //?/ - but can't glob inside it |
||||
#we can call file attributes on it - but we get no shortname (but we could get shortname for parent that way) |
||||
#so the illegalname_fix doesn't really work here |
||||
#set fixedpath [punk::winpath::illegalname_fix $parent $fixedtail] |
||||
|
||||
#this has shortpath for the tail - but it's not the canonical-shortpath because we didn't call it on the $parent part REIEW. |
||||
set fixedpath [file join $parent $fixedtail] |
||||
append errmsg "retrying with with windows dos device path $fixedpath\n" |
||||
puts stderr $errmsg |
||||
|
||||
} |
||||
|
||||
|
||||
set iterator [twapi::find_file_open $fixedpath/* -detail basic] |
||||
|
||||
|
||||
} on error args { |
||||
set errmsg "error reading folder: $folderpath\n" |
||||
append errmsg "error: $args" |
||||
append errmsg "aborting.." |
||||
error $errmsg |
||||
|
||||
} |
||||
} |
||||
set dirs [list] |
||||
set files [list] |
||||
set filesizes [list] |
||||
set links [list] |
||||
set flaggedhidden [list] |
||||
set flaggedsystem [list] |
||||
set flaggedreadonly [list] |
||||
|
||||
while {[twapi::find_file_next $iterator iteminfo]} { |
||||
set nm [dict get $iteminfo name] |
||||
set tail_altname [dict get $iteminfo altname] ;#altname of tail - not whole path |
||||
set attrinfo [decode_win_attributes [dict get $iteminfo attrs]] |
||||
#puts stderr "$iteminfo" |
||||
#puts stderr "$nm -> [dict get $iteminfo attrs] -> $attrinfo" |
||||
|
||||
#attributes applicable to any classification |
||||
set fullname [file_join_one $folderpath $nm] |
||||
if {"hidden" in $attrinfo} { |
||||
lappend flaggedhidden $fullname |
||||
} |
||||
if {"system" in $attrinfo} { |
||||
lappend flaggedsystem $fullname |
||||
} |
||||
if {"readonly" in $attrinfo} { |
||||
lappend flaggedreadonly $fullname |
||||
} |
||||
|
||||
#main classification |
||||
if {"reparse_point" in $attrinfo} { |
||||
#we will treat as zero sized for du purposes.. review - option -L for symlinks like BSD du? |
||||
#Note 'file readlink' can fail on windows - reporting 'invalid argument' - according to tcl docs, 'On systems that don't support symbolic links this option is undefined' |
||||
#The link may be viewable ok in windows explorer, and cmd.exe /c dir and unix tools such as ls |
||||
#if we need it without resorting to unix-tools that may not be installed: exec {*}[auto_execok dir] /A:L {c:\some\path} |
||||
#e.g (stripped of headers/footers and other lines) |
||||
#2022-10-02 04:07 AM <SYMLINKD> priv [\\?\c:\repo\elixir\gameportal\apps\test\priv] |
||||
#Note we will have to parse beyond header fluff as /B strips the symlink info along with headers. |
||||
#du includes the size of the symlink |
||||
#but we can't get it with tcl's file size |
||||
#twapi doesn't seem to have anything to help read it either (?) |
||||
#the above was verified with a symlink that points to a non-existant folder.. mileage may vary for an actually valid link |
||||
# |
||||
#Note also - a shortcut created in explorer with drag and drop to an existant folder is a different animal to a symlink (file with .lnk extension) even though it looks the same in explorer window. |
||||
# |
||||
#links are techically files too, whether they point to a file/dir or nothing. |
||||
lappend links $fullname |
||||
} elseif {"directory" in $attrinfo} { |
||||
if {$nm in {. ..}} { |
||||
continue |
||||
} |
||||
lappend dirs $fullname |
||||
} else { |
||||
|
||||
#review - is anything that isn't a reparse_point or a directory, some sort of 'file' in this context? What about the 'device' attribute? Can that occur in a directory listing of some sort? |
||||
lappend files $fullname |
||||
lappend filesizes [dict get $iteminfo size] |
||||
} |
||||
} |
||||
twapi::find_file_close $iterator |
||||
set vfsmounts [get_vfsmounts_in_folder $folderpath] |
||||
#also determine whether vfs. file system x is *much* faster than file attributes |
||||
#whether or not there is a corresponding file/dir add any applicable mountpoints for the containing folder |
||||
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes $filesizes flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem flaggedreadonly $flaggedreadonly altname $altname] |
||||
} |
||||
proc get_vfsmounts_in_folder {folderpath} { |
||||
set vfsmounts [list] |
||||
set known_vfs_mounts [vfs::filesystem info] |
||||
foreach mount $known_vfs_mounts { |
||||
if {[punk::repo::path_a_above_b $folderpath $mount]} { |
||||
if {([llength [file split $mount]] - [llength [file split $folderpath]]) == 1} { |
||||
#the mount is in this folder |
||||
lappend vfsmounts $mount |
||||
} |
||||
} |
||||
} |
||||
return $vfsmounts |
||||
} |
||||
#work around the horrible tilde-expansion thing (not needed for tcl 9+) |
||||
proc file_join_one {base newtail} { |
||||
if {[string index $newtail 0] ne {~}} { |
||||
return [file join $base $newtail] |
||||
} |
||||
return [file join $base ./$newtail] |
||||
} |
||||
|
||||
|
||||
#this is the cross-platform pure-tcl version - which calls glob multiple times to make sure it gets everythign it needs and can ignore everything it needs to. |
||||
#These repeated calls to glob will be a killer for performance - especially on a network share or when walking a large directory structure |
||||
proc du_dirlisting_generic {folderpath} { |
||||
#note platform differences between what is considered hidden make this tricky. |
||||
# on windows 'glob .*' will not return some hidden dot items but will return . .. and glob -types hidden .* will not return some dotted items |
||||
# glob -types hidden * on windows will not necessarily return all dot files/folders |
||||
# unix-like platforms seem to consider all dot files as hidden so processing is more straightforward |
||||
# we need to process * and .* in the same glob calls and remove duplicates |
||||
# if we do * and .* in separate iterations of this loop we lose the ability to filter duplicates easily |
||||
|
||||
#Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' |
||||
#set parent [lindex $folders $folderidx] |
||||
set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] |
||||
#set hdirs {} |
||||
set dirs [glob -nocomplain -dir $folderpath -types d * .*] |
||||
|
||||
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] |
||||
#set hlinks {} |
||||
set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove |
||||
#set links [lsort -unique [concat $hlinks $links[unset links]]] |
||||
|
||||
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] |
||||
#set hfiles {} |
||||
set files [glob -nocomplain -dir $folderpath -types f * .*] |
||||
#set files {} |
||||
|
||||
#note struct::set difference produces unordered result |
||||
#struct::set difference removes duplicates |
||||
#remove links and . .. from directories, remove links from files |
||||
set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] |
||||
set files [struct::set difference [concat $hfiles $files[unset files]] $links] |
||||
set links [lsort -unique [concat $links $hlinks]] |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set flaggedhidden [concat $hdirs $hfiles $hlinks] |
||||
} else { |
||||
#unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden |
||||
#this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden |
||||
set flaggedhidden {} |
||||
} |
||||
|
||||
set vfsmounts [get_vfsmounts_in_folder $folderpath] |
||||
|
||||
set filesizes [list]; #not available in listing-call - as opposed to twapi which can do it as it goes |
||||
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] |
||||
} |
||||
|
||||
#we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files |
||||
proc du_dirlisting_unix {folderpath} { |
||||
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs |
||||
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove |
||||
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files |
||||
#remove any links from our dirs and files collections |
||||
set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] |
||||
set files [struct::set difference $files[unset files] $links] |
||||
set vfsmounts [get_vfsmounts_in_folder $folderpath] |
||||
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] |
||||
} |
||||
proc du_dirlisting_tclvfs {folderpath} { |
||||
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs |
||||
#review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? |
||||
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove |
||||
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files |
||||
#remove any links from our dirs and files collections |
||||
set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] |
||||
set files [struct::set difference $files[unset files] $links] |
||||
#nested vfs mount.. REVIEW - does anything need special handling? |
||||
set vfsmounts [get_vfsmounts_in_folder $folderpath] |
||||
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes {} flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {}] |
||||
} |
||||
|
||||
|
||||
proc decode_win_attributes {bitmask} { |
||||
variable winfile_attributes |
||||
if {[dict exists $winfile_attributes $bitmask]} { |
||||
return [dict get $winfile_attributes $bitmask] |
||||
} else { |
||||
#list/dict shimmering? |
||||
return [lindex [lappend winfile_attributes $bitmask [twapi::decode_file_attributes $bitmask]] end] |
||||
} |
||||
} |
||||
|
||||
proc du_lit value { |
||||
variable du_literal |
||||
if {![info exists du_literal($value)]} { |
||||
set du_literal($value) $value |
||||
} |
||||
return $du_literal($value) |
||||
} |
||||
|
||||
#v1 |
||||
proc du_new_eachdirtail {dirtails depth parentfolderidx} { |
||||
set newlist {} |
||||
upvar folders folders |
||||
set parentpath [lindex $folders $parentfolderidx] |
||||
set newindex [llength $folders] |
||||
foreach dt $dirtails { |
||||
lappend folders [file join $parentpath [du_lit $dt]]; #store as a 'path' rather than a string (see tcl::unsupported::representation) |
||||
lappend newlist [::list $depth $parentfolderidx $newindex [du_lit $dt] [expr {0}]] |
||||
incr newindex |
||||
} |
||||
return $newlist |
||||
} |
||||
proc du_new_eachdir {dirpaths depth parentfolderidx} { |
||||
set newlist {} |
||||
upvar folders folders |
||||
set newindex [llength $folders] |
||||
foreach dp $dirpaths { |
||||
lappend folders $dp |
||||
#puts stdout "--->$dp" |
||||
lappend newlist [::list $depth $parentfolderidx $newindex [du_lit [file tail $dp]] [expr {0}]] |
||||
incr newindex |
||||
} |
||||
return $newlist |
||||
} |
||||
|
||||
#just an experiment |
||||
#get length of path which has internal rep of path - maintaining path/list rep without shimmering to string representation. |
||||
proc pathcharacterlen {pathrep} { |
||||
set l 0 |
||||
set parts [file split $pathrep] |
||||
if {[llength $parts] < 2} { |
||||
return [string length [lindex $parts 0]] |
||||
} |
||||
foreach seg $parts { |
||||
incr l [string length $seg] |
||||
} |
||||
return [expr {$l + [llength $parts] -2}] |
||||
} |
||||
#slower - doesn't work for short paths like c:/ |
||||
proc pathcharacterlen2 {pathrep} { |
||||
return [tcl::mathop::+ {*}[lmap v [set plist [file split $pathrep]] {[string length $v]}] [llength $plist] -2] |
||||
} |
||||
|
||||
#Strip using lengths without examining path components |
||||
#without normalization is much faster |
||||
proc path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
set tail [lrange [file split $path] [llength [file split $prefix]] end] |
||||
if {[llength $tail]} { |
||||
return [file join {*}$tail] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
package require natsort |
||||
#interp alias {} du {} .=args>* punk::du |> .=>1 natsort::sort -cols 1 |> list_as_lines <args| |
||||
#use natsort -debug 2 to see index output |
||||
#this works better for display of directory/file names with spaces (doesn't show curly braces) |
||||
interp alias {} du2 {} .=args>* punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat words |> list_as_lines <args| |
||||
|
||||
#experiment with csv as easy way to get column like format.. |
||||
#The /r is somewhat cheating however.. as it messes up redirected output .. e.g if redirected to text file |
||||
interp alias {} du {} .=args>* punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines <args| |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval ::punk::du::active { |
||||
variable functions |
||||
variable functions_kown |
||||
|
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {$punk::du::has_twapi} { |
||||
set_active_function du_dirlisting du_dirlisting_twapi |
||||
} else { |
||||
set_active_function du_dirlisting du_dirlisting_generic |
||||
} |
||||
} else { |
||||
set_active_function du_dirlisting du_dirlisting_unix |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::du [namespace eval punk::du { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,814 @@
|
||||
# -*- 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. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#Copyright (c) 2023 Julian Noble |
||||
#Copyright (c) 2012-2018 Andreas Kupries |
||||
# - code from A.K's 'kettle' project used in this module |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::repo 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# |
||||
# path/repo functions |
||||
# |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
package require punk::winpath |
||||
} else { |
||||
catch {package require punk::winpath} |
||||
} |
||||
package require cksum ;#tcllib |
||||
package require fileutil; #tcllib |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
# For performance/efficiency reasons - use file functions on paths in preference to string operations |
||||
# e.g use file join |
||||
# branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023) |
||||
# pwd is only expensive if we treat it as a string instead of a list/path |
||||
# e.g |
||||
# > time {set x [pwd]} |
||||
# 5 microsoeconds.. no problem |
||||
# > time {set x [pwd]} |
||||
# 4 microsoeconds.. still no problem |
||||
# > string length $x |
||||
# 45 |
||||
# > time {set x [pwd]} |
||||
# 1372 microseconds per iteration ;#!! values above 0.5ms common.. and that's a potential problem in loops that trawl filesystem |
||||
# The same sorts of timings occur with file normalize |
||||
# also.. even if we build up a path with file join from a base value that has already been normalized - the subsequent normalize will be expensive |
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
namespace eval punk::repo { |
||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||
|
||||
proc is_fossil {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
return [expr {[find_fossil $path] ne {}}] |
||||
} |
||||
proc is_git {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
return [expr {[find_git $path] ne {}}] |
||||
} |
||||
#tracked repo - but may not be a project |
||||
proc is_repo {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
return [expr {[isfossil] || [is_git]}] |
||||
} |
||||
proc is_candidate {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
return [expr {[find_candidate $path] ne {}}] |
||||
} |
||||
proc is_project {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
return [expr {[find_project $path] ne {}}] |
||||
} |
||||
|
||||
|
||||
proc find_fossil {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
scanup $path is_fossil_root |
||||
} |
||||
proc find_git {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
scanup $path is_git_root |
||||
} |
||||
proc find_candidate {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
scanup $path is_candidate_root |
||||
} |
||||
proc find_repo {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
#find the closest (lowest in dirtree) repository |
||||
set f_root [find_fossil $path] |
||||
set g_root [find_git $path] |
||||
if {[string length $f_root]} { |
||||
if {[string length $g_root]} { |
||||
if {[path_a_below_b $f_root $g_root]} { |
||||
return $f_root |
||||
} else { |
||||
return $g_root |
||||
} |
||||
} else { |
||||
return $f_root |
||||
} |
||||
} else { |
||||
if {[string length $g_root]} { |
||||
return $g_root |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
} |
||||
proc find_project {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
scanup $path is_project_root |
||||
} |
||||
|
||||
proc is_fossil_root {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
#from kettle::path::is.fossil |
||||
foreach control { |
||||
_FOSSIL_ |
||||
.fslckout |
||||
.fos |
||||
} { |
||||
set control $path/$control |
||||
if {[file exists $control] && [file isfile $control]} {return 1} |
||||
} |
||||
return 0 |
||||
} |
||||
proc is_git_root {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
set control [file join $path .git] |
||||
expr {[file exists $control] && [file isdirectory $control]} |
||||
} |
||||
proc is_repo_root {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
expr {[is_fossil_root $path] || [is_git_root $path]} |
||||
} |
||||
#require a minimum of /src and /modules|lib|scriptapps|*.vfs - and that it's otherwise sensible |
||||
proc is_candidate_root {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set normpath [punk::repo::norm [punk::winpath::winpath $path]] |
||||
} else { |
||||
set normpath [punk::repo::norm $path] |
||||
} |
||||
} else { |
||||
set normpath $path |
||||
} |
||||
set unwise_paths [list "/" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"] |
||||
if {[string tolower $normpath] in $unwise_paths} { |
||||
return 0 |
||||
} |
||||
if {[file pathtype [string trimright $normpath /]] eq "volumerelative"} { |
||||
#tcl 8.6/8.7 cd command doesn't preserve the windows "ProviderPath" (per drive current working directory) |
||||
return 0 |
||||
} |
||||
|
||||
#review - adjust to allow symlinks to folders? |
||||
foreach required { |
||||
src |
||||
} { |
||||
set req $path/$required |
||||
if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0} |
||||
} |
||||
|
||||
set src_subs [glob -nocomplain -dir $path/src -types d -tail *] |
||||
if {"modules" in $src_subs || "lib" in $src_subs || "scriptapps" in $src_subs} { |
||||
return 1 |
||||
} |
||||
foreach sub $src_subs { |
||||
if {[string match *.vfs $sub]} { |
||||
return 1 |
||||
} |
||||
} |
||||
|
||||
#todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root |
||||
#we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree |
||||
#such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate |
||||
|
||||
return 0 |
||||
} |
||||
#keep this message in sync with the programmed requirements of is_candidate_root |
||||
#message is not titled - it is intended to be output along with more contextual information from the calling site. |
||||
proc is_candidate_root_requirements_msg {} { |
||||
set msg "" |
||||
append msg "./src directory must exist." \n |
||||
append msg "At least one of ./src/lib ./src/modules ./src/scriptapps or a ./src/<something>.vfs folder should exist." \n |
||||
#append msg "Alternatively - the presence of any .tm or .tcl files within the top few levels of ./src will suffice." \n |
||||
return $msg |
||||
} |
||||
|
||||
proc is_project_root {path} { |
||||
#review - find a reliable simple mechanism. Noting we have projects based on different templates. |
||||
#Should there be a specific required 'project' file of some sort? |
||||
|
||||
#test for file/folder items indicating fossil or git workdir base |
||||
if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} { |
||||
return 0 |
||||
} |
||||
#exclude some known places we wouldn't want to put a project |
||||
if {![is_candidate_root $path]} { |
||||
return 0 |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
proc find_roots_and_warnings_dict {path} { |
||||
set start_dir $path |
||||
|
||||
#root is a 'project' if it it meets the candidate requrements and is under repo control |
||||
#therefore if project is in the closest_types list - candidate will always be there too - and at least one of git or fossil |
||||
set root_dict [list closest {} closest_types {} fossil {} git {} candidate {} project {} warnings {}] |
||||
set msg "" |
||||
|
||||
#we're only searching in a straight path up the tree looking for a few specific marker files/folder |
||||
set fosroot [punk::repo::find_fossil $start_dir] |
||||
dict set root_dict fossil $fosroot |
||||
set gitroot [punk::repo::find_git $start_dir] |
||||
dict set root_dict git $gitroot |
||||
set candroot [punk::repo::find_candidate $start_dir] |
||||
dict set root_dict candidate $candroot |
||||
|
||||
|
||||
if {[string length $fosroot]} { |
||||
if {([string length $candroot]) && ([string tolower $fosroot] ne [string tolower $candroot])} { |
||||
|
||||
#todo - only warn if this candidate is *within* the found repo root? |
||||
append msg "**" \n |
||||
append msg "** found folder with /src at or above starting folder - that isn't the fossil root" \n |
||||
append msg "** starting folder : $start_dir" \n |
||||
append msg "** unexpected : $candroot" \n |
||||
append msg "** fossil root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n |
||||
append msg "** reporting based on the fossil root found." |
||||
append msg "**" \n |
||||
|
||||
} |
||||
|
||||
} else { |
||||
if {[string length $gitroot]} { |
||||
|
||||
if {([string length $candroot]) && ([string tolower $gitroot] ne [string tolower $candroot])} { |
||||
|
||||
append msg "**" \n |
||||
append msg "** found folder with /src at or above current folder - that isn't the git root" \n |
||||
append msg "** starting folder : $start_dir" \n |
||||
append msg "** unexpected : $candroot ([punk::repo::path_relative $start_dir $candroot])" \n |
||||
append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n |
||||
append msg "** reporting based on the git root found." |
||||
append msg "**" \n |
||||
|
||||
} |
||||
} else { |
||||
|
||||
} |
||||
} |
||||
|
||||
if {(![string length [dict get $root_dict fossil]])} { |
||||
append msg "Not a punk fossil project" \n |
||||
} |
||||
#don't warn if not git - unless also not fossil |
||||
if {(![string length [dict get $root_dict fossil]]) && (![string length [dict get $root_dict git]])} { |
||||
append msg "No repository located at or above starting folder $start_dir" \n |
||||
if {![string length [dict get $root_dict candidate]]} { |
||||
append msg "No candidate project root found. " \n |
||||
append msg "Searched upwards from '$start_dir' expecting a folder with the following requirements: " \n |
||||
append msg [punk::repo::is_candidate_root_requirements_msg] \n |
||||
} else { |
||||
append msg "Candidate project root found at : $candidate" \n |
||||
append msg " - consider putting this folder under fossil control (and/or git)" \n |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
set pathinfo [list];#exclude not found |
||||
foreach repotype [list fossil git candidate] { |
||||
set path [dict get $root_dict $repotype] |
||||
if {[string length $path]} { |
||||
set plen [llength [file split $path]] |
||||
lappend pathinfo [list $repotype $path $plen] |
||||
} |
||||
} |
||||
#these root are all inline towards root of drive - so anything of same length should be same path - shorter path must be above another |
||||
#we will check equal depth paths are equal strings and raise an error just in case there are problems with the coding for the various path functions used here |
||||
#longest path is 'closest' to start_dir |
||||
set longest_first [lsort -index 2 $pathinfo] |
||||
if {![llength $longest_first]} { |
||||
#no repos or candidate - we have already created msg above |
||||
} else { |
||||
dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir - now we need to find all the types of this len |
||||
#see if others same len |
||||
set longestlen [lindex $longest_first 0 2] |
||||
set equal_longest [lsearch -all -inline -index 2 $longest_first $longestlen] |
||||
set ctypes [list] |
||||
foreach pinfo $equal_longest { |
||||
lappend ctypes [lindex $pinfo 0] |
||||
} |
||||
dict set root_dict closest_types $ctypes |
||||
} |
||||
|
||||
if {[string length [set fosroot [dict get $root_dict fossil]]] && [string length [set gitroot [dict get $root_dict git]]]} { |
||||
if {$fosroot ne $gitroot} { |
||||
if {[path_a_above_b $fosroot $gitroot]} { |
||||
append msg "Found git repo nested within fossil repo - be careful" \n |
||||
append msg "** fos root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n |
||||
append msg " * git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n |
||||
} else { |
||||
append msg "Found fossil repo nested within git repo - be careful" \n |
||||
append msg "** git root : $gitroot ([punk::repo::path_relative $start_dir $gitroot])" \n |
||||
append msg " * fos root : $fosroot ([punk::repo::path_relative $start_dir $fosroot])" \n |
||||
|
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
dict set root_dict warnings $msg |
||||
#some quick sanity checks.. |
||||
set ctypes [dict get $root_dict closest_types] |
||||
if {"project" in $ctypes} { |
||||
if {"candidate" ni $ctypes} { |
||||
set errmsg "find_roots_and_warnings_dict logic error: have project but not also classified as candidate (coding error in punk::repo) - inform developer\n" |
||||
append errmsg " warnings gathered before error:\n $msg" |
||||
error $errmsg |
||||
} |
||||
if {("git" ni $ctypes) && ("fossil" ni $ctypes)} { |
||||
set errmsg "find_roots_and_warnings_dict logic error: have project but not also at least one of 'git', 'fossil' (coding error in punk::repo) - inform developer\n" |
||||
append errmsg " warnings gathered before error:\n $msg" |
||||
error $errmsg |
||||
} |
||||
} |
||||
set ctype_paths [list] |
||||
foreach ctype [dict get $root_dict closest_types] { |
||||
lappend ctype_paths [lindex [dict get $root_dict $ctype] 1] ;# type, path, len |
||||
} |
||||
set unique [lsort -unique $ctype_paths] |
||||
if {[llength $unique] > 1} { |
||||
# this may be a filesystem path representation issue? case? normalisation? |
||||
set errmsg "find_roots_and_warnings_dict logic error: different paths for closest folders found (error in punk::repo) - inform developer\n" |
||||
append errmsg " warnings gathered before error:\n $msg" |
||||
error $errmsg |
||||
} |
||||
|
||||
return $root_dict |
||||
} |
||||
|
||||
#------------------------------------ |
||||
#limit to exec so full punk shell not required in scripts |
||||
proc git_revision {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
# ::kettle::path::revision.git |
||||
do_in_path $path { |
||||
try { |
||||
#git describe will error with 'No names found' if repo has no tags |
||||
#set v [::exec {*}[auto_execok git] describe] |
||||
set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD' |
||||
} on error {e o} { |
||||
set v [lindex [split [dict get $o -errorinfo] \n] 0] |
||||
} |
||||
} |
||||
return [string trim $v] |
||||
} |
||||
proc git_remote {{path {{}}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
do_in_path $path { |
||||
try { |
||||
#git describe will error with 'No names found' if repo has no tags |
||||
#set v [::exec {*}[auto_execok git] describe] |
||||
set v [::exec {*}[auto_execok git] -remote -v] ;# consider 'git rev-parse --short HEAD' |
||||
} on error {e o} { |
||||
set v [lindex [split [dict get $o -errorinfo] \n] 0] |
||||
} |
||||
} |
||||
return [string trim $v] |
||||
} |
||||
|
||||
proc fossil_revision {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
# ::kettle::path::revision.fossil |
||||
set fossilcmd [auto_execok fossil] |
||||
if {[llength $fossilcmd]} { |
||||
do_in_path $path { |
||||
set info [::exec {*}$fossilcmd info] |
||||
} |
||||
return [lindex [grep {checkout:*} $info] 0 1] |
||||
} else { |
||||
return Unknown |
||||
} |
||||
} |
||||
|
||||
proc fossil_remote {{path {}}} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
# ::kettle::path::revision.fossil |
||||
set fossilcmd [auto_execok fossil] |
||||
if {[llength $fossilcmd]} { |
||||
do_in_path $path { |
||||
set info [::exec {*}$fossilcmd remote ls] |
||||
} |
||||
return [string trim $v] |
||||
} else { |
||||
return Unknown |
||||
} |
||||
} |
||||
#------------------------------------ |
||||
|
||||
proc cksum_path_content {path args} { |
||||
dict set args -cksum_content 1 |
||||
dict set args -cksum_meta 0 |
||||
tailcall cksum_path $path {*}args |
||||
} |
||||
#for full cksum - using tar could reduce number of hashes to be made.. |
||||
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||
#-noperms only available on extraction - so that doesn't help |
||||
#Needs to operate on non-existant paths and return empty string in cksum field |
||||
proc cksum_path {path args} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
set base [file dirname $path] |
||||
set startdir [pwd] |
||||
|
||||
set defaults [list -cksum_content 1 -cksum_meta 1 -cksum_acls 0 -use_tar 1] |
||||
set opts [dict merge $defaults $args] |
||||
if {![file exists $path]} { |
||||
return [list cksum "" opts $opts] |
||||
} |
||||
|
||||
|
||||
|
||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||
if {$opt_cksum_acls} { |
||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||
return |
||||
} |
||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||
if {$opt_cksum_meta} { |
||||
|
||||
} else { |
||||
if {[file type $path] ne "file"} { |
||||
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1" |
||||
return [list error unsupported opts $opts] |
||||
} |
||||
} |
||||
set opt_use_tar [dict get $opts -use_tar] |
||||
if {$opt_use_tar} { |
||||
package require tar ;#from tcllib |
||||
} else { |
||||
if {[file type $path] eq "directory"} { |
||||
puts stderr "cksum_path doesn't yet support -use_tar 0 for folders" |
||||
return [list error unsupported opts $opts] |
||||
} |
||||
} |
||||
|
||||
if {$path eq $base} { |
||||
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||
#This needs fixing for general use.. not necessarily just for project repos |
||||
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||
return [list error unsupported opts $opts] |
||||
} |
||||
set cksum "" |
||||
if {$opt_use_tar} { |
||||
set target [file tail $path] |
||||
set tmplocation [tmpdir] |
||||
set archivename $tmplocation/[tmpfile].tar |
||||
|
||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||
|
||||
#temp emission to stdout.. todo - repl telemetry channel |
||||
puts stdout "cksum_path: creating temporary tar archive at: $archivename .." |
||||
tar::create $archivename $target |
||||
puts stdout "cksum_path: calculating cksum for $target (size [file size $target])..." |
||||
set cksum [crc::cksum -format 0x%X -file $archivename] |
||||
puts stdout "cksum_path: cleaning up.. " |
||||
file delete -force $archivename |
||||
cd $startdir |
||||
|
||||
} else { |
||||
#todo |
||||
if {[file type $path] eq "file"} { |
||||
if {$opt_cksum_meta} { |
||||
return [list error unsupported opts $opts] |
||||
} else { |
||||
set cksum [crc::cksum -format 0x%X -file $path] |
||||
} |
||||
} else { |
||||
error "cksum_path unsupported $opts for path type [file type $path]" |
||||
} |
||||
} |
||||
set result [dict create] |
||||
dict set result cksum $cksum |
||||
dict set result opts $opts |
||||
return $result |
||||
} |
||||
#temporarily cd to workpath to run script - return to correct path even on failure |
||||
proc do_in_path {path script} { |
||||
#from ::kettle::path::in |
||||
set here [pwd] |
||||
try { |
||||
cd $path |
||||
uplevel 1 $script |
||||
} finally { |
||||
cd $here |
||||
} |
||||
} |
||||
proc scanup {path cmd} { |
||||
if {$path eq {}} { set path [pwd] } |
||||
#based on kettle::path::scanup |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
while {1} { |
||||
# Found the proper directory, per the predicate. |
||||
if {[{*}$cmd $path]} { return $path } |
||||
|
||||
# Not found, walk to parent |
||||
set new [file dirname $path] |
||||
|
||||
# Stop when reaching the root. |
||||
if {$new eq $path} { return {} } |
||||
if {$new eq {}} { return {} } |
||||
|
||||
# Ok, truly walk up. |
||||
set path $new |
||||
} |
||||
return {} |
||||
} |
||||
#get content part of content/zip delimited by special \x1a (ctrl-z) char as used in tarjr and kettle::path::c/z |
||||
proc c/z {content} { |
||||
return [lindex [split $content \x1A] 0] |
||||
} |
||||
proc grep {pattern data} { |
||||
set data [string map [list \r\n \n] $data] |
||||
return [lsearch -all -inline -glob [split $data \n] $pattern] |
||||
} |
||||
|
||||
proc rgrep {pattern data} { |
||||
set data [string map [list \r\n \n] $data] |
||||
return [lsearch -all -inline -regexp [split $data \n] $pattern] |
||||
} |
||||
|
||||
proc tmpfile {{prefix tmp_}} { |
||||
#note risk of collision if pregenerating a list of tmpfile names |
||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||
variable tmpfile_counter |
||||
global tcl_platform |
||||
return .punkrepo_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||
} |
||||
|
||||
proc tmpdir {} { |
||||
# Taken from tcllib fileutil. |
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
set problems {} |
||||
|
||||
foreach tmp {TMPDIR TEMP TMP} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} else { |
||||
lappend problems "No environment variable $tmp" |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && |
||||
[file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} elseif { ![file isdirectory $tmp] } { |
||||
lappend problems "Not a directory: $tmp" |
||||
} else { |
||||
lappend problems "Not writable: $tmp" |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||
} |
||||
|
||||
#todo - review |
||||
proc ensure-cleanup {path} { |
||||
#::atexit [lambda {path} { |
||||
#file delete -force $path |
||||
#} [norm $path]] |
||||
|
||||
file delete -force $path |
||||
} |
||||
|
||||
proc path_relative {base dst} { |
||||
#see also kettle |
||||
# Modified copy of ::fileutil::relative (tcllib) |
||||
# Adapted to 8.5 ({*}). |
||||
# |
||||
# Taking two _directory_ paths, a base and a destination, computes the path |
||||
# of the destination relative to the base. |
||||
# |
||||
# Arguments: |
||||
# base The path to make the destination relative to. |
||||
# dst The destination path |
||||
# |
||||
# Results: |
||||
# The path of the destination, relative to the base. |
||||
|
||||
# Ensure that the link to directory 'dst' is properly done relative to |
||||
# the directory 'base'. |
||||
|
||||
if {[file pathtype $base] ne [file pathtype $dst]} { |
||||
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" |
||||
} |
||||
|
||||
set base [norm $base] |
||||
set dst [norm $dst] |
||||
|
||||
set save $dst |
||||
set base [file split $base] |
||||
set dst [file split $dst] |
||||
|
||||
while {[lindex $dst 0] eq [lindex $base 0]} { |
||||
set dst [lrange $dst 1 end] |
||||
set base [lrange $base 1 end] |
||||
if {![llength $dst]} {break} |
||||
} |
||||
|
||||
set dstlen [llength $dst] |
||||
set baselen [llength $base] |
||||
|
||||
if {($dstlen == 0) && ($baselen == 0)} { |
||||
# Cases: |
||||
# (a) base == dst |
||||
|
||||
set dst . |
||||
} else { |
||||
# Cases: |
||||
# (b) base is: base/sub = sub |
||||
# dst is: base = {} |
||||
|
||||
# (c) base is: base = {} |
||||
# dst is: base/sub = sub |
||||
|
||||
while {$baselen > 0} { |
||||
set dst [linsert $dst 0 ..] |
||||
incr baselen -1 |
||||
} |
||||
set dst [file join {*}$dst] |
||||
} |
||||
|
||||
return $dst |
||||
} |
||||
|
||||
#literate-programming style naming for some path tests |
||||
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||
#hence aboveorat vs atorbelow |
||||
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||
proc path_a_above_b {path_a path_b} { |
||||
#stripPath prefix path |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||
} |
||||
proc path_a_aboveorat_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||
} |
||||
proc path_a_at_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||
} |
||||
proc path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc path_a_below_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||
} |
||||
proc path_a_inlinewith_b {path_a path_b} { |
||||
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||
} |
||||
|
||||
#whether path is at and/or below one of the vfs mount points |
||||
#The design should facilitate nested vfs mountpoints |
||||
proc path_vfs_info {filepath} { |
||||
|
||||
} |
||||
|
||||
#file normalize is expensive so this is too |
||||
proc norm {path {platform env}} { |
||||
#kettle::path::norm |
||||
#see also wiki |
||||
#full path normalization |
||||
|
||||
set platform [string tolower $platform] |
||||
if {$platform eq "env"} { |
||||
set platform $::tcl_platform(platform) |
||||
} |
||||
if {$platform eq "windows"} { |
||||
return [file dirname [file normalize [punk::winpath::winpath $path]/__]] |
||||
} else { |
||||
return [file dirname [file normalize $path/__]] |
||||
} |
||||
} |
||||
|
||||
#This taken from kettle::path::strip |
||||
#It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan |
||||
#renamed to better indicate its behaviour |
||||
|
||||
proc path_strip_prefixdepth {path prefix} { |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
[file split [norm $path]] \ |
||||
[llength [file split [norm $prefix]]] \ |
||||
end]] |
||||
} |
||||
#MUCH faster version for absolute path prefix (pre-normalized) |
||||
proc path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
[file split $path] \ |
||||
[llength [file split $prefix]] \ |
||||
end]] |
||||
} |
||||
|
||||
proc fcat {args} { |
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
return [fileutil::cat {*}$args] |
||||
} |
||||
|
||||
set knownopts [list -eofchar -translation -encoding --] |
||||
set last_opt 0 |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set ival [lindex $args $i] |
||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||
if {$ival eq "--"} { |
||||
set last_opt $i |
||||
break |
||||
} else { |
||||
if {$ival in $knownopts} { |
||||
#puts ">known at $i : [lindex $args $i]" |
||||
if {($i % 2) != 0} { |
||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||
} |
||||
incr i |
||||
set last_opt $i |
||||
} else { |
||||
set last_opt [expr {$i - 1}] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set first_non_opt [expr {$last_opt + 1}] |
||||
|
||||
#puts stderr "first_non_opt: $first_non_opt" |
||||
set opts [lrange $args -1 $first_non_opt-1] |
||||
set paths [lrange $args $first_non_opt end] |
||||
if {![llength $paths]} { |
||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||
} |
||||
#puts stderr "opts: $opts paths: $paths" |
||||
set finalpaths [list] |
||||
foreach p $paths { |
||||
if {[punk::winpath::illegalname_test $p]} { |
||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||
} else { |
||||
lappend finalpaths $p |
||||
} |
||||
} |
||||
fileutil::cat {*}$opts {*}$finalpaths |
||||
} |
||||
|
||||
interp alias {} is_fossil {} ::punk::repo::is_fossil |
||||
interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root |
||||
interp alias {} find_fossil {} ::punk::repo::find_fossil |
||||
interp alias {} fossil_revision {} ::punk::repo::fossil_revision |
||||
interp alias {} is_git {} ::punk::repo::is_git |
||||
interp alias {} is_git_root {} ::punk::repo::is_git_root |
||||
interp alias {} find_git {} ::punk::repo::find_git |
||||
interp alias {} git_revision {} ::punk::repo::git_revision |
||||
|
||||
|
||||
interp alias {} gs {} git status -sb |
||||
interp alias {} gr {} ::punk::repo::git_revision |
||||
interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console |
||||
interp alias {} glast {} git log -1 HEAD --stat |
||||
interp alias {} gconf {} git config --global -l |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::repo [namespace eval punk::repo { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,321 @@
|
||||
# -*- 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::winpath 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::winpath { |
||||
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
||||
|
||||
#review - is this intended to be useful/callable on non-windows platforms? |
||||
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||
#review zipfs:// other uri schemes? |
||||
proc winpath {path} { |
||||
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||
# |
||||
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||
# |
||||
#convert /c/etc to C:/etc |
||||
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||
set volumes [file volumes] |
||||
#exclude things like //zipfs:/ |
||||
set driveletters [list] |
||||
foreach v $volumes { |
||||
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||
lappend driveletters $letter |
||||
} |
||||
} |
||||
#puts stderr "->$driveletters" |
||||
|
||||
if {[regexp $re_slash_x_slash $path _ letter]} { |
||||
#upper case appears to be windows canonical form |
||||
set path [string toupper $letter]:/[string range $path 3 end] |
||||
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $path] _ letter]} { |
||||
set path [string toupper $letter]:/[string range $path 7 end] |
||||
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $path] _ letter]} { |
||||
set path [string toupper $letter]:/ |
||||
} elseif {[regexp $re_slash_else $path _ firstpart remainder]} { |
||||
#could be for example /c or /something/users |
||||
if {[string length $firstpart] == 1} { |
||||
set letter $firstpart |
||||
set path [string toupper $letter]:/ |
||||
} else { |
||||
#attempt to use cygpath helper |
||||
if {![catch { |
||||
set cygpath [runout -n cygpath -w $path] ;#! |
||||
set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||
} errM]} { |
||||
set path [string map [list "\\" "/"] $cygpath] |
||||
} else { |
||||
error "Path '$path' does not appear to be in a standard form. For unix-like paths on windows such as /x, x must correspond to a drive letter. Consider installing cygwin's cygpath tool to see if that helps." |
||||
} |
||||
} |
||||
} |
||||
#puts stderr "=> $path" |
||||
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||
# |
||||
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||
#We want it to look at cwd for relative paths.. but we don't consider things like /c/Users to be relative even on windows |
||||
if {![file exists [file dirname $path]]} { |
||||
set path [file normalize $path] |
||||
#may still not exist.. that's ok. |
||||
} |
||||
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||
if {[illegalname_test $path]} { |
||||
set path [illegalname_fix $path] |
||||
} |
||||
|
||||
return $path |
||||
} |
||||
|
||||
proc windir {path} { |
||||
if {$path eq "~"} { |
||||
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||
return ~/.. |
||||
} |
||||
return [file dirname [winpath $path]] |
||||
} |
||||
|
||||
#REVIEW high-coupling |
||||
proc cdwin {path} { |
||||
set path [winpath $path] |
||||
if {$::repl::running} { |
||||
repl::term::set_console_title $path |
||||
} |
||||
cd $path |
||||
} |
||||
proc cdwindir {path} { |
||||
set path [winpath $path] |
||||
if {$::repl::running} { |
||||
repl::term::set_console_title $path |
||||
} |
||||
cd [file dirname $path] |
||||
} |
||||
|
||||
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||
proc is_unc_path {path} { |
||||
set path [string map [list \\ /] $path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string first "//" $path] == 0} { |
||||
#check for "Dos device path" syntax |
||||
if {[string range $path 0 3] in [list "//?/" "//./"]} { |
||||
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
||||
if {[string range $path 4 6] eq "UNC"} { |
||||
return 1 |
||||
} else { |
||||
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
||||
return 0 |
||||
} |
||||
} else { |
||||
#leading double slash and not dos device path syntax |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
||||
proc is_unc_path_plain {path} { |
||||
if {[is_unc_path $path]} { |
||||
if {![is_dos_device_path]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#'file attributes', and therefor this operation, is expensive (on windows at least) |
||||
proc pwdshortname {{path {}}} { |
||||
if {![string length $path]} { |
||||
set path [pwd] |
||||
} else { |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
} |
||||
return [dict get [file attributes $path] -shortname] |
||||
} |
||||
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
||||
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
||||
proc is_dos_device_path {path} { |
||||
set path [string map [list \\ /] $path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string range $path 0 3] in [list "//?/" "//./"]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc strip_dos_device_prefix {path} { |
||||
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
||||
#(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) |
||||
if {[is_unc_path $path]} { |
||||
return [strip_unc_path_prefix $path] |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
return [string range $path 4 end] |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
proc strip_unc_path_prefix {path} { |
||||
if {[is_unc_path $path]} { |
||||
#//?/UNC/server/etc |
||||
return [string range $path 7 end] |
||||
} elseif {is_unc_path_plain $path} { |
||||
#plain unc //server |
||||
return [string range $path 2 end] |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
#we don't validate that path is actually illegal because we don't know the full range of such names. |
||||
#The caller can apply this to any path. |
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||
proc illegalname_fix {path} { |
||||
#don't add extra dos device path syntax protection-prefix if already done |
||||
if {[is_unc_path $path]} { |
||||
error "illegalname_fix called on UNC path $path - unable to process" |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
#we may have appended |
||||
return $path |
||||
} |
||||
|
||||
|
||||
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
||||
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
||||
#(but mapped drive to same path will work) |
||||
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
||||
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
||||
if {[is_unc_path $path]} { |
||||
set err "" |
||||
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
||||
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
||||
error $err |
||||
} |
||||
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
||||
if {[file pathtype $path] eq "absolute"} { |
||||
if {$path eq "~"} { |
||||
# non-normalized ~ is classified as absolute |
||||
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
||||
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
||||
# unlikely this fix will be called on a plain tilde anyway |
||||
return $path |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
} else { |
||||
#set fullpath [file normalize $path] ;#very slow on windows |
||||
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
||||
if {[string range $path 0 1] eq "./"} { |
||||
set path [string range $path 2 end] |
||||
} |
||||
set fullpath [file join [pwd] $path] |
||||
} |
||||
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing |
||||
# and to send the string that follows it straight to the file system. |
||||
set protect "\\\\?\\" ;# value is: \\?\ prefix |
||||
set protect2 "//?/" ;#file normalize may do this - it still works |
||||
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
||||
|
||||
|
||||
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
||||
return ${protect2}$fullpath |
||||
} |
||||
|
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
||||
proc illegalname_test {path} { |
||||
#first test if already protected - we return false even if the file would be illegal without the protection! |
||||
if {[is_dos_device_path $path]} { |
||||
return 0 |
||||
} |
||||
#we need to exclude things like path/.. path/. |
||||
foreach seg [file split $path] { |
||||
if {$seg in [list . ..]} { |
||||
#review - what if there is a folder or file that actually has a name such as . or .. ? |
||||
#unlikely in normal use - but could done deliberately for bad reasons? |
||||
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
||||
# |
||||
#/./ /../ segments don't require protection - keep checking. |
||||
continue |
||||
} |
||||
|
||||
#only check for actual space as other whitespace seems to work without being stripped |
||||
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
||||
if {[string index $seg end] in [list " " "."]} { |
||||
#windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) |
||||
return 1 |
||||
} |
||||
} |
||||
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) |
||||
#- they seem to be readable from cmd and tclsh as is. |
||||
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt |
||||
#(at least with encoding system utf-8) |
||||
|
||||
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax |
||||
return 0 |
||||
} |
||||
|
||||
|
||||
#---------------------------------------------- |
||||
#leave the winpath related aliases available on all platforms |
||||
interp alias {} cdwin {} punk::winpath::cdwin |
||||
interp alias {} cdwindir {} punk::winpath::cdwindir |
||||
interp alias {} winpath {} punk::winpath::winpath |
||||
interp alias {} windir {} punk::winpath::windir |
||||
#---------------------------------------------- |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::winpath [namespace eval punk::winpath { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,24 @@
|
||||
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||
It could include other files necessary for this process. |
||||
|
||||
The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. |
||||
|
||||
The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. |
||||
The modules can be your own, or 3rd party such as individual items from tcllib. |
||||
|
||||
You can copy modules from a running punk shell to this location using the pmix command. |
||||
|
||||
e.g |
||||
>pmix visible_lib_copy_to_modulefolder some::module::lib bootsupport |
||||
|
||||
The pmix command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. |
||||
|
||||
e.g the result might be a file such as |
||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||
|
||||
The originating library may not yet be in .tm form. |
||||
You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. |
||||
|
||||
Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. |
||||
|
||||
|
||||
Loading…
Reference in new issue