diff --git a/src/bootsupport/README.md b/src/bootsupport/README.md new file mode 100644 index 00000000..89dc0de9 --- /dev/null +++ b/src/bootsupport/README.md @@ -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 +/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. + + diff --git a/src/bootsupport/cksum-1.1.4.tm b/src/bootsupport/cksum-1.1.4.tm new file mode 100644 index 00000000..6ff4e513 --- /dev/null +++ b/src/bootsupport/cksum-1.1.4.tm @@ -0,0 +1,200 @@ +# cksum.tcl - Copyright (C) 2002 Pat Thoyts +# +# 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: diff --git a/src/bootsupport/fileutil-1.16.1.tm b/src/bootsupport/fileutil-1.16.1.tm new file mode 100644 index 00000000..cb9c6274 --- /dev/null +++ b/src/bootsupport/fileutil-1.16.1.tm @@ -0,0 +1,2311 @@ +# fileutil.tcl -- +# +# Tcl implementations of standard UNIX utilities. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2002 by Phil Ehrens (fileType) +# Copyright (c) 2005-2013 by Andreas Kupries +# +# 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 +package require cmdline +package provide fileutil 1.16.1 + +namespace eval ::fileutil { + namespace export \ + grep find findByPattern cat touch foreachLine \ + jail stripPwd stripN stripPath tempdir tempfile \ + install fileType writeFile appendToFile \ + insertIntoFile removeFromFile replaceInFile \ + updateInPlace test tempdirReset maketempdir +} + +# ::fileutil::grep -- +# +# Implementation of grep. Adapted from the Tcler's Wiki. +# +# Arguments: +# pattern pattern to search for. +# files list of files to search; if NULL, uses stdin. +# +# Results: +# results list of matches + +proc ::fileutil::grep {pattern {files {}}} { + set result [list] + if {[llength $files] == 0} { + # read from stdin + set lnum 0 + while {[gets stdin line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${lnum}:${line}" + } + } + } else { + foreach filename $files { + set file [open $filename r] + set lnum 0 + while {[gets $file line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${filename}:${lnum}:${line}" + } + } + close $file + } + } + return $result +} + +# ::fileutil::find == + +# Below is the core command, which is portable across Tcl versions and +# platforms. Functionality which is common or platform and/or Tcl +# version dependent, has been factored out/ encapsulated into separate +# (small) commands. Only these commands may have multiple variant +# implementations per the available features of the Tcl core / +# platform. +# +# These commands are +# +# FADD - Add path result, performs filtering. Portable! +# GLOBF - Return files in a directory. Tcl version/platform dependent. +# GLOBD - Return dirs in a directory. Tcl version/platform dependent. +# ACCESS - Check directory for accessibility. Tcl version/platform dependent. + +proc ::fileutil::find {{basedir .} {filtercmd {}}} { + set result {} + set filt [string length $filtercmd] + + if {[file isfile $basedir]} { + # The base is a file, and therefore only possible result, + # modulo filtering. + + FADD $basedir + + } elseif {[file isdirectory $basedir]} { + # For a directory as base we do an iterative recursion through + # the directory hierarchy starting at the base. We use a queue + # (Tcl list) of directories we have to check. We access it by + # index, and stop when we have reached beyond the end of the + # list. This is faster than removing elements from the be- + # ginning of the list, as that entails copying down a possibly + # large list of directories, making it O(n*n). The index is + # faster, O(n), at the expense of memory. Nothing is deleted + # from the list until we have processed all directories in the + # hierarchy. + # + # We scan each directory at least twice. First for files, then + # for directories. The scans may internally make several + # passes (normal vs hidden files). + # + # Looped directory structures due to symbolic links are + # handled by _fully_ normalizing directory paths and checking + # if we encountered the normalized form before. The array + # 'known' is our cache where we record the known normalized + # paths. + + set pending [list $basedir] + set at 0 + array set parent {} + array set norm {} + Enter {} $basedir + + while {$at < [llength $pending]} { + # Get next directory not yet processed. + set current [lindex $pending $at] + incr at + + # Is the directory accessible? Continue if not. + ACCESS $current + + # Files first, then the sub-directories ... + + foreach f [GLOBF $current] { FADD $f } + + foreach f [GLOBD $current] { + # Ignore current and parent directory, this needs + # explicit filtering outside of the filter command. + if { + [string equal [file tail $f] "."] || + [string equal [file tail $f] ".."] + } continue + + # Extend result, modulo filtering. + FADD $f + + # Detection of symlink loops via a portable path + # normalization computing a canonical form of the path + # followed by a check if that canonical form was + # encountered before. If ok, record directory for + # expansion in future iterations. + + Enter $current $f + if {[Cycle $f]} continue + + lappend pending $f + } + } + } else { + return -code error "$basedir does not exist" + } + + return $result +} + +proc ::fileutil::Enter {parent path} { + upvar 1 parent _parent norm _norm + set _parent($path) $parent + set _norm($path) [fullnormalize $path] + return +} + +proc ::fileutil::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 +} + +# Helper command for fileutil::find. Performs the filtering of the +# result per a filter command for the candidates found by the +# traversal core, see above. This is portable. + +proc ::fileutil::FADD {filename} { + upvar 1 result result filt filt filtercmd filtercmd + if {!$filt} { + lappend result $filename + return + } + + set here [pwd] + cd [file dirname $filename] + + if {[uplevel 2 [linsert $filtercmd end [file tail $filename]]]} { + lappend result $filename + } + + cd $here + return +} + +# The next three helper commands for fileutil::find depend strongly on +# the version of Tcl, and partially on the platform. + +# 1. The -directory and -types switches were added to glob in Tcl +# 8.3. This means that we have to emulate them for Tcl 8.2. +# +# 2. 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. +# +# Note further that we have to handle broken links on our own. They +# are not returned by glob yet we want them in the output. +# +# 3. 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::ACCESS {args} {} + + proc ::fileutil::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::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::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::ACCESS {args} {} + + proc ::fileutil::GLOBF {current} { + 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::GLOBD {current} { + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + } + +} elseif {[package vsatisfies [package present Tcl] 8.3]} { + # 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::ACCESS {current} { + if {[catch { + set h [pwd] ; cd $current ; cd $h + }]} {return -code continue} + return + } + + if {[string equal $::tcl_platform(platform) windows]} { + proc ::fileutil::GLOBF {current} { + concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]] + } + } else { + proc ::fileutil::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::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 + } +} else { + # 8.2. + # (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required. + + proc ::fileutil::ACCESS {args} {} + + if {[string equal $::tcl_platform(platform) windows]} { + # Hidden files cannot be handled by Tcl 8.2 in glob. We have + # to punt. + + proc ::fileutil::GLOBF {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *]] { + if {[file isdirectory $x]} continue + if {[catch {file type $x}]} continue + # We have now accepted files, links to files, and + # broken links. We may also have accepted a directory + # as well, if the current path was inaccessible. This + # however will cause 'file type' to throw an error, + # hence the second check. + lappend res $x + } + return $res + } + + proc ::fileutil::GLOBD {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *]] { + if {![file isdirectory $x]} continue + lappend res $x + } + return $res + } + } else { + # Hidden files on Unix are dot-files. We emulate the switch + # '-types hidden' by using an explicit pattern. + + proc ::fileutil::GLOBF {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] { + if {[file isdirectory $x]} continue + if {[catch {file type $x}]} continue + # We have now accepted files, links to files, and + # broken links. We may also have accepted a directory + # as well, if the current path was inaccessible. This + # however will cause 'file type' to throw an error, + # hence the second check. + + lappend res $x + } + return $res + } + + proc ::fileutil::GLOBD {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- $current/* [file join $current .*]] { + if {![file isdirectory $x]} continue + lappend res $x + } + return $res + } + } +} + +# ::fileutil::findByPattern -- +# +# Specialization of find. Finds files based on their names, +# which have to match the specified patterns. Options are used +# to specify which type of patterns (regexp-, glob-style) is +# used. +# +# Arguments: +# basedir Directory to start searching from. +# args Options (-glob, -regexp, --) followed by a +# list of patterns to search for. +# +# Results: +# files a list of interesting files. + +proc ::fileutil::findByPattern {basedir args} { + set pos 0 + set cmd ::fileutil::FindGlob + foreach a $args { + incr pos + switch -glob -- $a { + -- {break} + -regexp {set cmd ::fileutil::FindRegexp} + -glob {set cmd ::fileutil::FindGlob} + -* {return -code error "Unknown option $a"} + default {incr pos -1 ; break} + } + } + + set args [lrange $args $pos end] + + if {[llength $args] != 1} { + set pname [lindex [info level 0] 0] + return -code error \ + "wrong#args for \"$pname\", should be\ + \"$pname basedir ?-regexp|-glob? ?--? patterns\"" + } + + set patterns [lindex $args 0] + return [find $basedir [list $cmd $patterns]] +} + + +# ::fileutil::FindRegexp -- +# +# Internal helper. Filter command used by 'findByPattern' +# to match files based on regular expressions. +# +# Arguments: +# patterns List of regular expressions to match against. +# filename Name of the file to match against the patterns. +# Results: +# interesting A boolean flag. Set to true if the file +# matches at least one of the patterns. + +proc ::fileutil::FindRegexp {patterns filename} { + foreach p $patterns { + if {[regexp -- $p $filename]} { + return 1 + } + } + return 0 +} + +# ::fileutil::FindGlob -- +# +# Internal helper. Filter command used by 'findByPattern' +# to match files based on glob expressions. +# +# Arguments: +# patterns List of glob expressions to match against. +# filename Name of the file to match against the patterns. +# Results: +# interesting A boolean flag. Set to true if the file +# matches at least one of the patterns. + +proc ::fileutil::FindGlob {patterns filename} { + foreach p $patterns { + if {[string match $p $filename]} { + return 1 + } + } + return 0 +} + +# ::fileutil::stripPwd -- +# +# If the specified path references is a path in [pwd] (or [pwd] itself) it +# is made relative to [pwd]. Otherwise it is left unchanged. +# In the case of [pwd] itself the result is the string '.'. +# +# Arguments: +# path path to modify +# +# Results: +# path The (possibly) modified path. + +proc ::fileutil::stripPwd {path} { + + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set pwd [pwd] + if {[string equal $pwd $path]} { + return "." + } + + set pwd [file split $pwd] + set npath [file split $path] + + if {[string match ${pwd}* $npath]} { + set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]] + } + return $path +} + +# ::fileutil::stripN -- +# +# Removes N elements from the beginning of the path. +# +# Arguments: +# path path to modify +# n number of elements to strip +# +# Results: +# path The modified path + +proc ::fileutil::stripN {path n} { + set path [file split $path] + if {$n >= [llength $path]} { + return {} + } else { + return [eval [linsert [lrange $path $n end] 0 file join]] + } +} + +# ::fileutil::stripPath -- +# +# If the specified path references/is a path in prefix (or prefix itself) it +# is made relative to prefix. Otherwise it is left unchanged. +# In the case of it being prefix itself the result is the string '.'. +# +# Arguments: +# prefix prefix to strip from the path. +# path path to modify +# +# Results: +# path The (possibly) modified path. + +if {[string equal $tcl_platform(platform) windows]} { + + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc ::fileutil::stripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } +} else { + proc ::fileutil::stripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } +} + +# ::fileutil::jail -- +# +# Ensures that the input path 'filename' stays within the +# directory 'jail'. In this way it prevents user-supplied paths +# from escaping the jail. +# +# Arguments: +# jail The path to the directory the other must +# not escape from. +# filename The path to prevent from escaping. +# +# Results: +# path The (possibly) modified path surely within +# the confines of the jail. + +proc fileutil::jail {jail filename} { + if {![string equal [file pathtype $filename] "relative"]} { + # Although the path to check is absolute (or volumerelative on + # windows) we cannot perform a simple prefix check to see if + # the path is inside the jail or not. We have to normalize + # both path and jail and then we can check. If the path is + # outside we make the original path relative and prefix it + # with the original jail. We do make the jail pseudo-absolute + # by prefixing it with the current working directory for that. + + # Normalized jail. Fully resolved sym links, if any. Our main + # complication is that normalize does not resolve symlinks in the + # last component of the path given to it, so we add a bogus + # component, resolve, and then strip it off again. That is why the + # code is so large and long. + + set njail [eval [list file join] [lrange [file split \ + [Normalize [file join $jail __dummy__]]] 0 end-1]] + + # Normalize filename. Fully resolved sym links, if + # any. S.a. for an explanation of the complication. + + set nfile [eval [list file join] [lrange [file split \ + [Normalize [file join $filename __dummy__]]] 0 end-1]] + + if {[string match ${njail}* $nfile]} { + return $filename + } + + # Outside the jail, put it inside. ... We normalize the input + # path lexically for this, to prevent escapes still lurking in + # the original path. (We cannot use the normalized path, + # symlinks may have bent it out of shape in unrecognizable ways. + + return [eval [linsert [lrange [file split \ + [lexnormalize $filename]] 1 end] 0 file join [pwd] $jail]] + } else { + # The path is relative, consider it as outside + # implicitly. Normalize it lexically! to prevent escapes, then + # put the jail in front, use PWD to ensure absoluteness. + + return [eval [linsert [file split [lexnormalize $filename]] 0 \ + file join [pwd] $jail]] + } +} + + +# ::fileutil::test -- +# +# Simple API to testing various properties of +# a path (read, write, file/dir, existence) +# +# Arguments: +# path path to test +# codes names of the properties to test +# msgvar Name of variable to leave an error +# message in. Optional. +# label Label for error message, optional +# +# Results: +# ok boolean flag, set if the path passes +# all tests. + +namespace eval ::fileutil { + variable test + array set test { + read {readable {Read access is denied}} + write {writable {Write access is denied}} + exec {executable {Is not executable}} + exists {exists {Does not exist}} + file {isfile {Is not a file}} + dir {isdirectory {Is not a directory}} + } +} + +proc ::fileutil::test {path codes {msgvar {}} {label {}}} { + variable test + + if {[string equal $msgvar ""]} { + set msg "" + } else { + upvar 1 $msgvar msg + } + + if {![string equal $label ""]} {append label { }} + + if {![regexp {^(read|write|exec|exists|file|dir)} $codes]} { + # Translate single characters into proper codes + set codes [string map { + r read w write e exists x exec f file d dir + } [split $codes {}]] + } + + foreach c $codes { + foreach {cmd text} $test($c) break + if {![file $cmd $path]} { + set msg "$label\"$path\": $text" + return 0 + } + } + + return 1 +} + +# ::fileutil::cat -- +# +# Tcl implementation of the UNIX "cat" command. Returns the contents +# of the specified files. +# +# Arguments: +# args names of the files to read, interspersed with options +# to set encodings, translations, or eofchar. +# +# Results: +# data data read from the file. + +proc ::fileutil::cat {args} { + # Syntax: (?options? file)+ + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + if {![llength $args]} { + # Argument processing stopped with arguments missing. + return -code error \ + "wrong#args: should be\ + [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..." + } + + # We go through the arguments using foreach and keeping track of + # the index we are at. We do not shift the arguments out to the + # left. That is inherently quadratic, copying everything down. + + set opts {} + set mode maybeopt + set channels {} + + foreach a $args { + if {[string equal $mode optarg]} { + lappend opts $a + set mode maybeopt + continue + } elseif {[string equal $mode maybeopt]} { + if {[string match -* $a]} { + switch -exact -- $a { + -encoding - + -translation - + -eofchar { + lappend opts $a + set mode optarg + continue + } + -- { + set mode file + continue + } + default { + return -code error \ + "Bad option \"$a\",\ + expected one of\ + -encoding, -eofchar,\ + or -translation" + } + } + } + # Not an option, but a file. Change mode and fall through. + set mode file + } + # Process file arguments + + if {[string equal $a -]} { + # Stdin reference is special. + + # Test that the current options are all ok. + # For stdin we have to avoid closing it. + + set old [fconfigure stdin] + set fail [catch { + SetOptions stdin $opts + } msg] ; # {} + SetOptions stdin $old + + if {$fail} { + return -code error $msg + } + + lappend channels [list $a $opts 0] + } else { + if {![file exists $a]} { + return -code error "Cannot read file \"$a\", does not exist" + } elseif {![file isfile $a]} { + return -code error "Cannot read file \"$a\", is not a file" + } elseif {![file readable $a]} { + return -code error "Cannot read file \"$a\", read access is denied" + } + + # Test that the current options are all ok. + set c [open $a r] + set fail [catch { + SetOptions $c $opts + } msg] ; # {} + close $c + if {$fail} { + return -code error $msg + } + + lappend channels [list $a $opts [file size $a]] + } + + # We may have more options and files coming after. + set mode maybeopt + } + + if {![string equal $mode maybeopt]} { + # Argument processing stopped with arguments missing. + return -code error \ + "wrong#args: should be\ + [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..." + } + + set data "" + foreach c $channels { + foreach {fname opts size} $c break + + if {[string equal $fname -]} { + set old [fconfigure stdin] + SetOptions stdin $opts + append data [read stdin] + SetOptions stdin $old + continue + } + + set c [open $fname r] + SetOptions $c $opts + + if {$size > 0} { + # Used the [file size] command to get the size, which + # preallocates memory, rather than trying to grow it as + # the read progresses. + append data [read $c $size] + } else { + # if the file has zero bytes it is either empty, or + # something where [file size] reports 0 but the file + # actually has data (like the files in the /proc + # filesystem on Linux). + append data [read $c] + } + close $c + } + + return $data +} + +# ::fileutil::writeFile -- +# +# Write the specified data into the named file, +# creating it if necessary. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to write. +# data The data to write into the file +# +# Results: +# None. + +proc ::fileutil::writeFile {args} { + # Syntax: ?options? file data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec Writable $args opts fname data + + # Now perform the requested operation. + + file mkdir [file dirname $fname] + set c [open $fname w] + SetOptions $c $opts + puts -nonewline $c $data + close $c + return +} + +# ::fileutil::appendToFile -- +# +# Append the specified data at the end of the named file, +# creating it if necessary. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# data The data to extend the file with. +# +# Results: +# None. + +proc ::fileutil::appendToFile {args} { + # Syntax: ?options? file data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec Writable $args opts fname data + + # Now perform the requested operation. + + file mkdir [file dirname $fname] + set c [open $fname a] + SetOptions $c $opts + set at [tell $c] + puts -nonewline $c $data + close $c + return $at +} + +# ::fileutil::insertIntoFile -- +# +# Insert the specified data into the named file, +# creating it if necessary, at the given locaton. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# data The data to extend the file with. +# +# Results: +# None. + +proc ::fileutil::insertIntoFile {args} { + + # Syntax: ?options? file at data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at data + + set max [file size $fname] + CheckLocation $at $max insertion + + if {[string length $data] == 0} { + # Another degenerate case, inserting nothing. + # Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # The degenerate cases of both appending and insertion at the + # beginning of the file allow more optimized implementations of + # the operation. + + if {$at == 0} { + puts -nonewline $o $data + fcopy $c $o + } elseif {$at == $max} { + fcopy $c $o + puts -nonewline $o $data + } else { + fcopy $c $o -size $at + puts -nonewline $o $data + fcopy $c $o + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::removeFromFile -- +# +# Remove n characters from the named file, +# starting at the given locaton. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# at Location to start the removal from. +# n Number of characters to remove. +# +# Results: +# None. + +proc ::fileutil::removeFromFile {args} { + + # Syntax: ?options? file at n + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at n + + set max [file size $fname] + CheckLocation $at $max removal + CheckLength $n $at $max removal + + if {$n == 0} { + # Another degenerate case, removing nothing. + # Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # The degenerate cases of both removal from the beginning or end + # of the file allow more optimized implementations of the + # operation. + + if {$at == 0} { + seek $c $n current + fcopy $c $o + } elseif {($at + $n) == $max} { + fcopy $c $o -size $at + # Nothing further to copy. + } else { + fcopy $c $o -size $at + seek $c $n current + fcopy $c $o + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::replaceInFile -- +# +# Remove n characters from the named file, +# starting at the given locaton, and replace +# it with the given data. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# at Location to start the removal from. +# n Number of characters to remove. +# data The replacement data. +# +# Results: +# None. + +proc ::fileutil::replaceInFile {args} { + + # Syntax: ?options? file at n data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at n data + + set max [file size $fname] + CheckLocation $at $max replacement + CheckLength $n $at $max replacement + + if { + ($n == 0) && + ([string length $data] == 0) + } { + # Another degenerate case, replacing nothing with + # nothing. Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # Check for degenerate cases and handle them separately, + # i.e. strip the no-op parts out of the general implementation. + + if {$at == 0} { + if {$n == 0} { + # Insertion instead of replacement. + + puts -nonewline $o $data + fcopy $c $o + + } elseif {[string length $data] == 0} { + # Removal instead of replacement. + + seek $c $n current + fcopy $c $o + + } else { + # General replacement at front. + + seek $c $n current + puts -nonewline $o $data + fcopy $c $o + } + } elseif {($at + $n) == $max} { + if {$n == 0} { + # Appending instead of replacement + + fcopy $c $o + puts -nonewline $o $data + + } elseif {[string length $data] == 0} { + # Truncating instead of replacement + + fcopy $c $o -size $at + # Nothing further to copy. + + } else { + # General replacement at end + + fcopy $c $o -size $at + puts -nonewline $o $data + } + } else { + if {$n == 0} { + # General insertion. + + fcopy $c $o -size $at + puts -nonewline $o $data + fcopy $c $o + + } elseif {[string length $data] == 0} { + # General removal. + + fcopy $c $o -size $at + seek $c $n current + fcopy $c $o + + } else { + # General replacement. + + fcopy $c $o -size $at + seek $c $n current + puts -nonewline $o $data + fcopy $c $o + } + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::updateInPlace -- +# +# Run command prefix on the contents of the +# file and replace them with the result of +# the command. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# cmd Command prefix to run. +# +# Results: +# None. + +proc ::fileutil::updateInPlace {args} { + # Syntax: ?options? file cmd + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname cmd + + # readFile/cat inlined ... + + set c [open $fname r] + SetOptions $c $opts + set data [read $c] + close $c + + # Transformation. Abort and do not modify the target file if an + # error was raised during this step. + + lappend cmd $data + set code [catch {uplevel 1 $cmd} res] + if {$code} { + return -code $code $res + } + + # writeFile inlined, with careful preservation of old contents + # until we are sure that the write was ok. + + if {[catch { + file rename -force $fname ${fname}.bak + + set o [open $fname w] + SetOptions $o $opts + puts -nonewline $o $res + close $o + + file delete -force ${fname}.bak + } msg]} { + if {[file exists ${fname}.bak]} { + catch { + file rename -force ${fname}.bak $fname + } + return -code error $msg + } + } + return +} + +proc ::fileutil::Writable {fname mv} { + upvar 1 $mv msg + if {[file exists $fname]} { + if {![file isfile $fname]} { + set msg "Cannot use file \"$fname\", is not a file" + return 0 + } elseif {![file writable $fname]} { + set msg "Cannot use file \"$fname\", write access is denied" + return 0 + } + } + return 1 +} + +proc ::fileutil::ReadWritable {fname mv} { + upvar 1 $mv msg + if {![file exists $fname]} { + set msg "Cannot use file \"$fname\", does not exist" + return 0 + } elseif {![file isfile $fname]} { + set msg "Cannot use file \"$fname\", is not a file" + return 0 + } elseif {![file writable $fname]} { + set msg "Cannot use file \"$fname\", write access is denied" + return 0 + } elseif {![file readable $fname]} { + set msg "Cannot use file \"$fname\", read access is denied" + return 0 + } + return 1 +} + +proc ::fileutil::Spec {check alist ov fv args} { + upvar 1 $ov opts $fv fname + + set n [llength $args] ; # Num more args + incr n ; # Count path as well + + set opts {} + set mode maybeopt + + set at 0 + foreach a $alist { + if {[string equal $mode optarg]} { + lappend opts $a + set mode maybeopt + incr at + continue + } elseif {[string equal $mode maybeopt]} { + if {[string match -* $a]} { + switch -exact -- $a { + -encoding - + -translation - + -eofchar { + lappend opts $a + set mode optarg + incr at + continue + } + -- { + # Stop processing. + incr at + break + } + default { + return -code error \ + "Bad option \"$a\",\ + expected one of\ + -encoding, -eofchar,\ + or -translation" + } + } + } + # Not an option, but a file. + # Stop processing. + break + } + } + + if {([llength $alist] - $at) != $n} { + # Argument processing stopped with arguments missing, or too + # many + return -code error \ + "wrong#args: should be\ + [lindex [info level 1] 0] ?-eofchar|-translation|-encoding arg? file $args" + } + + set fname [lindex $alist $at] + incr at + foreach \ + var $args \ + val [lrange $alist $at end] { + upvar 1 $var A + set A $val + } + + # Check given path ... + + if {![eval [linsert $check end $a msg]]} { + return -code error $msg + } + + return +} + +proc ::fileutil::Open2 {fname opts} { + set c [open $fname r] + set t [tempfile] + set o [open $t w] + + SetOptions $c $opts + SetOptions $o $opts + + return [list $c $o $t] +} + +proc ::fileutil::Close2 {f temp in out} { + close $in + close $out + + file copy -force $f ${f}.bak + file rename -force $temp $f + file delete -force ${f}.bak + return +} + +proc ::fileutil::SetOptions {c opts} { + if {![llength $opts]} return + eval [linsert $opts 0 fconfigure $c] + return +} + +proc ::fileutil::CheckLocation {at max label} { + if {![string is integer -strict $at]} { + return -code error \ + "Expected integer but got \"$at\"" + } elseif {$at < 0} { + return -code error \ + "Bad $label point $at, before start of data" + } elseif {$at > $max} { + return -code error \ + "Bad $label point $at, behind end of data" + } +} + +proc ::fileutil::CheckLength {n at max label} { + if {![string is integer -strict $n]} { + return -code error \ + "Expected integer but got \"$n\"" + } elseif {$n < 0} { + return -code error \ + "Bad $label size $n" + } elseif {($at + $n) > $max} { + return -code error \ + "Bad $label size $n, going behind end of data" + } +} + +# ::fileutil::foreachLine -- +# +# Executes a script for every line in a file. +# +# Arguments: +# var name of the variable to contain the lines +# filename name of the file to read. +# cmd The script to execute. +# +# Results: +# None. + +proc ::fileutil::foreachLine {var filename cmd} { + upvar 1 $var line + set fp [open $filename r] + + # -future- Use try/eval from tcllib/control + catch { + set code 0 + set result {} + set return 0 + while {[gets $fp line] >= 0} { + set code [catch {uplevel 1 $cmd} result options] + if {$code == 2} { + set return 1 + set code [dict get $options -code] + break + } elseif {$code != 0 && $code != 4} { + break + } + } + } + close $fp + + if {$return || $code == 1 || $code > 4} { + return -options $options $result + } + return $result +} + +# ::fileutil::touch -- +# +# Tcl implementation of the UNIX "touch" command. +# +# touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ... +# +# Arguments: +# -a change the access time only, unless -m also specified +# -m change the modification time only, unless -a also specified +# -c silently prevent creating a file if it did not previously exist +# -r ref_file use the ref_file's time instead of the current time +# -t time use the specified time instead of the current time +# ("time" is an integer clock value, like [clock seconds]) +# filename ... the files to modify +# +# Results +# None. +# +# Errors: +# Both of "-r" and "-t" cannot be specified. + +if {[package vsatisfies [package provide Tcl] 8.3]} { + namespace eval ::fileutil { + namespace export touch + } + + proc ::fileutil::touch {args} { + # Don't bother catching errors, just let them propagate up + + set options { + {a "set the atime only"} + {m "set the mtime only"} + {c "do not create non-existant files"} + {r.arg "" "use time from ref_file"} + {t.arg -1 "use specified time"} + } + set usage ": [lindex [info level 0] 0]\ + \[options] filename ...\noptions:" + array set params [::cmdline::getoptions args $options $usage] + + # process -a and -m options + set set_atime [set set_mtime "true"] + if { $params(a) && ! $params(m)} {set set_mtime "false"} + if {! $params(a) && $params(m)} {set set_atime "false"} + + # process -r and -t + set has_t [expr {$params(t) != -1}] + set has_r [expr {[string length $params(r)] > 0}] + if {$has_t && $has_r} { + return -code error "Cannot specify both -r and -t" + } elseif {$has_t} { + set atime [set mtime $params(t)] + } elseif {$has_r} { + file stat $params(r) stat + set atime $stat(atime) + set mtime $stat(mtime) + } else { + set atime [set mtime [clock seconds]] + } + + # do it + foreach filename $args { + if {! [file exists $filename]} { + if {$params(c)} {continue} + close [open $filename w] + } + if {$set_atime} {file atime $filename $atime} + if {$set_mtime} {file mtime $filename $mtime} + } + return + } +} + +# ::fileutil::fileType -- +# +# Do some simple heuristics to determine file type. +# +# +# Arguments: +# filename Name of the file to test. +# +# Results +# type Type of the file. May be a list if multiple tests +# are positive (eg, a file could be both a directory +# and a link). In general, the list proceeds from most +# general (eg, binary) to most specific (eg, gif), so +# the full type for a GIF file would be +# "binary graphic gif" +# +# At present, the following types can be detected: +# +# directory +# empty +# binary +# text +# script +# executable [elf, dos, ne, pe] +# binary graphic [gif, jpeg, png, tiff, bitmap, icns] +# ps, eps, pdf +# html +# xml +# message pgp +# compressed [bzip, gzip, zip, tar] +# audio [mpeg, wave] +# gravity_wave_data_frame +# link +# doctools, doctoc, and docidx documentation files. +# + +proc ::fileutil::fileType {filename} { + ;## existence test + if { ! [ file exists $filename ] } { + set err "file not found: '$filename'" + return -code error $err + } + ;## directory test + if { [ file isdirectory $filename ] } { + set type directory + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type + } + ;## empty file test + if { ! [ file size $filename ] } { + set type empty + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type + } + set bin_rx {[\x00-\x08\x0b\x0e-\x1f]} + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + set test [ read $fid 1024 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + if { [ regexp $bin_rx $test ] } { + set type binary + set binary 1 + } else { + set type text + set binary 0 + } + + # SF Tcllib bug [795585]. Allowing whitespace between #! + # and path of script interpreter + + set metakit 0 + + if { [ regexp {^\#\!\s*(\S+)} $test -> terp ] } { + lappend type script $terp + } elseif {([regexp "\\\[manpage_begin " $test] && + !([regexp -- {--- !doctools ---} $test] || [regexp -- "!tcl\.tk//DSL doctools//EN//" $test])) || + ([regexp -- {--- doctools ---} $test] || [regexp -- "tcl\.tk//DSL doctools//EN//" $test])} { + lappend type doctools + } elseif {([regexp "\\\[toc_begin " $test] && + !([regexp -- {--- !doctoc ---} $test] || [regexp -- "!tcl\.tk//DSL doctoc//EN//" $test])) || + ([regexp -- {--- doctoc ---} $test] || [regexp -- "tcl\.tk//DSL doctoc//EN//" $test])} { + lappend type doctoc + } elseif {([regexp "\\\[index_begin " $test] && + !([regexp -- {--- !docidx ---} $test] || [regexp -- "!tcl\.tk//DSL docidx//EN//" $test])) || + ([regexp -- {--- docidx ---} $test] || [regexp -- "tcl\.tk//DSL docidx//EN//" $test])} { + lappend type docidx + } elseif {[regexp -- "tcl\\.tk//DSL diagram//EN//" $test]} { + lappend type tkdiagram + } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } { + lappend type executable elf + } elseif { $binary && [string match "MZ*" $test] } { + if { [scan [string index $test 24] %c] < 64 } { + lappend type executable dos + } else { + binary scan [string range $test 60 61] s next + set sig [string range $test $next [expr {$next + 1}]] + if { $sig == "NE" || $sig == "PE" } { + lappend type executable [string tolower $sig] + } else { + lappend type executable dos + } + } + } elseif { $binary && [string match "SQLite format 3\x00*" $test] } { + lappend type sqlite3 + + # Check for various sqlite-based application file formats. + set appid [string range $test 68 71] + if {$appid eq "\x0f\x05\x51\x12"} { + lappend type fossil-checkout + } elseif {$appid eq "\x0f\x05\x51\x13"} { + lappend type fossil-global-config + } elseif {$appid eq "\x0f\x05\x51\x11"} { + lappend type fossil-repository + } else { + # encode the appid as hex and append that. + binary scan $appid H8 aid + lappend type A$aid + } + + } elseif { $binary && [string match "BZh91AY\&SY*" $test] } { + lappend type compressed bzip + } elseif { $binary && [string match "\x1f\x8b*" $test] } { + lappend type compressed gzip + } elseif { $binary && [string range $test 257 262] == "ustar\x00" } { + lappend type compressed tar + } elseif { $binary && [string match "\x50\x4b\x03\x04*" $test] } { + lappend type compressed zip + } elseif { $binary && [string match "GIF*" $test] } { + lappend type graphic gif + } elseif { $binary && [string match "icns*" $test] } { + lappend type graphic icns bigendian + } elseif { $binary && [string match "snci*" $test] } { + lappend type graphic icns smallendian + } elseif { $binary && [string match "\x89PNG*" $test] } { + lappend type graphic png + } elseif { $binary && [string match "\xFF\xD8\xFF*" $test] } { + binary scan $test x3H2x2a5 marker txt + if { $marker == "e0" && $txt == "JFIF\x00" } { + lappend type graphic jpeg jfif + } elseif { $marker == "e1" && $txt == "Exif\x00" } { + lappend type graphic jpeg exif + } + } elseif { $binary && [string match "MM\x00\**" $test] } { + lappend type graphic tiff + } elseif { $binary && [string match "BM*" $test] && [string range $test 6 9] == "\x00\x00\x00\x00" } { + lappend type graphic bitmap + } elseif { ! $binary && [string match -nocase "*\*" $test] } { + lappend type html + } elseif {[string match "\%PDF\-*" $test] } { + lappend type pdf + } elseif { [string match "\%\!PS\-*" $test] } { + lappend type ps + if { [string match "* EPSF\-*" $test] } { + lappend type eps + } + } elseif { [string match -nocase "*\<\?xml*" $test] } { + lappend type xml + if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } { + lappend type $doctype + } + } elseif { [string match {*BEGIN PGP MESSAGE*} $test] } { + lappend type message pgp + } elseif { $binary && [string match {IGWD*} $test] } { + lappend type gravity_wave_data_frame + } elseif {[string match "JL\x1a\x00*" $test] && ([file size $filename] >= 27)} { + lappend type metakit smallendian + set metakit 1 + } elseif {[string match "LJ\x1a\x00*" $test] && ([file size $filename] >= 27)} { + lappend type metakit bigendian + set metakit 1 + } elseif { $binary && [string match "RIFF*" $test] && [string range $test 8 11] == "WAVE" } { + lappend type audio wave + } elseif { $binary && [string match "ID3*" $test] } { + lappend type audio mpeg + } elseif { $binary && [binary scan $test S tmp] && [expr {$tmp & 0xFFE0}] == 65504 } { + lappend type audio mpeg + } + + # Additional checks of file contents at the end of the file, + # possibly pointing into the middle too (attached metakit, + # attached zip). + + ## Metakit File format: http://www.equi4.com/metakit/metakit-ff.html + ## Metakit database attached ? ## + + if {!$metakit && ([file size $filename] >= 27)} { + # The offsets in the footer are in always bigendian format + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + seek $fid -16 end + set test [ read $fid 16 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + binary scan $test IIII __ hdroffset __ __ + set hdroffset [expr {[file size $filename] - 16 - $hdroffset}] + + # Further checks iff the offset is actually inside the file. + + if {($hdroffset >= 0) && ($hdroffset < [file size $filename])} { + # Seek to the specified location and try to match a metakit header + # at this location. + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + seek $fid $hdroffset start + set test [ read $fid 16 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + if {[string match "JL\x1a\x00*" $test]} { + lappend type attached metakit smallendian + set metakit 1 + } elseif {[string match "LJ\x1a\x00*" $test]} { + lappend type attached metakit bigendian + set metakit 1 + } + } + } + + ## Zip File Format: http://zziplib.sourceforge.net/zzip-parse.html + ## http://www.pkware.com/products/enterprise/white_papers/appnote.html + + + ;## lastly, is it a link? + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type +} + +# ::fileutil::tempdir -- +# +# Return the correct directory to use for temporary files. +# Python attempts this sequence, which seems logical: +# +# 1. The directory named by the `TMPDIR' environment variable. +# +# 2. The directory named by the `TEMP' environment variable. +# +# 3. The directory named by the `TMP' environment variable. +# +# 4. A platform-specific location: +# * On Macintosh, the `Temporary Items' folder. +# +# * On Windows, the directories `C:\\TEMP', `C:\\TMP', +# `\\TEMP', and `\\TMP', in that order. +# +# * On all other platforms, the directories `/tmp', +# `/var/tmp', and `/usr/tmp', in that order. +# +# 5. As a last resort, the current working directory. +# +# The code here also does +# +# 0. The directory set by invoking tempdir with an argument. +# If this is present it is used exclusively. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# The directory for temporary files. + +proc ::fileutil::tempdir {args} { + if {[llength $args] > 1} { + return -code error {wrong#args: should be "::fileutil::tempdir ?path?"} + } elseif {[llength $args] == 1} { + variable tempdir [lindex $args 0] + variable tempdirSet 1 + return + } + return [Normalize [TempDir]] +} + +proc ::fileutil::tempdirReset {} { + variable tempdir {} + variable tempdirSet 0 + return +} + +proc ::fileutil::TempDir {} { + global tcl_platform env + variable tempdir + variable tempdirSet + + set attempdirs [list] + set problems {} + + if {$tempdirSet} { + lappend attempdirs $tempdir + lappend problems {User/Application specified tempdir} + } else { + 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 $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]" +} + +namespace eval ::fileutil { + variable tempdir {} + variable tempdirSet 0 +} + +# ::fileutil::maketempdir -- + +proc ::fileutil::maketempdir {args} { + return [Normalize [MakeTempDir $args]] +} + +proc ::fileutil::MakeTempDir {config} { + # Setup of default configuration. + array set options {} + set options(-suffix) "" + set options(-prefix) "tmp" + set options(-dir) [tempdir] + + # TODO: Check for and reject options not in -suffix, -prefix, -dir + # Merge user configuration, overwrite defaults. + array set options $config + + # See also "tempfile" below. Could be shareable internal configuration. + set chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 10 + set maxtries 10 + + for {set i 0} {$i < $maxtries} {incr i} { + # Build up the candidate name. See also "tempfile". + set directory_name $options(-prefix) + for {set j 0} {$j < $nrand_chars} {incr j} { + append directory_name \ + [string index $chars [expr {int(rand() * 62)}]] + } + append directory_name $options(-suffix) + set path [file join $options(-dir) $directory_name] + + # Try to create. Try again if already exists, or trouble + # with creation and setting of perms. + # + # Note: The last looks as if it is able to leave partial + # directories behind (created, trouble with perms). But + # deleting ... Might pull the rug out from somebody else. + + if {[file exists $path]} continue + if {[catch { + file mkdir $path + if {$::tcl_platform(platform) eq "unix"} { + file attributes $path -permissions 0700 + } + }]} continue + + return $path + } + return -code error "Failed to find an unused temporary directory name" +} + +# ::fileutil::tempfile -- +# +# generate a temporary file name suitable for writing to +# the file name will be unique, writable and will be in the +# appropriate system specific temp directory +# Code taken from http://mini.net/tcl/772 attributed to +# Igor Volobouev and anon. +# +# Arguments: +# prefix - a prefix for the filename, p +# Results: +# returns a file name +# + +proc ::fileutil::tempfile {{prefix {}}} { + return [Normalize [TempFile $prefix]] +} + +proc ::fileutil::TempFile {prefix} { + set tmpdir [tempdir] + + set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + set nrand_chars 10 + set maxtries 10 + set access [list RDWR CREAT EXCL] + set permission 0600 + set channel "" + set checked_dir_writable 0 + + for {set i 0} {$i < $maxtries} {incr i} { + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars \ + [expr {int(rand()*62)}]] + } + set newname [file join $tmpdir $newname] + + if {[catch {open $newname $access $permission} channel]} { + if {!$checked_dir_writable} { + set dirname [file dirname $newname] + if {![file writable $dirname]} { + return -code error "Directory $dirname is not writable" + } + set checked_dir_writable 1 + } + } else { + # Success + close $channel + return $newname + } + + } + if {[string compare $channel ""]} { + return -code error "Failed to open a temporary file: $channel" + } else { + return -code error "Failed to find an unused temporary file name" + } +} + +# ::fileutil::install -- +# +# Tcl version of the 'install' command, which copies files from +# one places to another and also optionally sets some attributes +# such as group, owner, and permissions. +# +# Arguments: +# -m Change the file permissions to the specified +# value. Valid arguments are those accepted by +# file attributes -permissions +# +# Results: +# None. + +# TODO - add options for group/owner manipulation. + +proc ::fileutil::install {args} { + set options { + {m.arg "" "Set permission mode"} + } + set usage ": [lindex [info level 0] 0]\ +\[options] source destination \noptions:" + array set params [::cmdline::getoptions args $options $usage] + # Args should now just be the source and destination. + if { [llength $args] < 2 } { + return -code error $usage + } + set src [lindex $args 0] + set dst [lindex $args 1] + file copy -force $src $dst + if { $params(m) != "" } { + set targets [::fileutil::find $dst] + foreach fl $targets { + file attributes $fl -permissions $params(m) + } + } +} + +# ### ### ### ######### ######### ######### + +proc ::fileutil::lexnormalize {sp} { + set spx [file split $sp] + + # Resolution of embedded relative modifiers (., and ..). + + if { + ([lsearch -exact $spx . ] < 0) && + ([lsearch -exact $spx ..] < 0) + } { + # Quick path out if there are no relative modifiers + return $sp + } + + set absolute [expr {![string equal [file pathtype $sp] relative]}] + # A volumerelative path counts as absolute for our purposes. + + set sp $spx + set np {} + set noskip 1 + + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if { + ($absolute && ([llength $np] > 1)) || + (!$absolute && ([llength $np] >= 1)) + } { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. + lappend np $ele + } + } + if {[llength $np] > 0} { + return [eval [linsert $np 0 file join]] + # 8.5: return [file join {*}$np] + } + return {} +} + +# ### ### ### ######### ######### ######### +## Forward compatibility. Some routines require path normalization, +## something we have supported by the builtin 'file' only since Tcl +## 8.4. For versions of Tcl before that, to be supported by the +## module, we implement a normalizer in Tcl itself. Slow, but working. + +if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Pre 8.4. We do not have 'file normalize'. We create an + # approximation for it based on earlier commands. + + # ... Hm. This is lexical normalization. It does not resolve + # symlinks in the path to their origin. + + proc ::fileutil::Normalize {sp} { + set sp [file split $sp] + + # Conversion of the incoming path to absolute. + if {[string equal [file pathtype [lindex $sp 0]] "relative"]} { + set sp [file split [eval [list file join [pwd]] $sp]] + } + + # Resolution of symlink components, and embedded relative + # modifiers (., and ..). + + set np {} + set noskip 1 + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if {[llength $np] > 1} { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. If it is not the last component + # then check if the combination is a symlink, and if + # yes, resolve it. + + lappend np $ele + + if {!$islast && $noskip} { + # The flag 'noskip' is technically not required, + # just 'file exists'. However if a path P does not + # exist, then all longer paths starting with P can + # not exist either, and using the flag to store + # this knowledge then saves us a number of + # unnecessary stat calls. IOW this a performance + # optimization. + + set p [eval file join $np] + set noskip [file exists $p] + if {$noskip} { + if {[string equal link [file type $p]]} { + set dst [file readlink $p] + + # We always push the destination in front of + # the source path (in expanded form). So that + # we handle .., .'s, and symlinks inside of + # this path as well. An absolute path clears + # the result, a relative one just removes the + # last, now resolved component. + + set sp [eval [linsert [file split $dst] 0 linsert $sp 0]] + + if {![string equal relative [file pathtype $dst]]} { + # Absolute|volrelative destination, clear + # result, we have to start over. + set np {} + } else { + # Relative link, just remove the resolved + # component again. + set np [lrange $np 0 end-1] + } + } + } + } + } + } + if {[llength $np] > 0} { + return [eval file join $np] + } + return {} + } +} else { + proc ::fileutil::Normalize {sp} { + file normalize $sp + } +} + +# ::fileutil::relative -- +# +# 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. + +proc ::fileutil::relative {base dst} { + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + if {![string equal [file pathtype $base] [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 [lexnormalize [file join [pwd] $base]] + set dst [lexnormalize [file join [pwd] $dst]] + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[string equal [lindex $dst 0] [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 + } + # 8.5: set dst [file join {*}$dst] + set dst [eval [linsert $dst 0 file join]] + } + + return $dst +} + +# ::fileutil::relativeUrl -- +# +# Taking two _file_ paths, a base and a destination, computes the path +# of the destination relative to the base, from the inside of the base. +# +# This is how a browser resolves relative links in a file, hence the +# url in the command name. +# +# Arguments: +# base The file path to make the destination relative to. +# dst The destination file path +# +# Results: +# The path of the destination file, relative to the base file. + +proc ::fileutil::relativeUrl {base dst} { + # Like 'relative', but for links from _inside_ a file to a + # different file. + + if {![string equal [file pathtype $base] [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 [lexnormalize [file join [pwd] $base]] + set dst [lexnormalize [file join [pwd] $dst]] + + set basedir [file dirname $base] + set dstdir [file dirname $dst] + + set dstdir [relative $basedir $dstdir] + + # dstdir == '.' on input => dstdir output has trailing './'. Strip + # this superfluous segment off. + + if {[string equal $dstdir "."]} { + return [file tail $dst] + } elseif {[string equal [file tail $dstdir] "."]} { + return [file join [file dirname $dstdir] [file tail $dst]] + } else { + return [file join $dstdir [file tail $dst]] + } +} + +# ::fileutil::fullnormalize -- +# +# Normalizes a path completely. I.e. a symlink in the last +# element is resolved as well, not only symlinks in the higher +# elements. +# +# Arguments: +# path The path to normalize +# +# Results: +# The input path with all symlinks resolved. + +proc ::fileutil::fullnormalize {path} { + # When encountering symlinks in a file copy operation Tcl copies + # the link, not the contents of the file it references. There are + # situations there this is not acceptable. For these this command + # resolves all symbolic links in the path, including in the last + # element of the path. A "file copy" using the return value of + # this command copies an actual file, it will not encounter + # symlinks. + + # BUG / WORKAROUND. Using the / instead of the join seems to work + # around a bug in the path handling on windows which can break the + # core 'file normalize' for symbolic links. This was exposed by + # the find testsuite which could not reproduced outside. I believe + # that there is some deep path bug in the core triggered under + # special circumstances. Use of / likely forces a refresh through + # the string rep and so avoids the problem with the path intrep. + + return [file dirname [Normalize $path/__dummy__]] + #return [file dirname [Normalize [file join $path __dummy__]]] +} diff --git a/src/bootsupport/fileutil/decode-0.2.1.tm b/src/bootsupport/fileutil/decode-0.2.1.tm new file mode 100644 index 00000000..02ce8a6a --- /dev/null +++ b/src/bootsupport/fileutil/decode-0.2.1.tm @@ -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 diff --git a/src/bootsupport/fileutil/multi-0.1.tm b/src/bootsupport/fileutil/multi-0.1.tm new file mode 100644 index 00000000..b95a728d --- /dev/null +++ b/src/bootsupport/fileutil/multi-0.1.tm @@ -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 diff --git a/src/bootsupport/fileutil/multi/op-0.5.3.tm b/src/bootsupport/fileutil/multi/op-0.5.3.tm new file mode 100644 index 00000000..9d065198 --- /dev/null +++ b/src/bootsupport/fileutil/multi/op-0.5.3.tm @@ -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 diff --git a/src/bootsupport/fileutil/paths-1.tm b/src/bootsupport/fileutil/paths-1.tm new file mode 100644 index 00000000..e387acf7 --- /dev/null +++ b/src/bootsupport/fileutil/paths-1.tm @@ -0,0 +1,74 @@ +# paths.tcl -- +# +# Manage lists of search paths. +# +# Copyright (c) 2009-2019 Andreas Kupries +# +# 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 diff --git a/src/bootsupport/fileutil/traverse-0.6.tm b/src/bootsupport/fileutil/traverse-0.6.tm new file mode 100644 index 00000000..2f36d109 --- /dev/null +++ b/src/bootsupport/fileutil/traverse-0.6.tm @@ -0,0 +1,504 @@ +# traverse.tcl -- +# +# Directory traversal. +# +# Copyright (c) 2006-2015 by Andreas Kupries +# +# 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 diff --git a/src/bootsupport/punk/du-0.1.0.tm b/src/bootsupport/punk/du-0.1.0.tm new file mode 100644 index 00000000..ad57193c --- /dev/null +++ b/src/bootsupport/punk/du-0.1.0.tm @@ -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 -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 +# @@ 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 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 * punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat words |> list_as_lines * punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines -t t)" \n + append result [exec fossil timeline -n 10 -t t] + + return $result + } + proc fossilize { args} { + #check if project already managed by fossil.. initialise and check in if not. + puts stderr "unimplemented" + } + proc unfossilize {projectname args} { + #remove/archive .fossil + puts stderr "unimplemented" + } + #new project structure - may be dedicated to one module, or contain many. + #create minimal folder structure only by specifying -modules {} + proc new {projectname args} { + lib::validate_projectname $projectname + + + set defaults [list -type plain -empty 0 -force 0 -update 0 -confirm 1 -modules \uFFFF -layout project] ;#todo + set opts [dict merge $defaults $args] + set opt_modules [dict get $opts -modules] + if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { + #if not specified - add a single module matching project name + set opt_modules [list $projectname] + } + set opt_type [dict get $opts -type] + if {$opt_type ni [lib::module_types]} { + error "pmix new error - unknown type '$opt_type' known types: [lib::module_types]" + } + set opt_layout [dict get $opts -layout] + set opt_force [dict get $opts -force] + set opt_update [dict get $opts -update] + set opt_confirm [string tolower [dict get $opts -confirm]] + + set startdir [pwd] + if {[punk::repo::is_project $startdir]} { + puts stderr "Already in a project directory '$startdir' - move to a base location suitable for a new project" + puts stderr " todo: pmix newsubproject" + return + } + + set projectdir $startdir/$projectname + + + set tpldir [lib::mix_templates_dir] + if {[file exists $projectdir] && !($opt_force || $opt_update)} { + puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" + return + } elseif {[file exists $projectdir] && $opt_force} { + puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -force option to overwrite from template" + if {$opt_confirm ni [list 0 no false]} { + puts stdout "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + } elseif {[file exists $projectdir] && $opt_update} { + puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $tpldir/layouts/$opt_layout using -update option to add missing items" + } + + + if {[file exists $startdir/$projectname.fossil]} { + puts stdout "NOTICE: $startdir/$projectname.fossil already exists" + if {!($opt_force || $opt_update)} { + puts stderr "-force 1 or -update 1 not specified - aborting" + return + } + } + + #todo - lookup config for .fossil repo location. For now use current dir. + + if {[punk::repo::is_git $startdir]} { + puts stderr "mix new WARNING: you are already within a git repo based at [punk::repo::find_git $startdir]" + puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" + puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" + puts stdout "Do you want to proceed to create a project based at: $projectdir? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + set is_nested_fossil 0 ;#default assumption + if {[punk::repo::is_fossil $startdir]} { + puts stderr "mix new WARNING: you are already within an open fossil repo based at [punk::repo::find_fossil $startdir] NESTED fossil repository" + if {$opt_confirm ni [list 0 no false]} { + puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" + puts stdout "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolwer [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + set is_nested_fossil 1 + } + } + + puts stdout "Initialising fossil repo: $startdir/$projectname.fossil" + set fossilinit [runx -n fossil init $projectname.fossil -project-name $projectname] + if {[dict get $fossilinit exitcode] != 0} { + puts stderr "fossil init failed:" + puts stderr [dict get $fossilinit stderr] + return + } else { + puts stdout "fossil init result:" + puts stdout [dict get $fossilinit stdout] + } + + file mkdir $projectdir + set layout_dir $tpldir/layouts/$opt_layout + if {$opt_force} { + lib::copy_files_from_source_to_target $layout_dir $projectdir -overwrite ALL-TARGETS + #file copy -force $layout_dir $projectdir + } else { + lib::copy_files_from_source_to_target $layout_dir $projectdir + } + + #expect this in all templates? - todo make these substitutions independent of specific paths and filenames? + set readme_file $projectdir/src/README.md + if {[file exists $readme_file]} { + set fd [open $readme_file r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list %project% $projectname] $data] + set fdout [open $readme_file w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data; close $fdout + } else { + puts stderr "warning: Missing $projectdir/src/README.md" + } + #todo - tag substitutions in src/doc tree + + + cd $projectdir + + foreach m $opt_modules { + newmodule $m -project $projectname -type $opt_type -force $opt_force + } + + #generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation + cd $projectdir/src + Kettle doc + + cd $projectdir + if {![punk::repo::is_fossil_root $projectdir]} { + set first_fossil 1 + #-k = keep. (only modify the manifest file(s)) + if {$is_nested_fossil} { + set fossilopen [runx -n fossil open --nested ../$projectname.fossil -k] + } else { + set fossilopen [runx -n fossil open ../$projectname.fossil -k] + } + if {[dict get $fossilopen exitcode] != 0} { + puts stderr "fossil open in project workdir '$projectdir' FAILED:" + puts stderr [dict get $fossilopen stderr] + return + } else { + puts stdout "fossil open in project workdir '$projectdir' OK:" + puts stdout [dict get $fossilopen stdout] + } + } else { + set first_fossil 0 + } + set fossiladd [runx -n fossil add --dotfiles .] + if {[dict get $fossiladd exitcode] != 0} { + puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" + puts stderr [dict get $fossiladd stderr] + return + } else { + puts stdout "fossil add workfiles in workdir '$projectdir' OK:" + puts stdout [dict get $fossiladd stdout] + } + if {$first_fossil} { + #fossil commit may prompt user for input.. runx runout etc will pause with no prompts + set fossilcommit [run -n fossil commit -m "initial project commit"] + if {[dict get $fossilcommit exitcode] != 0} { + puts stderr "fossil commit in workdir '$projectdir' FAILED" + return + } else { + puts stdout "fossil commit in workdir '$projectdir' OK" + } + } + + puts stdout "-done- project:$projectname projectdir: $projectdir" + } + interp alias {} ::punk::mix::cli::newproject {} ::punk::mix::cli::new + + proc visible_lib_glob {glob} { + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + set matches [lsearch -all -inline [package names] $glob] + set matchinfo [list] + foreach m $matches { + set versions [package versions $m] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + lappend matchinfo [list $m $versions] + } + return [join [lsort $matchinfo] \n] + } + proc visible_lib_copy_to_modulefolder {library modulefoldername args} { + set defaults [list -askme 1] + set opts [dict merge $defaults $args] + set opt_askme [dict get $opts -askme] + + if {[catch {package require natsort}]} { + set has_natsort 0 + } else { + set has_natsort 1 + } + + if {[file pathtype $modulefoldername] eq "absolute"} { + if {![file exists $modulefoldername]} { + error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use /src/modules" + } + #use the target folder as the source of projectdir info + set pathinfo [punk::repo::find_roots_and_warnings_dict $modulefoldername] + set projectdir [dict get $pathinfo closest] + set modulefolder_path $modulefoldername + } else { + #use the current working directory as the source of projectdir info + set pathinfo [punk::repo::find_roots_and_warnings_dict [pwd]] + set projectdir [dict get $pathinfo closest] + set modulefolders [lib::find_source_module_paths $projectdir] + foreach k [list modules bootsupport vendormodules] { + set knownfolder [file join $projectdir src $k] + if {$knownfolder ni $modulefolders} { + lappend modulefolders $knownfolder + } + } + set mtails [list] + foreach path $modulefolders { + lappend mtails [file tail $path] + } + if {$modulefoldername ni $mtails} { + set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" + append msg "Known module folders: [lsort $mtails]\n" + append msg "Use a name from the above list, or a fully qualified path\n" + error $msg + } + + set modulefolder_path [file join $projectdir src $modulefoldername] + + } + puts stdout "-----------------------------" + puts stdout "Using projectdir: $projectdir for visible_lib_copy_to_modulefolder" + puts stdout "-----------------------------" + + + set libfound [lsearch -all -inline [package names] $library] + if {[llength $libfound] != 1 || ![string length $libfound]} { + error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" + } + + set versions [package versions [lindex $libfound 0]] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + if {![llength $versions]} { + error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" + } + puts stdout "Versions of $libfound found: $versions" + set alphaposn [lsearch $versions "999999.*"] + if {$alphaposn >= 0} { + set alpha [lindex $versions $alphaposn] + #remove and tack onto beginning.. + set versions [lreplace $versions $alphaposn $alphaposn] + set versions [list $alpha {*}$versions] + } + + set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? + if {[llength $versions] > 1} { + puts stdout "Version selected: $ver" + } + + set loadinfo [package ifneeded $libfound $ver] + if {[llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source"} { + set source_file [lindex $loadinfo 1] + } elseif {[string match "*source*" $loadinfo]} { + set parts [split $loadinfo ";"] + set sources_found [list] + foreach p $parts { + if {[lindex $p 0] eq "source"} { + #may have args.. e.g -encoding utf-8 + lappend sources_found [lindex $p end] + } + } + + if {[llength $sources_found] != 1} { + puts stderr "sorry - unable to interpreet source library location" + puts stderr "Only 1 source supported for now: received $loadinfo" + return false + } + set source_file [lindex $sources_found 0] + } else { + puts stderr "sorry - unable to interpret source library location" + puts stderr "Found info: $loadinfo" + return false + } + + if {![file exists $source_file]} { + error "Unable to verify source file existence at: $source_file" + } + set source_data [fcat $source_file -translation binary] + if {![string match "*package provide*" $source_data] || ![string match "*$libfound*" $source_data]} { + puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" + return false + } + + set moduleprefix [punk::nsprefix $libfound] + if {[string length $moduleprefix]} { + set moduleprefix_parts [punk::nsparts $moduleprefix] + set relative_path [file join {*}$moduleprefix_parts] + } else { + set relative_path "" + } + set pkgtail [punk::nstail $libfound] + set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] + + if {$opt_askme} { + puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" + puts stdout "" + puts stdout "This is not intended for binary modules - use at own risk and check results" + puts stdout "" + puts stdout "Base module path: $modulefolder_path" + puts stdout "Target path : $target_path" + puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + + if {![file exists $modulefolder_path]} { + puts stdout "Creating module base folder at $modulefolder_path" + file mkdir $modulefolder_path + } + if {![file exists [file dirname $target_path]]} { + puts stdout "Creating relative folder at [file dirname $target_path]" + file mkdir [file dirname $target_path] + } + + if {[file exists $target_path]} { + puts stdout "WARNING - module already exists at $target_path" + if {$opt_askme} { + puts stdout "Copy anyway? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + } + + file copy -force $source_file $target_path + + return $target_path + } + + proc wrap_in_multishell {filepath args} { + set defaults [list -askme 1] + set opts [dict merge $defaults $args] + + set opt_askme [dict get $opts -askme] + + if {[file type $filepath] ne "file"} { + error "wrap_in_multishell: only script files can be wrapped." + } + set ext [string trim [file extension $filepath] .] + #set allowed_extensions [list tcl ps1 sh bash] + #TODO + set allowed_extensions [list tcl] + if {[string tolower $ext] ni $allowed_extensions} { + error "wrap_in_multishell: script must have file extension in list: $allowed_extensions" + } + + set output_file [file rootname $filepath].cmd + if {[file exists $output_file]} { + error "wrap_in_multishell: target file $output_file already exists.. aborting" + } + + + set startdir [pwd] + set workroot [punk::repo::find_candidate $startdir] + set wrapper_template $workroot/src/ + + set tpldir [lib::mix_templates_dir] + set wrapper_template $tpldir/utility/multishell.cmd + if {![file exists $wrapper_template]} { + error "wrap_in_multishell: unable to find multishell template at $wrapper_template" + } + set fdt [open $wrapper_template r] + fconfigure $fdt -translation binary + set template_data [read $fdt] + close $fdt + puts stdout "Read [string length $template_data] bytes of template data.." + set template_lines [split $template_data \n] + puts stdout "Displaying first 3 lines of template between dashed lines..." + puts stdout "-----------------------------------------------" + foreach ln [lrange $template_lines 0 3] { + puts stdout $ln + } + puts stdout "-----------------------------------------------\n" + #foreach ln $template_lines { + #} + + set fdscript [open $filepath r] + fconfigure $fdscript -translation binary + set script_data [read $fdscript] + close $fdscript + puts stdout "Read [string length $script_data] bytes of template data.." + set script_lines [split $script_data \n] + puts stdout "Displaying first 3 lines of your script between dashed lines..." + puts stdout "-----------------------------------------------" + foreach ln [lrange $script_lines 0 3] { + puts stdout $ln + } + puts stdout "-----------------------------------------------\n" + if {$opt_askme} { + puts stdout "Target for above data is '$output_file'" + puts stdout "Does this look correct? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [gets stdin] + if {[string tolower $answer] ne "y"} { + fconfigure stdin -blocking [dict get $stdin_state -blocking] + + puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." + return + } + fconfigure stdin -blocking [dict get $stdin_state -blocking] + } + + set start_idx 0 + set end_idx 0 + set line_idx 0 + set existing_payload [list] + foreach ln $template_lines { + + if {[string match "#*" $ln]} { + set start_idx $line_idx + } elseif {[string match "#*" $ln]} { + set end_idx $line_idx + break + } elseif {$start_idx > 0} { + if {$end_idx > 0} { + lappend existing_payload [string trim $ln] + } + } else { + + } + incr line_idx + } + if {($start_idx == 0) || ($end_idx == 0)} { + error "wrap_in_multishell was unable to find payload area in template marked with # and # on separate lines" + } + set existing_string [join $existing_payload \n] + if {[string length [string trim $existing_string]]} { + puts stdout "EXISTING PAYLOAD!!" + puts stdout "-----------------------------------------------\n" + puts stdout $existing_string + puts stdout "-----------------------------------------------\n" + error "wrap_in_multishell found existing payload.. aborting." + #todo - allow overwrite only in files outside of punkshell distribution? + if 0 { + puts stderr "Found existing payload.. overwrite?" + if {$opt_askme} { + puts stdout "Are you sure you want to replace the tcl payload shown above? Y|N" + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + } + } + + set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line + set tpl_tail_lines [lrange $template_lines $end_idx end] + set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] + puts stdout "New script is [string length $newscript] bytes" + puts stdout $newscript + set fdtarget [open $output_file w] + fconfigure $fdtarget -translation binary + puts -nonewline $fdtarget $newscript + close $fdtarget + puts stdout "Wrote script file at $output_file" + puts stdout "-done-" + return $output_file + } + + #require current dir when calling to be the projectdir, or + proc newmodule {module args} { + set year [clock format [clock seconds] -format %Y] + set defaults [list -project \uFFFF -type \uFFFF -version 0.1.0 -force 0 -license ] + set opts [dict merge $defaults $args] + set opt_project [dict get $opts -project] + set opt_version [dict get $opts -version] + set opt_license [dict get $opts -license] + + if {[string first - $module]> 0} { + set vparts [lassign [split $module -] modulename] + set mversion [join $vparts -] ;# (- not supported in tcl versions for 8.7 - but possibly part of 9+ if semver implemented) + if {![lib::is_valid_tm_version $mversion]} { + error "pmix newmodule error - unable to determine modulename-version from supplied value '$module'" + } + if {[package vcompare $mversion $opt_version] > 0} { + set opt_version $mversion; #module parameter has higher value than -version + } + } else { + set modulename $module + + } + lib::validate_modulename $modulename "mix newmodule name" + + + set testdir [pwd] + if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { + if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { + error "newmodule unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards (/src, src/modules, src/lib & /modules must exist, must not be a system path such as /usr/bin or c:/windows)" + } + } + + if {$opt_project == "\uFFFF"} { + set projectname [file tail $projectdir] + } else { + set projectname $opt_project + if {$projectname ne [file tail $projectdir]} { + error "newmodule -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" + } + } + + set opt_type [dict get $opts -type] + if {$opt_type eq "\uFFFF"} { + set opt_type [lindex [lib::module_types] 0] ;#default to plain + } + if {$opt_type ni [lib::module_types]} { + error "mix newmodule - error - unknown -type '$opt_type' known-types: [lib::module_types]" + } + + set subpath [lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' + if {![string length $subpath]} { + set modulefolder $projectdir/src/modules + } else { + set modulefolder $projectdir/src/modules/$subpath + } + file mkdir $modulefolder + + set moduletail [namespace tail $modulename] + set tpldir [lib::mix_templates_dir] + set magicversion [lib::magic_tm_version] ;#deliberately large so given load-preference when testing + + + set fd [open $tpldir/module/module_buildversion.txt r]; set filedata [read $fd]; close $fd + set filedata [string map [list %Major.Minor.Level% $opt_version] $filedata] + set fd [open $modulefolder/${moduletail}-buildversion.txt w] + fconfigure $fd -translation binary + puts -nonewline $fd $filedata + close $fd + + set tpldir [lib::mix_templates_dir] + set fd [open $tpldir/module/module_template-0.0.1.tm r]; set filedata [read $fd]; close $fd + set filedata [string map [list %pkg% $modulename %year% $year %license% $opt_license] $filedata] + set modulefile $modulefolder/${moduletail}-$magicversion.tm + set fd [open $modulefile w] + fconfigure $fd -translation binary + puts -nonewline $fd $filedata + close $fd + + return [list file $modulefile version $opt_version] + } + + proc make {args} { + set startdir [pwd] + set project_base "" ;#empty for unknown + if {[punk::repo::is_git $startdir]} { + set project_base [punk::repo::find_git] + set sourcefolder $project_base/src + } elseif {[punk::repo::is_fossil $startdir]} { + set project_base [punk::repo::find_fossil] + set sourcefolder $project_base/src + } else { + if {[punk::repo::is_candidate $startdir]} { + set project_base [punk::repo::find_candidate] + set sourcefolder $project_base/src + puts stderr "WARNING - project not under git or fossil control" + puts stderr "Using base folder $project_base" + } else { + set sourcefolder $startdir + } + } + + #review - why can't we be anywhere in the project? + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "mix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" + if {[string length $project_base]} { + if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $projectbase/src]} { + puts stderr "Try cd to $project_base/src" + } + } + return false + } + + if {![string length $project_base]} { + puts stderr "WARNING no git or fossil repository detected." + puts stderr "Using base folder $startdir" + set project_base $startdir + } + + set lc_this_exe [string tolower [info nameofexecutable]] + set lc_proj_bin [string tolower $project_base/bin] + set lc_build_bin [string tolower $project_base/src/_build] + + + set is_own_exe 0 + if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { + set is_own_exe 1 + puts stderr "WARNING - running make using executable that may be created by the project being built" + puts stdout "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + cd $sourcefolder + #use run so that stdout visible as it goes + set exitinfo [run [info nameofexecutable] $sourcefolder/make.tcl project] + set exitcode [dict get $exitinfo exitcode] + + cd $startdir + if {$exitcode != 0} { + puts stderr "FAILED with exitcode $exitcode" + return false + } else { + puts stdout "OK make finished " + return true + } + } + + proc Kettle {args} { + tailcall lib::kettle_call lib {*}$args + } + proc KettleShell {args} { + tailcall lib::kettle_call shell {*}$args + } + + #proc libexample {} { + # set result [lib::libfunc1 test] + # return $result + #} + + + namespace eval lib { + proc libfunc1 {args} { + return libfunc1-$args + } + proc module_types {} { + #first in list is default for unspecified -type when creating new module + return [list plain tarjar zipkit] + } + proc module_subpath {modulename} { + set modulename [string trim $modulename :] + set nsq [namespace qualifiers $modulename] + return [string map [list :: /] $nsq] + } + #find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) + proc find_source_module_paths {{path {}}} { + if {![string length [set candidate [punk::repo::find_candidate $path]]]} { + error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" + } + #we can return module paths even if the project isn't yet under revision control + set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] + set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] + set tm_folders [list] + foreach sub $src_subs { + foreach anti $antipatterns { + if {[string match $anti $sub]} { + continue + } + } + set testfolder [file join $candidate src $sub] + set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] + if {[llength $tmfiles]} { + lappend tm_folders $testfolder + } + } + return $tm_folders + } + proc validate_modulename {modulename {name_description modulename}} { + validate_name_not_empty_or_spaced $modulename $name_description + set testname [string map [list :: ""] $modulename] + if {[string first : $testname] >=0} { + error "$name_description '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$name_description '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + proc validate_projectname {projectname {name_description projectname}} { + validate_name_not_empty_or_spaced $projectname $name_description + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$name_description '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$name_description '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name {name_description name}} { + if {![string length $name]} { + error "$name_description cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$name_description cannot contain whitespace" + } + return $name + } + proc get_build_cksums_stored {path} { + set buildfolder [get_build_folder $path] + + set vfscontainer [file dirname $buildfolder] + set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] + set dict_cksums [dict create] + foreach vfs $vfslist { + set vname [file rootname $vfs] + set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] + set ckfile $buildfolder/$vname.cksums + if {[file exists $ckfile]} { + set data [punk::repo::fcat -translation binary $ckfile] + foreach ln [split $data \n] { + if {[string trim $ln] eq ""} {continue} + lassign $ln path cksum + dict set dict_vfs $path $cksum + } + } + dict set dict_cksums $vname $dict_vfs + } + return $dict_cksums + } + proc get_build_folder {path} { + if {[string length [set testbase [punk::repo::find_fossil $path]]]} { + set base $testbase + } elseif {[string length [set testbase [punk::repo::find_git $path]]]} { + set base $testbase + } elseif {[string length [set testbase [punk::repo::find_candidate $path]]]} { + set base $testbase + } else { + error "get_build_cksums_stored unable to determine project base for path '$path'" + } + if {![file exists $base/src] || ![file writable $base/src]} { + error "get_build_cksums_stored unable to access $base/src" + } + file mkdir $base/src/_build + return $base/src/_build + } + proc get_build_cksums {path} { + set buildfolder [get_build_folder $path] + set vfscontainer [file dirname $buildfolder] + set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] + set buildruntime $buildfolder/buildruntime.exe + set ckinfo_buildruntime [punk::repo::cksum_path $buildruntime] + set dict_cksums [dict create] + foreach vfs $vfslist { + set vname [file rootname $vfs] + set ckinfo_vfs [punk::repo::cksum_path $vfscontainer/$vname.vfs] + set ckinfo_exe [punk::repo::cksum_path $buildfolder/$vname.exe] + set dict_vfs [list $vname.vfs [dict get $ckinfo_vfs cksum] $vname.exe [dict get $ckinfo_exe cksum] buildruntime.exe [dict get $ckinfo_buildruntime cksum]] + dict set dict_cksums $vname $dict_vfs + } + return $dict_cksums + } + proc mix_templates_dir {} { + set provide_statement [package ifneeded punk::mix [package require punk::mix]] + set tmdir [file dirname [lindex $provide_statement end]] + set tpldir $tmdir/mix/templates + if {![file exists $tpldir]} { + error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" + } + return $tpldir + } + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + + #todo - review. Check Tcl's exact requirements here + # assume we can have things like: 1.1a2 2.2.b4 + proc is_valid_tm_version1 {versionpart} { + #review - regexp from https://wiki.tcl-lang.org/page/Package+MetaData+Fields + #page notes that 'valid version numbers can be decoded via the following.." + #regexp {([0-9]+)\.([0-9]+)\.?([ab])?\.?([0-9]*)} $ver => major minor maturity level + #but that doesn't rule out invalid version numbers being passed by this and causing issues with version comparisons, package loading etc. + + set versionsegments [split $versionpart .] + if {![string is integer -strict [lindex $versionsegments 0]]} { + return 0 + } + #rudimentary check on the tail.. + #reviewed briefly 2023-07 - need to support e.g 2.5.b.5 ? + #Note that package vcompare in tcl 8.7a5 doesn't support 2.5.b.5 + foreach tailpart [lrange $versionsegments 1 end] { + if {![string is integer -strict $tailpart]} { + #extremely loose check.. + #pass anything with an a or b for now.. + #review to see if tcl tm system allows semver style x.y.z-beta etc or if we should lock it down + #need to take into account how tcl compares/orders version numbers. + if {(![string first a $tailpart] >= 0) && (![string first b $tailpart] >=0)} { + return 0 + } + } + } + return 1 + } + + + #Note that semver only has a small overlap with tcl tm versions. + #todo - work out what overlap and whether it's even useful + #see also TIP #439: Semantic Versioning (tcl 9??) + proc semver {versionstring} { + set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} + } + proc magic_tm_version {} { + return 999999.0a1.0 ;#deliberately large so given load-preference when testing + } + proc copy_modules_from_source_to_base {srcdir basedir args} { + set defaults [list -glob *.tm -antiglob_file [list "*[magic_tm_version]*"] ] + set opts [dict merge $defaults $args] + copy_files_from_source_to_target $srcdir $basedir {*}$opts + } + proc copy_nonmodules_from_source_to_base {srcdir basedir args} { + #set keys [dict keys $args] + set defaults [list -glob * -antiglob_file [list "*.tm" "*-buildversion.txt"]] + set opts [dict merge $defaults $args] + copy_files_from_source_to_target $srcdir $basedir {*}$opts + } + + ## unidirectional file transfer to possibly non empty folder + #default of -overwrite no-targets will only copy files that are missing at the target + # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) + # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target + # -overwrite all-targets will copy regardless of timestamp at target + # review - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? + # if such a content-mismatch - what default behaviour and what options would make sense? + # probably it's reasonable that only all-targets would overwrite such files. + # consider -source_fudge_seconds +-X ?, -source_override_timestamp ts ??? etc which only adjust timestamp for calculation purposes? Define a specific need/usecase when reviewing. + # + # valid filetypes for src tgt + # src dir tgt dir + # todo - review and consider enabling symlink src and dst + # no need for src file - as we use -glob with no glob characters to match one source file file + # no ability to target file with different name - keep it simpler and caller will have to use an intermediate folder/file if they need to rename something? + # + # todo - determine what happens if mismatch between file type of a src vs target e.g target has dir matching filename at source + # As function is named copy_files... we should only expect dirs to be created as necessary to hold files + # A pre-scan to determine no such conflict - before attempting to copy anything might provide the most integrity at slight cost in speed. + proc copy_files_from_source_to_target {srcdir tgtdir args} { + set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#defaults + set defaults [list -subdirlist {} -glob * -antiglob_file [list "*[magic_tm_version]*" "*-buildversion.txt"] -antiglob_dir $antidir -overwrite no-targets] + set opts [dict merge $defaults $args] + if {([llength $args] %2) != 0} { + error "copy_files_from_source_to_target requires option-style arguments to be in pairs. Received args: $args" + } + foreach k [dict keys $args] { + if {$k ni [dict keys $defaults]} { + error "copy_files_from_source_to_target unrecognised option '$k' known options: '[dict keys $defaults]'" + } + } + + #The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one. + #(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree) + #It comes from build_modules_from_source_to_base where we need to keep track of position relative to our targetdir starting point to handle submodules e.g pkg::something::mypkg-0.1.tm + #It could have been handled with some other parameter such as -depth, but this -subdirlist mechanism, whilst perhaps not beautiful, is straightforward enough + #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started + #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. + set subdirlist [dict get $opts -subdirlist] + + set fileglob [dict get $opts -glob] + set antiglobs [dict get $opts -antiglob_file] + set known_whats [list no-targets newer-targets older-targets all-targets] + set overwrite_what [string tolower [dict get $opts -overwrite]]; #accept any case for value to allow emphasis by caller e.g -overwrite NEWER-TARGETS + if {$overwrite_what ni $known_whats} { + error "copy_files_from_source_to_target received unrecognised value for -overwrite. Received value '$overwrite_what' vs known values '$known_whats'" + } + set opt_antiglob_dir [dict get $opts -antiglob_dir] + + if {[llength $subdirlist] == 0} { + set current_source_dir $srcdir + set current_target_dir $tgtdir + } else { + set current_source_dir $srcdir/[file join {*}$subdirlist] + set current_target_dir $tgtdir/[file join {*}$subdirlist] + } + + if {$overwrite_what in [list newer-targets older-targets]} { + error "copy_files_from_source_to_target newer-target, older-targets not implemented - sorry" + #TODO - check crossplatform availability of ctime (on windows it still seems to be creation time, but on bsd/linux it's last attribute mod time) + # external pkg? use twapi and ctime only on other platforms? + } + + if {![file exists $current_source_dir]} { + error "copy_files_from_source_to_target current source dir:'$current_source_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + if {![file exists $current_target_dir]} { + error "copy_files_from_source_to_target current target dir:'$current_target_dir' doesn't exist (srcdir:$srcdir tgtdir:$tgtdir args:'$args')" + } + if {([file type $current_source_dir] ni [list directory]) || ([file type $current_target_dir] ni [list directory])} { + error "copy_files_from_source_to_target requires source and target dirs to be of type 'directory' type current source: [file type $current_source_dir] type current target: [file type $current_target_dir]" + } + + set copied_files [list] + set candidate_list [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + set hidden_candidate_list [glob -nocomplain -dir $current_source_dir -types {hidden f} -tail $fileglob] + foreach h $hidden_candidate_list { + if {$h ni $candidate_list} { + lappend candidate_list $h + } + } + set match_list [list] + foreach m $candidate_list { + set suppress 0 + foreach anti $antiglobs { + if {[string match $anti $m]} { + puts stderr "anti: $anti vs m:$m" + set suppress 1 + break + } + } + if {$suppress == 0} { + lappend match_list $m + } + } + + + foreach m $match_list { + puts stdout "copying file $current_source_dir/$m to $current_target_dir" + if {$overwrite_what eq "all-targets"} { + file copy -force $current_source_dir/$m $current_target_dir + } else { + if {![file exists $current_target_dir/$m]} { + file copy $current_source_dir/$m $current_target_dir + } else { + puts stderr "Skipping file copy $m target $current_target_dir/$m already exists (use -overwrite all-targets to overwrite)" + #TODO! implement newer-targets older-targets + } + } + lappend copied_files $current_source_dir/$m + } + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + set hiddensubdirs [glob -nocomplain -dir $current_source_dir -type {hidden d} -tail *] + foreach h $hiddensubdirs { + if {$h in [list "." ".."]} { + continue + } + if {$h ni $subdirs} { + lappend subdirs $h + } + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + foreach dg $opt_antiglob_dir { + if {[string match $dg $d]} { + continue + } + } + if {![file exists $current_target_dir/$d]} { + file mkdir $current_target_dir/$d + } + lappend copied_files {*}[copy_files_from_source_to_target $srcdir $tgtdir -subdirlist [list {*}$subdirlist $d] -glob $fileglob -antiglob_file $antiglobs -antiglob_dir $opt_antiglob_dir -overwrite $overwrite_what] + } + return $copied_files + } + + proc build_modules_from_source_to_base {srcdir basedir args} { + set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. + set defaults [list -subdirlist {} -glob *.tm] + set opts [dict merge $defaults $args] + set subdirlist [dict get $opts -subdirlist] + set fileglob [dict get $opts -glob] + if {![string match "*.tm" $fileglob]} { + error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." + } + + set magicversion [magic_tm_version] ;#deliberately large so given load-preference when testing + set module_list [list] + + if {[file tail [file dirname $srcdir]] ne "src"} { + puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" + puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" + puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." + puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" + puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" + exit 2 + } + set srcdirname [file tail $srcdir] + + set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir + if {[llength $subdirlist] == 0} { + set target_module_dir $basedir + set current_source_dir $srcdir + } else { + set target_module_dir $basedir/[file join {*}$subdirlist] + set current_source_dir $srcdir/[file join {*}$subdirlist] + } + if {![file exists $target_module_dir]} { + error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" + } + if {![file exists $current_source_dir]} { + error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" + } + + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + + + foreach m $src_modules { + set fileparts [split [file rootname $m] -] + set tmfile_versionsegment [lindex $fileparts end] + if {$tmfile_versionsegment eq $magicversion} { + #rebuild the .tm from the #tarjar + set basename [join [lrange $fileparts 0 end-1] -] + set versionfile $current_source_dir/$basename-buildversion.txt + if {![file exists $versionfile]} { + puts stderr "WARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning" + set module_build_version "0.1" + } else { + set fd [open $versionfile r]; set data [read $fd]; close $fd + set ln0 [lindex [split $data \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + file mkdir $buildfolder + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + + } else { + + } + #REVIEW - should be in same structure/depth as $target_module_dir in _build? + set tmfile $basedir/_build/$basename-$module_build_version.tm + file mkdir $basedir/_build + file delete -force $basedir/_build/#tarjar-$basename-$module_build_version + file delete -force $tmfile + + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version + # + #bsdtar doesn't seem to work.. or I haven't worked out the right options? + #exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version + package require tar + tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version + if {![file exists $tmfile]} { + puts stdout "ERROR: Failed to build tarjar file $tmfile" + exit 4 + } + #copy the file? + #set target $target_module_dir/$basename-$module_build_version.tm + #file copy -force $tmfile $target + + lappend module_list $tmfile + } else { + #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. + if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { + puts stderr "Warning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + } + set target $target_module_dir/$basename-$module_build_version.tm + puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" + set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $target w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + #file copy -force $srcdir/$m $target + lappend module_list $target + } + + continue + } + + + if {![is_valid_tm_version $tmfile_versionsegment]} { + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." + exit 1 + } + puts stderr "copying already versioned module $current_source_dir/$m to $target_module_dir" + file copy -force $current_source_dir/$m $target_module_dir + lappend module_list $current_source_dir/$m + } + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + foreach dg $antidir { + if {[string match $dg $d]} { + continue + } + } + if {![file exists $target_module_dir/$d]} { + file mkdir $target_module_dir/$d + } + lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir -subdirlist [list {*}$subdirlist $d] -glob $fileglob] + } + return $module_list + } + + proc kettle_call {calltype args} { + if {$calltype ni [list lib shell]} { + error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + if {$calltype eq "shell"} { + set kettleappfile [file dirname [info nameofexecutable]]/kettle + set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" + } + if {[file exists $kettleappfile]} { + set kettlescript $kettleappfile + } + if {$::tcl_platform(platform) eq "windows"} { + if {[file exists $kettlebatfile]} { + set kettlescript $kettlebatfile + } + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" + } + if {[catch {package present kettle}]} { + puts stdout "Loading kettle package - may be delay on first load ..." + package require kettle + } + set first [lindex $args 0] + if {[string match @* $first]} { + error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" + } + if {$first eq "-f"} { + set args [lassign $args __ path] + } else { + set path $startdir/build.tcl + } + set opts [list] + + if {[lindex $args 0] eq "-trace"} { + set args [lrange $args 1 end] + lappend opts --verbose on + } + set goals [list] + + if {$calltype eq "lib"} { + file mkdir ~/.kettle + set dotfile ~/.kettle/config + if {[file exists $dotfile] && + [file isfile $dotfile] && + [file readable $dotfile]} { + ::kettle io trace {Loading dotfile $dotfile ...} + set args [list {*}[::kettle path cat $dotfile] {*}$args] + } + } + + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) + #REVIEW - needs to be updated to keep in sync with kettle. + set knownopts [list\ + --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ + --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ + --log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ + --iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ + ] + + while {[llength $args]} { + set o [lindex $args 0] + switch -glob -- $o { + --* { + #instead of using: kettle option known + if {$o ni $knownopts} { + error "Unable to process unknown option $o." {} [list KETTLE (pmix)] + } + lappend opts $o [lindex $args 1] + #::kettle::option set $o [lindex $args 1] + set args [lrange $args 2 end] + } + default { + lappend goals $o + set args [lrange $args 1 end] + } + } + } + + if {![llength $goals]} { + lappend goals help + } + if {"--prefix" ni [dict keys $opts]} { + dict set opts --prefix [file dirname $startdir] + } + if {$calltype eq "lib"} { + ::kettle status clear + ::kettle::option::set @kettle $startdir + foreach {o v} $opts { + ::kettle option set $o $v + } + ::kettle option set @srcscript $path + ::kettle option set @srcdir [file dirname $path] + ::kettle option set @goals $goals + ::source $path + puts stderr "recipes: [::kettle recipe names]" + ::kettle recipe run {*}[::kettle option get @goals] + + set state [::kettle option get --state] + if {$state ne {}} { + puts stderr "saving kettle state: $state" + ::kettle status save $state + } + + } else { + #shell + puts stdout "Running external kettle process with args: $opts $goals" + run -n tclsh $kettlescript -f $path {*}$opts {*}$goals + } + + } + + } +} + + +namespace eval punk::mix::cli { + variable default_command help + package require punk::mix::base + package require punk::overlay + punk::overlay::custom_from_base [namespace current] ::punk::mix::base +} + diff --git a/src/bootsupport/punk/repo-0.1.0.tm b/src/bootsupport/punk/repo-0.1.0.tm new file mode 100644 index 00000000..29b9996e --- /dev/null +++ b/src/bootsupport/punk/repo-0.1.0.tm @@ -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 -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/.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 diff --git a/src/bootsupport/punk/winpath-0.1.0.tm b/src/bootsupport/punk/winpath-0.1.0.tm new file mode 100644 index 00000000..e60648b0 --- /dev/null +++ b/src/bootsupport/punk/winpath-0.1.0.tm @@ -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 -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 diff --git a/src/make.tcl b/src/make.tcl index 70b41b1b..dbfbc427 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -21,6 +21,81 @@ if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" exit 1 } + +#------------------------------------------------------------------------------ +#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder +#------------------------------------------------------------------------------ +#If the there is a folder directly under the current directory /src/bootsupport which contains .tm files when the starts +# - then it will attempt to preference these modules +# This allows a source update via 'fossil update' 'git pull' etc to pull in support modules for the make script +set startdir [pwd] +set bootsupport [file join $startdir src bootsupport] +if {[file exists $bootsupport]} { + + set original_tm_list [tcl::tm::list] + tcl::tm::remove {*}$original_tm_list + + set support_modules [glob -nocomplain -dir $bootsupport -type f -tail *.tm] + set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs tcl Tcl] + if {[llength $support_modules]} { + #only forget all *unloaded* package names if we are started in a .tm containing folder + foreach pkg [package names] { + if {$pkg in $tcl_core_packages} { + continue + } + if {![llength [package versions $pkg]]} { + #puts stderr "Got no versions for pkg $pkg" + continue + } + if {[catch {package present $pkg}]} { + package forget $pkg + } + } + tcl::tm::add $bootsupport + } + + + #todo - review usecase + if {[string match "*.vfs/*" [info script]]} { + #src/xxx.vfs/lib/app-punk/repl.tcl + #we assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels + set modulefolder [file dirname [file dirname [file dirname [file dirname [info script]]]]]/modules + + } else { + # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) + set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules + } + + if {[file exists $modulefolder]} { + tcl::tm::add $modulefolder + } else { + puts stderr "Warning unable to find module folder at: $modulefolder" + } + if {[file exists [pwd]/modules]} { + tcl::tm::add [pwd]/modules + } + + #package require Thread + #These are strong dependencies + # - the repl requires Threading and punk,shellfilter,shellrun to call and display properly. + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list + + package forget punk::mix + package require punk::mix + package forget punk::repo + package require punk::repo + + + #restore module paths + set tm_list_now [tcl::tm::list] + foreach p $original_tm_list { + if {$p ni $tm_list_now} { + tcl::tm::add $p + } + } + #------------------------------------------------------------------------------ +} + # ** *** *** *** *** *** *** *** *** *** *** *** #*temporarily* hijack package command # ** *** *** *** *** *** *** *** *** *** *** *** @@ -147,15 +222,19 @@ if {$::punkmake::command eq "get-project-info"} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { set vc "fossil" set rev [punk::repo::fossil_revision $scriptfolder] + set rem [punk::repo::fossil_remote $scriptfolder] } elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { set vc "git" set rev [punk::repo::git_revision $scriptfolder] + set rem [punk::repo::git_remote $scriptfolder] } else { set vc " - none found -" set rev "n/a" + set remotes "n/a" } puts stdout "- version control : $vc" puts stdout "- revision : $rev" + puts stdout "- remote : $rem" puts stdout "- -- --- --- --- --- --- --- --- --- ---" exit 0 diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index a18284de..d692fa90 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -5700,81 +5700,151 @@ namespace eval punk { #todo - package as punk::navdir #todo - in thread #todo - streaming version - proc dirfiles_dict {{glob ""}} { - set dir [pwd] - if {$glob eq ""} { - set glob "*" + proc dirfiles_dict {{searchspec ""}} { + #we don't want to normalize.. + #for example if the user supplies ../ we want to see ../result + if {[file pathtype $searchspec] eq "relative"} { + set searchbase [pwd] + set listingfor [file join $searchbase $searchspec] + } else { + set searchbase "" + set listingfor $searchspec } - set dirname [file dirname $glob] ;# for * or something* will return just "." which is ok - set ftail [file tail $glob] + + set ftail [file tail $listingfor] if {[string first ? $ftail] >= 0 || [string first * $ftail] >=0} { #has globchar (we only recognise as glob in tail) - set location $dirname + set location [file dirname $listingfor] set glob $ftail } else { - set location $dirname/$ftail + set location $listingfor set glob * } - #also determine whether vfs. file system x is *much* faster than file attributes - set vfs [list] ;#dict keyed on dir/file name - set dirs [glob -nocomplain -directory $location -type d -tail $glob] - # + set in_vfs 0 + foreach mount [vfs::filesystem info] { + if {[punk::repo::path_a_atorbelow_b $location $mount]} { + set in_vfs 1 + break + } + } + if {$in_vfs} { + set listing [punk::du::lib::du_dirlisting_tclvfs $location] + } else { + set listing [punk::du::dirlisting $location] + } + + + + #set dirs [glob -nocomplain -directory $location -type d -tail $glob] + set dirs [dict get $listing dirs] + set files [dict get $listing files] + set filesizes [dict get $listing filesizes] + set vfsmounts [dict get $listing vfsmounts] + set flaggedhidden [dict get $listing flaggedhidden] + + + set nonportable [list] ;#illegal file/folder names for windows e.g trailing dot or trailing space - can still be read if //?/ AND shortname used + set underlayfiles [list] + set underlayfilesizes [list] + if {[llength $vfsmounts]} { + foreach vfsmount $vfsmounts { + if {[set fposn [lsearch $files $vfsmount]] >= 0} { + lappend underlayfiles [lindex $files $fposn] + set files [lreplace $files $fposn $fposn] + if {[llength $filesizes]} { + lappend underlayfilesizes [lindex $filesizes $fposn] + set filesizes [lreplace $filesizes $fposn $fposn] + } + lappend dirs $vfsmount + } elseif {$vfsmount in $dirs} { + #either dirlisting mech was aware of vfs.. or mountpoint is overlaying an underlying folder + #for now - do nothing + #todo - review. way to query dirlisting mech to see if we are hiding a folder? + + } else { + #vfs mount but dirlisting mechanism didn't detect as file or folder + lappend dirs $vfsmount + } + } + } + + #NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. #A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. - set hiddendirs [glob -nocomplain -directory $location -type {hidden d} -tail $glob] ;#non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. - foreach hidden $hiddendirs { - if {$hidden ni $dirs} { - lappend dirs $hidden - } + #non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. + #mac & windows have these + #windows doesn't consider dotfiles as hidden - mac does (?) + #we add dotfiles to flaggedhidden list in case there is some other mechanism that has flagged items as hidden + if {$::tcl_platform(platform) ne "windows"} { + lappend flaggedhidden {*}[lsearch -all -inline [concat $dirs $files] ".*"] + set flaggedhidden [lsort -unique $flaggedhidden] } set dirs [lsort $dirs] ;#todo - natsort - foreach d $dirs { - if {[lindex [file system $d] 0] eq "tclvfs"} { - lappend vfs $d [file system $d] - } - } + + + + #foreach d $dirs { + # if {[lindex [file system $d] 0] eq "tclvfs"} { + # lappend vfs $d [file system $d] + # } + #} #glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) - set files [glob -nocomplain -directory $location -type f -tail $glob] - set hiddenfiles [glob -nocomplain -directory $location -type {hidden f} -tail $glob] - foreach hidden $hiddenfiles { - if {$hidden ni $files} { - lappend files $hidden - } - } set files [lsort $files] ;#todo natsort - set illegalwinfiles [list] - foreach fname $files { - if {[punk::winpath::illegalname_test $fname]} { - lappend illegalwinfiles $fname - } - } - set illegalwindirs [list] - foreach dname $dirs { - if {[punk::winpath::illegalname_test $dname]} { - lappend illegalwindirs $dname + + foreach nm [concat $dirs $files] { + if {[punk::winpath::illegalname_test $nm]} { + lappend nonportable $nm } } - return [list dirs $dirs hiddendirs $hiddendirs vfs $vfs files $files hiddenfiles $hiddenfiles illegalwinfiles $illegalwinfiles illegalwindirs $illegalwindirs location $location] + + set updated [dict create dirs $dirs files $files nonportable $nonportable flagedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes location $location searchbase $searchbase] + + + return [dict merge $listing $updated] + #return [list dirs $dirs vfsmounts $vfsmounts files $files filesizes $filesizes underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes nonportable $nonportable flaggedhidden $flaggedhidden flaggedsystem $flaggedsystem location $location searchbase $searchbase] } #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? - proc dirfiles_dict_as_lines {contents} { + proc dirfiles_dict_as_lines {contents args} { + + set defaults [list -stripbase 0] + set opts [dict merge $defaults $args] + set opt_stripbase [dict get $opts -stripbase] + package require overtype set dirs [dict get $contents dirs] - set hiddendirs [dict get $contents hiddendirs] + set links [dict get $contents links] set files [dict get $contents files] - set hiddenfiles [dict get $contents hiddenfiles] - set illegalwindirs [dict get $contents illegalwindirs] - set illegalwinfiles [dict get $contents illegalwinfiles] - set vfs [dict get $contents vfs] + set filesizes [dict get $contents filesizes] + set underlayfiles [dict get $contents underlayfiles] + set underlayfilesizes [dict get $contents underlayfilesizes] + set flaggedhidden [dict get $contents flaggedhidden] + set flaggedreadonly [dict get $contents flaggedreadonly] + set flaggedsystem [dict get $contents flaggedsystem] + set nonportable [dict get $contents nonportable] ;# illegal file/folder names from windows perspective + set vfsmounts [dict get $contents vfsmounts] + set searchbase [dict get $contents searchbase] + + if {$opt_stripbase} { + set filetails [list] + set dirtails [list] + foreach fileset [list dirs files links underlayfiles flaggedhidden flaggedsystem nonportable vfsmounts] { + set stripped [list] + foreach f [set $fileset] { + lappend stripped [strip_prefix_depth $f $searchbase] + } + set $fileset $stripped + } + } + set widest [pipedata [list {*}$dirs ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] @@ -5786,37 +5856,37 @@ namespace eval punk { set f1 [a+ white bold] set f2 [a+] if {[string length $d]} { - if {$d in $hiddendirs} { + if {$d in $flaggedhidden} { set d1 [a+ cyan] } - if {[dict exists $vfs $d]} { - if {$d in $hiddendirs} { + if {$d in $vfsmounts} { + if {$d in $flaggedhidden} { #we could have a hidden dir which is also a vfs.. color will be overridden giving no indicatio of 'hidden' status - REVIEW #(This situation encountered on windows - even though file attr showed -hidden 0 - the glob with -types hidden returned it.. possibly a tcl glob bug on windows) #mark it differently for now.. (todo bug report?) - if {$d in $illegalwindirs} { + if {$d in $nonportable} { set d1 [a+ red Yellow bold] } else { set d1 [a+ green Purple bold] } } else { - if {$d in $illegalwindirs} { + if {$d in $nonportable} { set d1 [a+ red White bold] } else { set d1 [a+ green bold] } } } else { - if {$d in $illegalwindirs} { + if {$d in $nonportable} { set d1 [a+ red bold] } } } if {[string length $f]} { - if {$f in $hiddenfiles} { + if {$f in $flaggedhidden} { set f1 [a+ Purple] } else { - if {$f in $illegalwinfiles} { + if {$f in $nonportable} { set f1 [a+ red bold] } } @@ -5827,11 +5897,20 @@ namespace eval punk { return [list_as_lines $displaylist] } - proc dirfiles {{glob ""}} { - set contents [dirfiles_dict $glob] + proc dirlist {{location ""}} { + set contents [dirfiles_dict $location] + return [dirfiles_dict_as_lines $contents -stripbase 1] + } + + #dirfiles dirfiles_dict always deliberately return absolute *unnormalized* path + #e.g when cwd is c:/repo/jn/shellspy dirfiles ../../ will return something like: + # c:/repo/jn/shellspy/../../blah + proc dirfiles {{location ""}} { + set contents [dirfiles_dict $location] return [dirfiles_dict_as_lines $contents] } + #extra slash implies more verbosity (ie display commands instead of just nschildren) interp alias {} :/ {} punk::ns/ / interp alias {} :// {} punk::ns/ // @@ -5922,7 +6001,7 @@ namespace eval punk { set a1 [lindex $args 0] set curdir [pwd] set path1 [path_to_absolute $a1 $curdir $::tcl_platform(platform)] - set fullpath [join $path1 {*}[lrange $args 1 end] /] + set fullpath [file join $path1 {*}[lrange $args 1 end]] if {[file exists $fullpath]} { error "Folder $fullpath already exists" @@ -5966,6 +6045,102 @@ namespace eval punk { } return $path_absolute } + proc strip_prefix_depth {path prefix} { + set tail [lrange [file split $path] [llength [file split $prefix]] end] + if {[llength $tail]} { + return [file join {*}$tail] + } else { + return "" + } + } + + #todo + proc format_number {number {delim ""} {groupsize ""}} { + if {"windows" eq $::tcl_platform(platform)} { + if {![catch {package require twapi}]} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + return [twapi::format_number $number $localeid -idigits -1] + } else { + if {$delim eq ""} {set delim ","} + if {$groupsize eq ""} {set groupsize 3} + return [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + } + } + } + #todo - get configured user defaults + set delim "," + set groupsize 3 + + return [delimit_number $number $delim $groupsize] + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {number {delim ","} {GroupSize 3}} { + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number [expr $point + 1] end]; + set PostDecimalP 1; + } else { + set point [expr [string length $number] + 1] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr $FirstNonSpace - 1]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace [expr $point -1]]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr $Length % $GroupSize] + set PhaseMinusOne [expr $Phase -1]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr $FirstInGroup + $GroupSize -1]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + + + #NOTE - as we expect to run other apps (e.g Tk) in the same process, but possibly different threads - we should be careful about use of cd which is per-process not per-thread. #As this function recurses and calls cd multiple times - it's not thread-safe. #Another thread could theoretically cd whilst this is running. @@ -5996,11 +6171,23 @@ namespace eval punk { set matchinfo [punk::dirfiles_dict] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] - set location [file normalize [dict get $matchinfo location]] + #set location [file normalize [dict get $matchinfo location]] + set location [dict get $matchinfo location] + + + + + #result for glob is count of matches - use dirfiles etc for script access to results set result [list location $location dircount $dircount filecount $filecount] + set filesizes [dict get $matchinfo filesizes] + if {[llength $filesizes]} { + set filesizes [lsearch -all -inline -not $filesizes na] + set filebytes [tcl::mathop::+ {*}$filesizes] + lappend result filebytes [format_number $filebytes] + } if {$::repl::running} { - set out [punk::dirfiles_dict_as_lines $matchinfo] + set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] #puts stdout $out #puts stderr [a+ white]$out[a+] @@ -6031,11 +6218,18 @@ namespace eval punk { set matchinfo [punk::dirfiles_dict [file tail $path]] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] + set location [file normalize [dict get $matchinfo location]] #result for glob is count of matches - use dirfiles etc for script access to results set result [list location $location dircount $dircount filecount $filecount] + set filesizes [dict get $matchinfo filesizes] + if {[llength $filesizes]} { + set filesizes [lsearch -all -inline -not $filesizes na] + set filebytes [tcl::mathop::+ {*}$filesizes] + lappend result filebytes [format_number $filebytes] + } if {$::repl::running} { - set out [punk::dirfiles_dict_as_lines $matchinfo] + set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] set chunklist [list] lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] lappend chunklist [list result $result] @@ -6079,6 +6273,7 @@ namespace eval punk { } } if {[file type $path] eq "directory"} { + #don't cd to intermediate paths.. could be restricted - yet may have permissions on final path cd $path tailcall punk::d/ {*}$atail } @@ -6099,9 +6294,15 @@ namespace eval punk { set location [file normalize [dict get $matchinfo location]] #result for glob is count of matches - use dirfiles etc for script access to results set result [list location $location dircount $dircount filecount $filecount] + set filesizes [dict get $matchinfo filesizes] + if {[llength $filesizes]} { + set filesizes [lsearch -all -inline -not $filesizes na] + set filebytes [tcl::mathop::+ {*}$filesizes] + lappend result filebytes [format_number $filebytes] + } if {$::repl::running} { - set out [punk::dirfiles_dict_as_lines $matchinfo] + set out [punk::dirfiles_dict_as_lines $matchinfo -stripbase 1] #return $out\n[pwd] set chunklist [list] lappend chunklist [list stdout "[a+ white light]$out[a+]\n"] @@ -7108,9 +7309,9 @@ namespace eval punk { interp alias {} d/ {} punk::d/ interp alias {} dd/ {} punk::dd/ + interp alias {} dirlist {} punk::dirlist interp alias {} dirfiles {} punk::dirfiles interp alias {} dirfiles_dict {} punk::dirfiles_dict - interp alias {} df {} punk::dirfiles #namespace/command/proc query interp alias {} nslist {} punk::nslist diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 7be23bc0..c317b636 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -18,156 +18,41 @@ ## 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 du_lit value { - if {![info exists ::punk::du_literal($value)]} { - set ::punk::du_literal($value) $value + 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] + } - return $::punk::du_literal($value) - } - proc _du_new_eachdir {dirtails depth parentfolderidx} { - set newlist {} - upvar folders folders - set parentpath [lindex $folders $parentfolderidx] - set newindex [llength $folders] - foreach dt $dirtails { - lappend folders $parentpath/$dt - lappend newlist [::list $depth $parentfolderidx $newindex $dt [expr {0}]] - incr newindex - } - return $newlist - } - proc du_listing {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} -tail * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d -tail * .*] - - #set hlinks [glob -nocomplain -dir [lindex $folders $folderidx] -types {hidden l} -tail * .*] - set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l -tail * .*] ;#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} -tail * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f -tail * .*] - #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 {. ..}]] - set files [struct::set difference [concat $hfiles $files[unset files]] $links] - - set filesizes [list]; #not available in listing-call - as opposed to twapi which can do it as it goes - return [list $dirs $files $filesizes] + #run whichever of du_dirlisting_twapi, du_dirlisting_generic, du_dirlisting_unix has been activated + set dirinfo [active::du_dirlisting $folderpath] } - # get listing without using unix-tools (may not be installed on the windows system) - proc du_listing_twapi {folderpath} { - package require punk::winpath - set dirs [list] - set files [list] - set filesizes [list] - try { - if {[string length [file normalize $folderpath]] >= 250} { - set folderpath_shortname [punk::winpath::pwdshortname $folderpath] - set iterator [twapi::find_file_open $folderpath_shortname/* -detail basic] - } else { - set iterator [twapi::find_file_open $folderpath/* -detail basic] ;# -detail full only adds data to the altname field - } - } on error args { - if {[string match "*denied*" $args]} { - #output similar format as unixy du - puts stderr "[file dirname $folderpath] '[file tail $folderpath]':$args" - return [list {} {} {}] - } - #possibly an illegal windows filename - easily happens on a machine with WSL or with drive mapped to unix share - set errmsg "error reading folder: $folderpath (len:[string length [file normalize $folderpath]])\n" - append errmsg "error: $args" \n - append errmsg "errorcode: $::errorCode" \n - append errmsg {retrying with with windows altname} - puts stderr $errmsg - try { - #go to parent and re-fetch this folder with altnames - #use normalize to get full path - in case we are currently at "." - set parent [file dirname [file normalize $folderpath]] - set iterator [twapi::find_file_open $parent/* -detail full] ;# -detail full because we need altname! - while {[twapi::find_file_next $iterator iteminfo]} { - set nm [dict get $iteminfo name] - if {$nm eq [file tail $folderpath]} { - break - } - } - if {$nm ne [file tail $folderpath]} { - error "failed to re-fetch current directory info with altpath info" - } - set altname [dict get $iteminfo altname] - puts stderr "using altname $parent/$altname" - set iterator [twapi::find_file_open $parent/$altname/* -detail basic] - - - } on error args { - set errmsg "error reading folder: $parent or $folderpath\n" - append errmsg "error: $args" - append errmsg "aborting.." - error $errmsg - } - } - while {[twapi::find_file_next $iterator iteminfo]} { - set nm [dict get $iteminfo name] - if {$nm in {. ..}} { - continue - } - set attrinfo [twapi::decode_file_attributes [dict get $iteminfo attrs]] - if {"reparse_point" in $attrinfo} { - #we will treat as a zero sized file.. 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 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. - #This .lnk seems to be an ordinary file and we can treat as such here. - lappend files $nm - lappend filesizes 0 - } elseif {"directory" in $attrinfo} { - lappend dirs $nm - } else { - lappend files $nm - lappend filesizes [dict get $iteminfo size] - } - } - return [list $dirs $files $filesizes] - } #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 though + #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 @@ -201,8 +86,13 @@ namespace eval punk::du { set opts $args - # flags in args are singletons (or longopts --something=somethingelse) or sometimes pairopts - # process any pairopts first + # 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} { @@ -217,7 +107,9 @@ namespace eval punk::du { } } } - #---- + #------------------------------------------------------- + #only solos and longopts remain in the opts now + set lastarg [lindex $opts end] if {[string length $lastarg] && (![string match -* $lastarg])} { @@ -256,6 +148,10 @@ namespace eval punk::du { if {"--extra" in $lc_opts} { set opt_extra 1 } + set opt_vfs 0 + if {"--vfs" in $lc_opts} { + set opt_vfs 1 + } @@ -263,21 +159,7 @@ namespace eval punk::du { set dir_depths_remaining [list] - #if {[file normalize [file dirname $dir]] eq [file normalize $dir]} { - # error "du at root of filesystem not yet implemented.. sorry" - # - #} - set is_windows [expr {$::tcl_platform(platform) eq "windows"}] - set has_twapi 0 ;#default assumption - if {$is_windows} { - if {![catch { - package require twapi - } - ]} { - set has_twapi 1 - } - } set zero [expr {0}] # ## ### ### ### ### @@ -287,11 +169,11 @@ namespace eval punk::du { lappend folders $dir ;#itemindex 1 # ## ### ### ### ### if {![file isdirectory $dir]} { - lappend dir_depths_remaining [list $zero $zero [expr {1}] [du_lit [file tail $dir]] [file size $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}] [du_lit [file tail $dir]] $zero] + lappend dir_depths_remaining [list $zero $zero [expr {1}] [lib::du_lit [file tail $dir]] $zero] set leveldircount 1 } set level [expr {0}] @@ -324,19 +206,39 @@ namespace eval punk::du { #return #} - if {$is_windows && $has_twapi} { - lassign [du_listing_twapi $folderpath] dirs files filesizes; #twapi supports gathering file sizes during directory contents traversal + #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 { - lassign [du_listing $folderpath] dirs files filesizes ;#filesizes is empty list if listing mechanism doesn't support it (as Tcl glob doesn't) + #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 [du_lit $cont/$itm] $d $zero}] + #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 {*}[_du_new_eachdir $dirs $nextlevel $folderidx] + 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}] @@ -344,9 +246,11 @@ namespace eval punk::du { if {[llength $files] && ![llength $filesizes]} { #listing mechanism didn't supply corresponding sizes foreach filename $files { - incr bytecount [file size "$folderpath/$filename"] + #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] } @@ -449,6 +353,392 @@ namespace eval punk::du { } # 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 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 /src/modules" + } + #use the target folder as the source of projectdir info + set pathinfo [punk::repo::find_roots_and_warnings_dict $modulefoldername] + set projectdir [dict get $pathinfo closest] + set modulefolder_path $modulefoldername + } else { + #use the current working directory as the source of projectdir info + set pathinfo [punk::repo::find_roots_and_warnings_dict [pwd]] + set projectdir [dict get $pathinfo closest] + set modulefolders [lib::find_source_module_paths $projectdir] + foreach k [list modules bootsupport vendormodules] { + set knownfolder [file join $projectdir src $k] + if {$knownfolder ni $modulefolders} { + lappend modulefolders $knownfolder + } + } + set mtails [list] + foreach path $modulefolders { + lappend mtails [file tail $path] + } + if {$modulefoldername ni $mtails} { + set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" + append msg "Known module folders: [lsort $mtails]\n" + append msg "Use a name from the above list, or a fully qualified path\n" + error $msg + } + + set modulefolder_path [file join $projectdir src $modulefoldername] + + } + puts stdout "-----------------------------" + puts stdout "Using projectdir: $projectdir for visible_lib_copy_to_modulefolder" + puts stdout "-----------------------------" + + + set libfound [lsearch -all -inline [package names] $library] + if {[llength $libfound] != 1 || ![string length $libfound]} { + error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" + } + + set versions [package versions [lindex $libfound 0]] + if {$has_natsort} { + set versions [natsort::sort $versions] + } else { + set versions [lsort $versions] + } + if {![llength $versions]} { + error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" + } + puts stdout "Versions of $libfound found: $versions" + set alphaposn [lsearch $versions "999999.*"] + if {$alphaposn >= 0} { + set alpha [lindex $versions $alphaposn] + #remove and tack onto beginning.. + set versions [lreplace $versions $alphaposn $alphaposn] + set versions [list $alpha {*}$versions] + } + + set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? + if {[llength $versions] > 1} { + puts stdout "Version selected: $ver" + } + + set loadinfo [package ifneeded $libfound $ver] + if {[llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source"} { + set source_file [lindex $loadinfo 1] + } elseif {[string match "*source*" $loadinfo]} { + set parts [split $loadinfo ";"] + set sources_found [list] + foreach p $parts { + if {[lindex $p 0] eq "source"} { + #may have args.. e.g -encoding utf-8 + lappend sources_found [lindex $p end] + } + } + + if {[llength $sources_found] != 1} { + puts stderr "sorry - unable to interpreet source library location" + puts stderr "Only 1 source supported for now: received $loadinfo" + return false + } + set source_file [lindex $sources_found 0] + } else { + puts stderr "sorry - unable to interpret source library location" + puts stderr "Found info: $loadinfo" + return false + } + + if {![file exists $source_file]} { + error "Unable to verify source file existence at: $source_file" + } + set source_data [fcat $source_file -translation binary] + if {![string match "*package provide*" $source_data] || ![string match "*$libfound*" $source_data]} { + puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" + return false + } + + set moduleprefix [punk::nsprefix $libfound] + if {[string length $moduleprefix]} { + set moduleprefix_parts [punk::nsparts $moduleprefix] + set relative_path [file join {*}$moduleprefix_parts] + } else { + set relative_path "" + } + set pkgtail [punk::nstail $libfound] + set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] + + if {$opt_askme} { + puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" + puts stdout "" + puts stdout "This is not intended for binary modules - use at own risk and check results" + puts stdout "" + puts stdout "Base module path: $modulefolder_path" + puts stdout "Target path : $target_path" + puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + + if {![file exists $modulefolder_path]} { + puts stdout "Creating module base folder at $modulefolder_path" + file mkdir $modulefolder_path + } + if {![file exists [file dirname $target_path]]} { + puts stdout "Creating relative folder at [file dirname $target_path]" + file mkdir [file dirname $target_path] + } + + if {[file exists $target_path]} { + puts stdout "WARNING - module already exists at $target_path" + if {$opt_askme} { + puts stdout "Copy anyway? Y|N" + set stdin_state [fconfigure stdin] + fconfigure stdin -blocking 1 + set answer [string tolower [gets stdin]] + fconfigure stdin -blocking [dict get $stdin_state -blocking] + if {$answer ne "y"} { + puts stderr "mix visible_lib_copy_to_modulefolder aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." + return + } + } + } + + file copy -force $source_file $target_path + + return $target_path + } + proc wrap_in_multishell {filepath args} { set defaults [list -askme 1] set opts [dict merge $defaults $args] @@ -395,6 +582,7 @@ namespace eval punk::mix::cli { puts stderr "Found existing payload.. overwrite?" if {$opt_askme} { puts stdout "Are you sure you want to replace the tcl payload shown above? Y|N" + fconfigure stdin -blocking 1 set answer [string tolower [gets stdin]] fconfigure stdin -blocking [dict get $stdin_state -blocking] if {$answer ne "y"} { @@ -597,14 +785,14 @@ namespace eval punk::mix::cli { set nsq [namespace qualifiers $modulename] return [string map [list :: /] $nsq] } - #find src/something folders which are not certain known folders with other purposes, (such as: .vfs folders or vendor folders etc) and contain .tm file(s) + #find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) proc find_source_module_paths {{path {}}} { if {![string length [set candidate [punk::repo::find_candidate $path]]]} { error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" } #we can return module paths even if the project isn't yet under revision control - set src_subs [glob -nocomplain -dir $candidate/src -type d -tail *] - set antipatterns [list *.vfs vendor* lib _build doc embedded runtime] + set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] + set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] set tm_folders [list] foreach sub $src_subs { foreach anti $antipatterns { @@ -612,7 +800,7 @@ namespace eval punk::mix::cli { continue } } - set testfolder $candidate/src/$sub + set testfolder [file join $candidate src $sub] set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] if {[llength $tmfiles]} { lappend tm_folders $testfolder diff --git a/src/modules/punk/mix/templates/layouts/project/src/bootsupport/README.md b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/README.md new file mode 100644 index 00000000..89dc0de9 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/bootsupport/README.md @@ -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 +/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. + + diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 73b6d37e..79488f5e 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -1,7 +1,3 @@ -package provide punk::repl [namespace eval punk::repl { - variable version - set version 0.1 -}] #punk linerepl #todo - make repls configurable/pluggable packages @@ -826,6 +822,7 @@ proc repl::rputs {args} { if {[::tcl::mathop::<= 1 [llength $args] 3]} { set out [lindex $args end] + append out ""; #copy on write if {([llength $args] > 1) && [lindex $args 0] ne "-nonewline"} { set this_tail \n set rputschan [lindex $args 0] @@ -1051,7 +1048,7 @@ proc repl::repl_handler {inputchan prompt_config} { #=============================================================================== if {[string equal -length [string length "repl_runraw "] "repl_runraw " $commandstr]} { #pass unevaluated command to runraw - set status [catch {uplevel #0 [list runraw $commandstr]} result] + set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] } else { #puts stderr "repl uplevel 0 '$command'" set status [catch { @@ -1071,8 +1068,10 @@ proc repl::repl_handler {inputchan prompt_config} { } else { uplevel 1 {namespace inscope $punk::ns_current $run_command_string} } - } result] + } raw_result] } + set result $raw_result + append result ""; #copy on write #=============================================================================== flush stdout flush stderr @@ -1311,6 +1310,16 @@ proc repl::repl_handler {inputchan prompt_config} { } } + +package provide punk::repl [namespace eval punk::repl { + variable version + set version 0.1 +}] +package provide punk::repl [namespace eval punk::repl { + variable version + set version 0.1 +}] + #repl::start stdin #exit 0 diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index b8af87a0..983760ab 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -27,10 +27,33 @@ # # path/repo functions # -package require punk::winpath +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 @@ -112,7 +135,7 @@ namespace eval punk::repo { } proc is_git_root {{path {}}} { if {$path eq {}} { set path [pwd] } - set control $path/.git + set control [file join $path .git] expr {[file exists $control] && [file isdirectory $control]} } proc is_repo_root {{path {}}} { @@ -122,11 +145,14 @@ namespace eval punk::repo { #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 {$::tcl_platform(platform) eq "windows"} { - set normpath [punk::repo::norm [punk::winpath::winpath $path]] + 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 [punk::repo::norm $path] + set normpath $path } set unwise_paths [list "/" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"] if {[string tolower $normpath] in $unwise_paths} { @@ -243,9 +269,9 @@ namespace eval punk::repo { 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. " + 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] + 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 @@ -281,7 +307,18 @@ namespace eval punk::repo { } 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 + } + } } @@ -314,6 +351,9 @@ namespace eval punk::repo { 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 @@ -328,6 +368,19 @@ namespace eval punk::repo { } 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] } @@ -343,6 +396,20 @@ namespace eval punk::repo { } } + 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 @@ -354,7 +421,11 @@ namespace eval punk::repo { #-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} { - set base [file dirname [file normalize $path]] + 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] @@ -391,6 +462,7 @@ namespace eval punk::repo { 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] } @@ -442,7 +514,9 @@ namespace eval punk::repo { proc scanup {path cmd} { if {$path eq {}} { set path [pwd] } #based on kettle::path::scanup - set path [file normalize $path] + 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 } @@ -489,11 +563,11 @@ namespace eval punk::repo { set problems {} foreach tmp {TMPDIR TEMP TMP} { - if { [info exists env($tmp)] } { - lappend attempdirs $env($tmp) - } else { - lappend problems "No environment variable $tmp" - } + if { [info exists env($tmp)] } { + lappend attempdirs $env($tmp) + } else { + lappend problems "No environment variable $tmp" + } } switch $tcl_platform(platform) { @@ -622,7 +696,13 @@ namespace eval punk::repo { 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 @@ -642,6 +722,7 @@ namespace eval punk::repo { #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 \ @@ -649,6 +730,14 @@ namespace eval punk::repo { [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"} { diff --git a/src/modules/punk/winpath-999999.0a1.0.tm b/src/modules/punk/winpath-999999.0a1.0.tm index e1627016..bea9d5e7 100644 --- a/src/modules/punk/winpath-999999.0a1.0.tm +++ b/src/modules/punk/winpath-999999.0a1.0.tm @@ -156,11 +156,16 @@ namespace eval punk::winpath { } } + #'file attributes', and therefor this operation, is expensive (on windows at least) proc pwdshortname {{path {}}} { if {![string length $path]} { - set path [pwd] + set path [pwd] + } else { + if {[file pathtype $path] eq "relative"} { + set path [file normalize $path] + } } - return [dict get [file attributes [file normalize $path]] -shortname] + 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) @@ -172,12 +177,39 @@ namespace eval punk::winpath { 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 } @@ -197,12 +229,20 @@ namespace eval punk::winpath { 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 [pwd]/$path + #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.