diff --git a/src/bootsupport/modules/punk-0.2.7.tm b/src/bootsupport/modules/punk-0.2.8.tm similarity index 99% rename from src/bootsupport/modules/punk-0.2.7.tm rename to src/bootsupport/modules/punk-0.2.8.tm index aac58c5f..ce6dd983 100644 --- a/src/bootsupport/modules/punk-0.2.7.tm +++ b/src/bootsupport/modules/punk-0.2.8.tm @@ -9002,7 +9002,14 @@ namespace eval punk { runtime-artifact metadata target field. The raw Tcl platform-package identifiers are shown for comparison (punk::platform::normalize folds their version-dependent - aliases - amd64/aarch64/macos - into the canonical names)." + aliases - amd64/aarch64/macos - into the canonical names, and + folds the msys2 family - mingw64/mingw32/ucrt64/clang* - onto + the one 'msys' tag, since msys2's uname renders that token from + MSYSTEM rather than from the binary). + These are HOST names. What a name implies for build OUTPUT + (.exe suffixing, process tooling, which bin/runtime tier holds + a runtime) is a TARGET question src/make.tcl derives from the + name - a cygwin-family host targets win32-x86_64 by default." @values -min 0 -max 0 } proc platforms {context args} { @@ -9505,7 +9512,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.2.7 + set version 0.2.8 }] diff --git a/src/bootsupport/modules/punk/mix/templates-0.2.0.tm b/src/bootsupport/modules/punk/mix/templates-0.2.0.tm index 42e47414..5b144e73 100644 Binary files a/src/bootsupport/modules/punk/mix/templates-0.2.0.tm and b/src/bootsupport/modules/punk/mix/templates-0.2.0.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/platform-0.1.0.tm b/src/bootsupport/modules/punk/platform-0.2.0.tm similarity index 73% rename from src/vfs/_vfscommon.vfs/modules/punk/platform-0.1.0.tm rename to src/bootsupport/modules/punk/platform-0.2.0.tm index 41b41736..b74ad186 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/platform-0.1.0.tm +++ b/src/bootsupport/modules/punk/platform-0.2.0.tm @@ -7,7 +7,7 @@ # (C) 2026 # # @@ Meta Begin -# Application punk::platform 0.1.0 +# Application punk::platform 0.2.0 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -40,6 +40,29 @@ namespace eval punk::platform { # the darwin 'arm64' machine name to 'arm'; Apple silicon is 64-bit only, # so the arm token on macosx always means arm64. Elsewhere 'arm' is a # genuine 32-bit token and is preserved.) + # - os mingw64/mingw32/ucrt64/clang64/clangarm64 -> msys (G-122; see the + # MSYSTEM-variance note below) + # + #MSYSTEM VARIANCE (cygwin-family hosts on windows). An msys2-runtime tclsh + #reports tcl_platform(platform) 'unix' with an os string msys2's uname + #renders from the MSYSTEM environment variable, so ONE binary canonizes + #differently per launching shell - verified 2026-07-26 with msys2's + #/usr/bin/tclsh8.6: MSYSTEM=MSYS -> MSYS_NT-10.0-26200 (msys-x86_64), and + #MSYSTEM=MINGW64, =UCRT64 or unset (msys2 defaults it) -> MINGW64_NT-10.0-26200 + #(mingw64-x86_64). The MSYSTEM token names the shell that launched the + #process, not the binary's ABI: a genuinely MINGW-built tclsh is a native + #windows binary reporting os 'Windows NT' and canonizes as win32-*. So every + #msys2-runtime token folds to the one stable tag 'msys'. Real cygwin keeps + #its own tag 'cygwin' - a separate runtime dll and mount world, so a store + #tier serving one does not serve the other. Windows build numbers never + #reach a tag (platform::generic cuts the os at its first _ or -; normalize_os + #re-folds a raw uname-style string anyway). + #These are HOST canon names. What a tag implies for BUILD OUTPUT - .exe + #suffixing, which process tooling manages a running artifact, which + #bin/runtime store tier holds a runtime - is a TARGET question that + #src/make.tcl derives from the tag (G-122 host/target split): cygwin-family + #hosts default their build target to win32-x86_64, since the kits they bake + #are native windows binaries. #The special name 'macosx' (no cpu suffix) is the RUNTIME-tier convention for #universal (multi-arch) macOS binaries - punkbin and bin/runtime keep one #universal folder; the per-arch macosx-x86_64/macosx-arm64 names serve the @@ -83,7 +106,8 @@ namespace eval punk::platform { macosx-arm64 {status supported tiers {lib} buildsuite none notes "Apple silicon; would follow a macosx runtime arc"} freebsd-x86_64 {status supported tiers {runtime lib} buildsuite candidate notes ""} freebsd-arm64 {status supported tiers {runtime lib} buildsuite candidate notes "no artifacts yet"} - msys-x86_64 {status dormant tiers {lib} buildsuite none notes "msys/cygwin-built tclsh runtimes; utility under review"} + msys-x86_64 {status dormant tiers {runtime lib} buildsuite none notes "msys2-runtime tclsh on windows (posix personality, .exe files); host canon for every MSYSTEM shell - see normalize"} + cygwin-x86_64 {status recognized tiers {runtime lib} buildsuite none notes "cygwin-runtime tclsh on windows; separate dll/mount world from msys2, so a distinct tier"} openbsd-x86_64 {status recognized tiers {runtime} buildsuite none notes "hosted third-party runtimes possible"} netbsd-x86_64 {status recognized tiers {runtime} buildsuite none notes "hosted third-party runtimes possible"} dragonflybsd-x86_64 {status recognized tiers {runtime} buildsuite none notes "hosted third-party runtimes possible"} @@ -124,6 +148,45 @@ namespace eval punk::platform { return $platforms } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::platform::normalize_os + @cmd -name punk::platform::normalize_os\ + -summary\ + "Fold an os token to its canonical punkshell spelling."\ + -help\ + "Fold a single os token (the half of an - platform + identifier) to its canonical punkshell spelling: + macos -> macosx + mingw32|mingw64|ucrt64|clang* -> msys + MSYS_NT- -> msys + CYGWIN_NT- -> cygwin + The msys2 family folds to one tag because msys2's uname renders + the os string from the MSYSTEM environment variable: the same + binary reports MSYS_NT or MINGW64_NT depending on which shell + launched it, while a genuinely MINGW-built (native windows) + tclsh reports 'Windows NT' and canonizes as win32. Raw + uname-style strings carrying a windows build number fold too - + a build number never belongs in a platform tag. + Unrecognized tokens pass through unchanged." + @values -min 1 -max 1 + os -type string -help\ + "os token, e.g the half of platform::generic's result." + }] + } + proc normalize_os {os} { + switch -glob -- [string tolower $os] { + macos {return macosx} + msys - msys_nt-* {return msys} + mingw32 - mingw64 - mingw_nt-* - mingw32_nt-* - mingw64_nt-* {return msys} + ucrt64 - ucrt64_nt-* {return msys} + clang32 - clang64 - clangarm64 - clang32_nt-* - clang64_nt-* - clangarm64_nt-* {return msys} + cygwin_nt-* {return cygwin} + } + return $os + } + namespace eval argdoc { variable PUNKARGS lappend PUNKARGS [list { @@ -137,6 +200,9 @@ namespace eval punk::platform { platform-dir name: cpu amd64 -> x86_64, aarch64 -> arm64 os macos -> macosx (Tcl platform 1.1.x renamed modern macOS) + os mingw64/mingw32/ucrt64/clang* -> msys (one stable tag for + the msys2 runtime family - the reported name follows MSYSTEM, + not the binary; see punk::platform::normalize_os) macosx cpu arm -> arm64 (platform::generic's arm* glob folds the darwin arm64 machine name to arm; Apple silicon is 64-bit only - non-macosx 'arm' stays 32-bit arm) @@ -150,18 +216,13 @@ namespace eval punk::platform { proc normalize {platform} { set parts [split $platform -] if {[llength $parts] < 2} { - #single-token names (e.g the universal 'macosx') - fold macos only - if {$platform eq "macos"} { - return macosx - } - return $platform + #single-token names (e.g the universal 'macosx') - fold the os token only + return [normalize_os $platform] } #os may itself contain a dash in principle - treat last token as cpu set cpu [lindex $parts end] set os [join [lrange $parts 0 end-1] -] - switch -- $os { - macos {set os macosx} - } + set os [normalize_os $os] switch -- $cpu { amd64 {set cpu x86_64} aarch64 {set cpu arm64} @@ -232,6 +293,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::platform [namespace eval punk::platform { variable version - set version 0.1.0 + set version 0.2.0 }] return diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm deleted file mode 100644 index 02415ccd..00000000 --- a/src/bootsupport/modules/punk/zip-0.1.1.tm +++ /dev/null @@ -1,914 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt -# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm -# -# 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) 2024 JMN -# (C) 2009 Path Thoyts -# -# @@ Meta Begin -# Application punk::zip 0.1.1 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::zip 0 0.1.1] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::zip] -#[keywords module zip fileformat] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::zip -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::zip -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package {punk::args}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::zip { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - #variable xyz - - #*** !doctools - #[subsection {Namespace punk::zip}] - #[para] Core API functions for punk::zip - #[list_begin definitions] - - proc Path_a_atorbelow_b {path_a path_b} { - return [expr {[StripPath $path_b $path_a] ne $path_a}] - } - proc Path_a_at_b {path_a path_b} { - return [expr {[StripPath $path_a $path_b] eq "." }] - } - - proc Path_strip_alreadynormalized_prefixdepth {path prefix} { - if {$prefix eq ""} { - return $path - } - set pathparts [file split $path] - set prefixparts [file split $prefix] - if {[llength $prefixparts] >= [llength $pathparts]} { - return "" - } - return [file join \ - {*}[lrange \ - $pathparts \ - [llength $prefixparts] \ - end]] - } - - #StripPath - borrowed from tcllib fileutil - # ::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 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 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 - } - } - - proc Timet_to_dos {time_t} { - #*** !doctools - #[call [fun Timet_to_dos] [arg time_t]] - #[para] convert a unix timestamp into a DOS timestamp for ZIP times. - #[example { - # DOS timestamps are 32 bits split into bit regions as follows: - # 24 16 8 0 - # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ - # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| - # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ - #}] - set s [clock format $time_t -format {%Y %m %e %k %M %S}] - scan $s {%d %d %d %d %d %d} year month day hour min sec - expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) - | ($hour << 11) | ($min << 5) | ($sec >> 1)} - } - punk::args::define { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - #If we don't include --, the call walk -- .. will return nothing as 'base' will receive the -- - -- -type none -optional 1 - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } - proc walk {args} { - #*** !doctools - #[call [fun walk] [arg ?options?] [arg base]] - #[para] Walk a directory tree rooted at base - #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g - #[example { - # punk::zip::walk -exclude {CVS/* *~.#*} library - #}] - - #todo: -relative 0|1 flag? - set argd [punk::args::parse $args withid ::punk::zip::walk] - set base [dict get $argd values base] - set fileglobs [dict get $argd values fileglobs] - set subpath [dict get $argd opts -subpath] - set excludes [dict get $argd opts -excludes] - set emptydirs [dict get $argd opts -emptydirs] - - set received [dict get $argd received] - - set imatch [list] - foreach fg $fileglobs { - lappend imatch [file join $subpath $fg] - } - - if {![dict exists $received -resultrelative]} { - set relto $base - set prefix "" - } else { - set relto [file normalize [dict get $argd opts -resultrelative]] - if {$relto ne ""} { - if {![Path_a_atorbelow_b $base $relto]} { - error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" - } - set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] - } else { - set prefix $base - } - } - - set result {} - #set imatch [file join $subpath $match] - set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] - foreach file $files { - set excluded 0 - foreach glob $excludes { - if {[string match $glob $file]} { - set excluded 1 - break - } - } - if {!$excluded} {lappend result [file join $prefix $file]} - } - foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { - set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] - set subdir_entries [list] - set thisdir_match [list] - set has_file 0 - foreach sd $submatches { - set fullpath [file join $prefix $sd] ;#file join destroys trailing slash - if {[string index $sd end] eq "/"} { - lappend subdir_entries $fullpath/ - } else { - set has_file 1 - lappend subdir_entries $fullpath - } - } - if {$emptydirs} { - set thisdir_match [list "[file join $prefix $dir]/"] - } else { - if {$has_file} { - set thisdir_match [list "[file join $prefix $dir]/"] - } else { - set subdir_entries [list] - } - } - #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" - #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash - #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. - set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] - } - return $result - } - - #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) - #Otherwise extract an internal preamble. - #if neither -? - #review - reconsider auto-determination of internal vs external preamble - punk::args::define { - @id -id ::punk::zip::extract_preamble - @cmd -name punk::zip::extract_preamble -help\ - "Split a zipfs based executable or library into its constituent - binary and zip parts. - - Note that the binary preamble might be either 'within' the zip offsets, - or simply catenated prior to an unadjusted zip. - Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file - ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip - ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper - split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. - - Either way, extract_preamble can usually separate them, but in the unusual case that there is both an - external preamble and a preamble within the zip, only the external preamble will be split, with the - internal one remaining in the zip. - - The inverse of this process would be to extract the .zip file created by this split to a folder, - e.g extracted_zip_folder (adjusting contents as required) and then to run: - zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" - " - @values -min 2 -max 3 - infile -type file -optional 0 -help\ - "Name of existing tcl executable or shared lib with attached zipfs filesystem" - outfile_preamble -optional 0 -type file -help\ - "Name of output file for binary preamble to be extracted to. - If this file already exists, an error will be raised" - outfile_zip -default "" -type file -help\ - "Name of output file for zip data to be extracted to. - If this file already exists, an error will be raised" - } - proc extract_preamble {args} { - set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] - lassign [dict values $argd] leaders opts values received - - set infile [dict get $values infile] - set outfile_preamble [dict get $values outfile_preamble] - set outfile_zip [dict get $values outfile_zip] - - set inzip [open $infile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - if {[file exists $outfile_preamble]} { - error "outfile_preamble $outfile_preamble already exists - please remove first" - } - if {$outfile_zip ne ""} { - if {[file exists $outfile_zip] && [file size $outfile_zip]} { - error "outfile_zip $outfile_zip already exists - please remove first" - } - } - chan seek $inzip 0 end - set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent - chan seek $inzip 0 start - #only scan last 64k - cover max signature size?? review - if {$insize < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$insize - 65559}] - } - chan seek $inzip $tailsearch_start start - set scan [read $inzip] - #EOCD - End Of Central Directory record - set start_of_end [string last "\x50\x4b\x05\x06" $scan] - puts stdout "==>start_of_end: $start_of_end" - - if {$start_of_end == -1} { - #no zip eocdr - consider entire file to be the zip preamble - set baseoffset $insize - } else { - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - chan seek $inzip $filerelative_eocd_posn - set cdir_record_plus [read $inzip] ;#can have trailing data - binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - #rule out a false positive from within a nonzip (e.g plain exe) - #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. - #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway - #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros - #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review - if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { - #review - should keep searching? - #for now we assume not a zip - set baseoffset $insize - } else { - #use the central dir size to jump back tko start of central dir - #determine if diroffset is file or archive relative - - set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] - puts stdout "---> [read $inzip 4]" - if {$filerelative_cdir_start > $eocd(diroffset)} { - #'external preamble' easy case - # - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier - #though we are assuming zip offsets are not corrupted - set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] - } else { - #'internal preamble' hard case - # - either no preamble - or offsets have been adjusted to be file relative. - #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers - #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? - #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - - #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) - #we can't assume they're ordered in any particular way - so we in theory have to look at them all. - set baseoffset "unknown" - chan seek $inzip $filerelative_cdir_start start - #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - #load the whole central dir into cdir - - #todo! loop through all cdr file headers - find highest offset? - #tclZipfs.c just looks at first file header in Central Directory - #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW - - set cdirdata [read $inzip $eocd(dirsize)] - binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ - cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ - cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) - - #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file - chan seek $inzip $cdir(relativeoffset) - #let's at least check that we landed on a local file header.. - set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field - binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ - lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) - #dec2hex 67324752 = 4034B50 = PK\3\4 - puts stdout "1st local file header sig: $lfh(signature)" - if {$lfh(signature) == 67324752} { - #looks like a local file header - #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) - set baseoffset $cdir(relativeoffset) - } - } - puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" - } - } - puts stdout "baseoffset: $baseoffset" - #expect CDFH PK\1\2 - #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) - #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script - - if {![string is integer -strict $baseoffset]} { - error "unable to determine zip baseoffset of file $infile" - } - - if {$baseoffset < $insize} { - set pout [open $outfile_preamble w] - fconfigure $pout -encoding iso8859-1 -translation binary - chan seek $inzip 0 start - chan copy $inzip $pout -size $baseoffset - close $pout - if {$outfile_zip ne ""} { - #todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile - set zout [open $outfile_zip w] - fconfigure $zout -encoding iso8859-1 -translation binary - chan copy $inzip $zout - close $zout - } - close $inzip - } else { - #no valid (from our perspective) eocdr found - baseoffset has been set to insize - close $inzip - file copy $infile $outfile_preamble - if {$outfile_zip ne ""} { - #touch equiv? - set fd [open $outfile_zip w] - close $fd - } - } - } - - - - punk::args::define { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry\ - -summary\ - "Add zip-entry for file at 'path'"\ - -help\ - "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } - - # Addentry - was Mkzipfile -- - # - # FIX ME: should handle the current offset for non-seekable channels - # - proc Addentry {args} { - #*** !doctools - #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] - #[para] Add a single file to a zip archive - #[para] The zipchan channel should already be open and binary. - #[para] You can provide a -comment for the file. - #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - - set argd [punk::args::parse $args withid ::punk::zip::Addentry] - set zipchan [dict get $argd values zipchan] - set base [dict get $argd values base] - set path [dict get $argd values path] - set zipdataoffset [dict get $argd values zipdataoffset] - - set comment [dict get $argd opts -comment] - - set fullpath [file join $base $path] - set mtime [Timet_to_dos [file mtime $fullpath]] - set utfpath [encoding convertto utf-8 $path] - set utfcomment [encoding convertto utf-8 $comment] - set flags [expr {(1<<11)}] ;# utf-8 comment and path - set method 0 ;# store 0, deflate 8 - set attr 0 ;# text or binary (default binary) - set version 20 ;# minumum version req'd to extract - set extra "" - set crc 0 - set size 0 - set csize 0 - set data "" - set seekable [expr {[tell $zipchan] != -1}] - if {[file isdirectory $fullpath]} { - set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) - #set attrex 0x40000010 - } elseif {[file executable $fullpath]} { - set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) - } else { - set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) - if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { - set attr 1 ;# text - } - } - - if {[file isfile $fullpath]} { - set size [file size $fullpath] - if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} - } - - - set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip - set local [binary format a4sssiiiiss PK\03\04 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]] - append local $utfpath $extra - puts -nonewline $zipchan $local - - if {[file isfile $fullpath]} { - # If the file is under 2MB then zip in one chunk, otherwize we use - # streaming to avoid requiring excess memory. This helps to prevent - # storing re-compressed data that may be larger than the source when - # handling PNG or JPEG or nested ZIP files. - if {$size < 0x00200000} { - set fin [open $fullpath rb] - set data [read $fin] - set crc [zlib crc32 $data] - set cdata [zlib deflate $data] - if {[string length $cdata] < $size} { - set method 8 - set data $cdata - } - close $fin - set csize [string length $data] - puts -nonewline $zipchan $data - } else { - set method 8 - set fin [open $fullpath rb] - set zlib [zlib stream deflate] - while {![eof $fin]} { - set data [read $fin 4096] - set crc [zlib crc32 $data $crc] - $zlib put $data - if {[string length [set zdata [$zlib get]]]} { - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - } - } - close $fin - $zlib finalize - set zdata [$zlib get] - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - $zlib close - } - - if {$seekable} { - # update the header if the output is seekable - set local [binary format a4sssiiii PK\03\04 \ - $version $flags $method $mtime $crc $csize $size] - set current [tell $zipchan] - seek $zipchan $channeloffset - puts -nonewline $zipchan $local - seek $zipchan $current - } else { - # Write a data descriptor record - set ddesc [binary format a4iii PK\7\8 $crc $csize $size] - puts -nonewline $zipchan $ddesc - } - } - - #PK\x01\x02 Cdentral directory file header - #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 - set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) - - set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]\ - [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. - append hdr $utfpath $extra $utfcomment - return $hdr - } - - #### REVIEW!!! - #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') - # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) - #### - - - punk::args::define { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -summary\ - "Create a zip archive in 'filename'."\ - -help\ - "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help\ - "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix." - -return -default "pretty" -choices {pretty list none}\ - -help\ - "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help\ - "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" - -runtime -default ""\ - -help\ - "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review)" - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "Scan for contents within this folder or current directory if not provided." - -base -default ""\ - -help\ - "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - -- -type none -help\ - "End of options marker" - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help\ - "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } - - # zip::mkzip -- - # - # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # - proc mkzip {args} { - #todo - doctools - [arg ?globs...?] syntax? - - #*** !doctools - #[call [fun mkzip]\ - # [opt "[option -offsettype] [arg offsettype]"]\ - # [opt "[option -return] [arg returntype]"]\ - # [opt "[option -zipkit] [arg 0|1]"]\ - # [opt "[option -runtime] [arg preamble_filename]"]\ - # [opt "[option -comment] [arg zipfilecomment]"]\ - # [opt "[option -directory] [arg dir_to_zip]"]\ - # [opt "[option -base] [arg archive_root]"]\ - # [opt "[option -exclude] [arg globlist]"]\ - # [arg zipfilename]\ - # [arg ?glob...?]] - #[para] Create a zip archive in 'zipfilename' - #[para] If a file already exists, an error will be raised. - #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - - set argd [punk::args::parse $args withid ::punk::zip::mkzip] - set filename [dict get $argd values filename] - if {$filename eq ""} { - error "mkzip filename cannot be empty string" - } - if {[regexp {[?*]} $filename]} { - #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name - error "mkzip filename should not contain glob characters ? *" - } - if {[file exists $filename]} { - error "mkzip filename:$filename already exists" - } - dict for {k v} [dict get $argd opts] { - switch -- $k { - -comment { - dict set argd opts $k [encoding convertto utf-8 $v] - } - -directory - -base { - dict set argd opts $k [file normalize $v] - } - } - } - - array set opts [dict get $argd opts] - - - if {$opts(-directory) ne ""} { - if {$opts(-base) ne ""} { - #-base and -directory have been normalized already - if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" - } - set base $opts(-base) - set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] - } else { - set base $opts(-directory) - set relpath "" - } - #will pick up intermediary folders as paths (ending with trailing slash) - set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] - - set norm_filename [file normalize $filename] - set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) - if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { - #check that we aren't adding the zipfile to itself - #REVIEW - now that we open zipfile after scanning - this isn't really a concern! - #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) - #In the case of -force - we may want to delay replacement of original until scan is done? - - #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each - #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths - set self_globs_match 0 - foreach g [dict get $argd values globs] { - if {[string match $g [file tail $filename]]} { - set self_globs_match 1 - break - } - } - if {$self_globs_match} { - #still dangerous - set self_excluded 0 - foreach e $opts(-exclude) { - if {[string match $e [file tail $filename]]} { - set self_excluded 1 - break - } - } - if {!$self_excluded} { - #still dangerous - likely to be in resultset - check each path - #puts stderr "zip file $filename is below directory $opts(-directory)" - set self_is_matched 0 - set i 0 - foreach p $paths { - set norm_p [file normalize [file join $opts(-directory) $p]] - if {[Path_a_at_b $norm_filename $norm_p]} { - set self_is_matched 1 - break - } - incr i - } - if {$self_is_matched} { - puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" - set paths [lremove $paths $i] - } - } - } - } - } else { - #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! - #ie - only the exact *files* matching the glob are stored. - set paths [list] - set dir [pwd] - if {$opts(-base) ne ""} { - if {![Path_a_atorbelow_b $dir $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above current directory" - } - set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] - } else { - set relpath "" - } - set base $opts(-base) - - set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] - foreach m $matches { - if {$m eq $filename} { - #puts stderr "--> excluding $filename" - continue - } - set isok 1 - foreach e [concat $opts(-exclude) $filename] { - if {[string match $e $m]} { - set isok 0 - break - } - } - if {$isok} { - lappend paths [file join $relpath $m] - } - } - } - - if {![llength $paths]} { - return "" - } - - set zf [open $filename wb] - if {$opts(-runtime) ne ""} { - #todo - strip any existing vfs - option to merge contents.. only if zip attached? - set rt [open $opts(-runtime) rb] - fcopy $rt $zf - close $rt - } elseif {$opts(-zipkit)} { - #TODO - update to zipfs ? - #see modpod - set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" - append zkd "package require vfs::zip\n" - append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" - append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" - append zkd " source \[file join \[info script\] main.tcl\]\n" - append zkd "}\n" - append zkd \x1A - puts -nonewline $zf $zkd - } - - #todo - subtract this from the endrec offset - if {$opts(-offsettype) eq "archive"} { - set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 - } else { - set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ - } - - set count 0 - set cd "" - - set members [list] - foreach path $paths { - #puts $path - lappend members $path - append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath - incr count - } - set cdoffset [tell $zf] - set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ - [string length $opts(-comment)]] - append endrec $opts(-comment) - puts -nonewline $zf $cd - puts -nonewline $zf $endrec - close $zf - - set result "" - switch -exact -- $opts(-return) { - list { - set result $members - } - pretty { - if {[info commands showlist] ne ""} { - set result [plist -channel none members] - } else { - set result $members - } - } - none { - set result "" - } - } - return $result - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::zip ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::zip::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace punk::zip::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::zip [tcl::namespace::eval punk::zip { - variable pkg punk::zip - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/bootsupport/modules/punk/zip-0.2.0.tm b/src/bootsupport/modules/punk/zip-0.2.0.tm new file mode 100644 index 00000000..eb1651da --- /dev/null +++ b/src/bootsupport/modules/punk/zip-0.2.0.tm @@ -0,0 +1,1698 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# 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) 2024 JMN +# (C) 2009 Path Thoyts +# +# @@ Meta Begin +# Application punk::zip 0.2.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::zip 0 0.2.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::zip] +#[keywords module zip fileformat] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::zip +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::zip +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::zip}] + #[para] Core API functions for punk::zip + #[list_begin definitions] + + proc Path_a_atorbelow_b {path_a path_b} { + return [expr {[StripPath $path_b $path_a] ne $path_a}] + } + proc Path_a_at_b {path_a path_b} { + return [expr {[StripPath $path_a $path_b] eq "." }] + } + + proc Path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + set pathparts [file split $path] + set prefixparts [file split $prefix] + if {[llength $prefixparts] >= [llength $pathparts]} { + return "" + } + return [file join \ + {*}[lrange \ + $pathparts \ + [llength $prefixparts] \ + end]] + } + + #StripPath - borrowed from tcllib fileutil + # ::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 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 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 + } + } + + proc Timet_to_dos {time_t} { + #*** !doctools + #[call [fun Timet_to_dos] [arg time_t]] + #[para] convert a unix timestamp into a DOS timestamp for ZIP times. + #[example { + # DOS timestamps are 32 bits split into bit regions as follows: + # 24 16 8 0 + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + #}] + set s [clock format $time_t -format {%Y %m %e %k %M %S}] + scan $s {%d %d %d %d %d %d} year month day hour min sec + expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) + | ($hour << 11) | ($min << 5) | ($sec >> 1)} + } + + #Inverse of Timet_to_dos. DOS timestamps carry no timezone, and Timet_to_dos + #formats in local time - so this scans in local time to keep the pair symmetric. + #Entries stored with an unrepresentable date (zero, or corrupt) yield 0. + proc Dos_to_timet {dosdatetime} { + set dosdate [expr {($dosdatetime >> 16) & 0xFFFF}] + set dostime [expr {$dosdatetime & 0xFFFF}] + set year [expr {(($dosdate >> 9) & 0x7F) + 1980}] + set month [expr {($dosdate >> 5) & 0x0F}] + set day [expr {$dosdate & 0x1F}] + set hour [expr {($dostime >> 11) & 0x1F}] + set minute [expr {($dostime >> 5) & 0x3F}] + set second [expr {($dostime & 0x1F) << 1}] + if {$month < 1 || $month > 12 || $day < 1 || $day > 31 || $hour > 23 || $minute > 59 || $second > 59} { + return 0 + } + set stamp [format {%04d %02d %02d %02d %02d %02d} $year $month $day $hour $minute $second] + if {[catch {clock scan $stamp -format {%Y %m %d %H %M %S}} timet]} { + return 0 + } + return $timet + } + + #Compression method ids as they appear in a zip central directory. + #punk::zip READS 0 (store) and 8 (deflate); the rest are named so an + #unsupported archive is refused by name rather than by number. + variable methodnames + set methodnames [dict create {*}{ + 0 store + 1 shrink + 2 reduce1 + 3 reduce2 + 4 reduce3 + 5 reduce4 + 6 implode + 8 deflate + 9 deflate64 + 10 pkware-implode + 12 bzip2 + 14 lzma + 16 cmpsc + 18 terse + 19 lz77 + 20 zstd-deprecated + 93 zstd + 94 mp3 + 95 xz + 96 jpeg + 97 wavpack + 98 ppmd + 99 aes + }] + + proc Method_name {method} { + variable methodnames + if {[dict exists $methodnames $method]} { + return [dict get $methodnames $method] + } + return method-$method + } + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + #If we don't include --, the call walk -- .. will return nothing as 'base' will receive the -- + -- -type none -optional 1 + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } + proc walk {args} { + #*** !doctools + #[call [fun walk] [arg ?options?] [arg base]] + #[para] Walk a directory tree rooted at base + #[para] the -excludes list can be a set of glob expressions to match against files and avoid + #[para] e.g + #[example { + # punk::zip::walk -exclude {CVS/* *~.#*} library + #}] + + #todo: -relative 0|1 flag? + set argd [punk::args::parse $args withid ::punk::zip::walk] + set base [dict get $argd values base] + set fileglobs [dict get $argd values fileglobs] + set subpath [dict get $argd opts -subpath] + set excludes [dict get $argd opts -excludes] + set emptydirs [dict get $argd opts -emptydirs] + + set received [dict get $argd received] + + set imatch [list] + foreach fg $fileglobs { + lappend imatch [file join $subpath $fg] + } + + if {![dict exists $received -resultrelative]} { + set relto $base + set prefix "" + } else { + set relto [file normalize [dict get $argd opts -resultrelative]] + if {$relto ne ""} { + if {![Path_a_atorbelow_b $base $relto]} { + error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" + } + set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] + } else { + set prefix $base + } + } + + set result {} + #set imatch [file join $subpath $match] + set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] + foreach file $files { + set excluded 0 + foreach glob $excludes { + if {[string match $glob $file]} { + set excluded 1 + break + } + } + if {!$excluded} {lappend result [file join $prefix $file]} + } + foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { + set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] + set subdir_entries [list] + set thisdir_match [list] + set has_file 0 + foreach sd $submatches { + set fullpath [file join $prefix $sd] ;#file join destroys trailing slash + if {[string index $sd end] eq "/"} { + lappend subdir_entries $fullpath/ + } else { + set has_file 1 + lappend subdir_entries $fullpath + } + } + if {$emptydirs} { + set thisdir_match [list "[file join $prefix $dir]/"] + } else { + if {$has_file} { + set thisdir_match [list "[file join $prefix $dir]/"] + } else { + set subdir_entries [list] + } + } + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] + } + return $result + } + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Archive structure - the shared reader machinery. + # + # Every reading surface (extract_preamble, archive_info, members, unzip) goes + # through Archive_read, so a plain zip and a zip attached to an executable are + # one code path, and the archive-relative vs file-relative offset convention is + # decided in exactly one place. + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + #Locate and validate the End Of Central Directory record. + #Scans candidate PK\5\6 signatures from the end of the file backwards - a plain + #executable can contain that byte sequence in its data, so a candidate is only + #accepted if it describes a single-disk directory that really begins with PK\1\2. + #The first pass also requires the record to end exactly at EOF (comment length + #consistent); a second pass drops that so archives with trailing junk still read. + proc Eocd_scan {chan filesize} { + set info [dict create {*}{ + status nozip + reason {no end-of-central-directory record found} + eocdoffset -1 + cdiroffset -1 + cdirsize 0 + count 0 + diroffset 0 + offsetbase 0 + comment {} + }] + dict set info filesize $filesize + if {$filesize < 22} { + return $info + } + set tailstart [expr {$filesize < 65559 ? 0 : $filesize - 65559}] + chan seek $chan $tailstart start + set tail [read $chan] + set candidates [list] + set idx [string length $tail] + while {1} { + set p [string last "\x50\x4b\x05\x06" $tail [expr {$idx - 1}]] + if {$p < 0} { + break + } + lappend candidates [expr {$p + $tailstart}] + set idx $p + } + foreach strict {1 0} { + foreach eocdoffset $candidates { + set try [Eocd_try $chan $filesize $eocdoffset $strict] + if {[dict get $try status] ne "reject"} { + return $try + } + } + } + return $info + } + + proc Eocd_try {chan filesize eocdoffset strict} { + if {$eocdoffset + 22 > $filesize} { + return [dict create status reject] + } + chan seek $chan $eocdoffset start + set rec [read $chan 22] + binary scan $rec issssiis sig disknbr cdirdisk numondisk totalnum cdirsize diroffset commentlen + set disknbr [expr {$disknbr & 0xFFFF}] + set cdirdisk [expr {$cdirdisk & 0xFFFF}] + set numondisk [expr {$numondisk & 0xFFFF}] + set totalnum [expr {$totalnum & 0xFFFF}] + set commentlen [expr {$commentlen & 0xFFFF}] + set cdirsize [expr {$cdirsize & 0xFFFFFFFF}] + set diroffset [expr {$diroffset & 0xFFFFFFFF}] + #single-disk archives only - anything else is a spanned archive or a false positive + if {$disknbr != 0 || $cdirdisk != 0 || $numondisk != $totalnum} { + return [dict create status reject] + } + if {$strict && $eocdoffset + 22 + $commentlen != $filesize} { + return [dict create status reject] + } + set info [dict create {*}{ + status ok + reason {} + } filesize $filesize {*}{ + } eocdoffset $eocdoffset {*}{ + } cdirsize $cdirsize {*}{ + } count $totalnum {*}{ + } diroffset $diroffset {*}{ + }] + #A saturated field means the real value lives in a zip64 record we do not read. + if {$totalnum == 0xFFFF || $cdirsize == 0xFFFFFFFF || $diroffset == 0xFFFFFFFF} { + dict set info status unsupported + dict set info reason "zip64 archive - punk::zip reads single-disk zip32 archives only" + dict set info cdiroffset -1 + dict set info offsetbase 0 + dict set info comment "" + return $info + } + set cdiroffset [expr {$eocdoffset - $cdirsize}] + if {$cdiroffset < 0} { + return [dict create status reject] + } + if {$totalnum > 0} { + chan seek $chan $cdiroffset start + if {[read $chan 4] ne "\x50\x4b\x01\x02"} { + return [dict create status reject] + } + } elseif {$cdirsize != 0} { + return [dict create status reject] + } + #The recorded directory offset is either archive-relative (the directory sits + #that far past a preamble) or file-relative (it IS the file position). The + #difference between where the directory actually is and where the record says + #it is therefore gives the preamble length directly; negative means neither + #reading holds and this candidate is not a real EOCD. + set offsetbase [expr {$cdiroffset - $diroffset}] + if {$offsetbase < 0} { + return [dict create status reject] + } + set comment "" + if {$commentlen > 0} { + chan seek $chan [expr {$eocdoffset + 22}] start + set comment [read $chan $commentlen] + } + dict set info cdiroffset $cdiroffset + dict set info offsetbase $offsetbase + dict set info comment $comment + return $info + } + + punk::args::define { + @id -id ::punk::zip::Cdir_records + @cmd -name punk::zip::Cdir_records\ + -summary\ + "Parse every central directory record of an archive"\ + -help\ + "Walk ALL central directory file headers and return one member dict per + entry, in stored order. Sizes and offsets come from the central + directory, which sidesteps data descriptors entirely. + See punk::zip::members for the member dict keys." + @values -min 2 -max 2 + chan -help "open binary channel positioned anywhere in the archive" + info -type dict -help "archive dict from Eocd_scan with status ok" + } + proc Cdir_records {chan info} { + set cdiroffset [dict get $info cdiroffset] + set cdirsize [dict get $info cdirsize] + set count [dict get $info count] + set offsetbase [dict get $info offsetbase] + if {$count == 0} { + return [list] + } + chan seek $chan $cdiroffset start + set cd [read $chan $cdirsize] + if {[string length $cd] != $cdirsize} { + error "punk::zip: central directory truncated - wanted $cdirsize bytes at $cdiroffset, got [string length $cd]" + } + set members [list] + set pos 0 + for {set i 0} {$i < $count} {incr i} { + if {$pos + 46 > $cdirsize} { + error "punk::zip: central directory truncated - record [expr {$i + 1}] of $count starts beyond the directory" + } + binary scan $cd @${pos}issssssiiisssssii sig madeby version flags method dostime dosdate crc csize size namelen extralen commentlen disknbr iattr eattr offset + if {$sig != 33639248} { + error "punk::zip: bad central directory record [expr {$i + 1}] of $count - expected signature PK\\1\\2" + } + set madeby [expr {$madeby & 0xFFFF}] + set version [expr {$version & 0xFFFF}] + set flags [expr {$flags & 0xFFFF}] + set method [expr {$method & 0xFFFF}] + set dostime [expr {$dostime & 0xFFFF}] + set dosdate [expr {$dosdate & 0xFFFF}] + set namelen [expr {$namelen & 0xFFFF}] + set extralen [expr {$extralen & 0xFFFF}] + set commentlen [expr {$commentlen & 0xFFFF}] + set iattr [expr {$iattr & 0xFFFF}] + set crc [expr {$crc & 0xFFFFFFFF}] + set csize [expr {$csize & 0xFFFFFFFF}] + set size [expr {$size & 0xFFFFFFFF}] + set eattr [expr {$eattr & 0xFFFFFFFF}] + set offset [expr {$offset & 0xFFFFFFFF}] + set namestart [expr {$pos + 46}] + set rawname [string range $cd $namestart [expr {$namestart + $namelen - 1}]] + set commentstart [expr {$namestart + $namelen + $extralen}] + set rawcomment [string range $cd $commentstart [expr {$commentstart + $commentlen - 1}]] + set packedtime [expr {($dosdate << 16) | $dostime}] + set name [Decode_text $rawname $flags] + set hostsystem [expr {($madeby >> 8) & 0xFF}] + lappend members [dict create {*}{ + } name $name {*}{ + } isdirectory [Is_directory_entry $name $size $eattr $hostsystem] {*}{ + } size $size {*}{ + } csize $csize {*}{ + } method $method {*}{ + } methodname [Method_name $method] {*}{ + } mtime [Dos_to_timet $packedtime] {*}{ + } dostime $packedtime {*}{ + } crc $crc {*}{ + } offset $offset {*}{ + } fileoffset [expr {$offsetbase + $offset}] {*}{ + } flags $flags {*}{ + } encrypted [expr {($flags & 0x41) != 0}] {*}{ + } attributes $eattr {*}{ + } iattributes $iattr {*}{ + } madeby $madeby {*}{ + } hostsystem $hostsystem {*}{ + } version $version {*}{ + } comment [Decode_text $rawcomment $flags] {*}{ + }] + incr pos [expr {46 + $namelen + $extralen + $commentlen}] + } + return $members + } + + #Member names and comments are utf-8 when general purpose bit 11 is set + #(punk::zip::mkzip always sets it), and cp437 otherwise. + proc Decode_text {bytes flags} { + if {$bytes eq ""} { + return "" + } + if {$flags & 0x800} { + return [encoding convertfrom utf-8 $bytes] + } + if {[catch {encoding convertfrom cp437 $bytes} decoded]} { + set decoded [encoding convertfrom iso8859-1 $bytes] + } + return $decoded + } + + #A trailing slash is the portable marker; the FAT directory attribute and the + #unix S_IFDIR mode bits are accepted as secondary evidence for archives that + #store directory entries without one. + proc Is_directory_entry {name size eattr hostsystem} { + if {[string index $name end] eq "/"} { + return 1 + } + if {$hostsystem == 3 && (($eattr >> 16) & 0xF000) == 0x4000} { + return 1 + } + if {$size == 0 && ($eattr & 0x10)} { + return 1 + } + return 0 + } + + punk::args::define { + @id -id ::punk::zip::Archive_read + @cmd -name punk::zip::Archive_read\ + -summary\ + "Read the structure of a zip archive on an open channel"\ + -help\ + "Derive the archive geometry and read every central directory record. + Returns a 2-element dict: 'info' (see punk::zip::archive_info for the + keys) and 'members' (see punk::zip::members). + + Never raises for a file that simply is not an archive - callers decide + what a non-ok status means. Does raise for an archive whose central + directory is truncated or malformed." + @values -min 1 -max 1 + chan -help "open channel - reconfigured to binary translation by this call" + } + proc Archive_read {chan} { + chan configure $chan -translation binary + chan seek $chan 0 end + set filesize [tell $chan] + set info [Eocd_scan $chan $filesize] + if {[dict get $info status] ne "ok"} { + #the whole file is preamble as far as any splitting caller is concerned + dict set info dataoffset $filesize + dict set info offsetstyle none + return [dict create info $info members {}] + } + set members [Cdir_records $chan $info] + set offsetbase [dict get $info offsetbase] + set minoffset "" + foreach m $members { + set o [dict get $m offset] + if {$minoffset eq "" || $o < $minoffset} { + set minoffset $o + } + } + if {$minoffset eq ""} { + set minoffset 0 + } + if {$offsetbase > 0} { + #external preamble, archive-relative offsets: the archive begins exactly + #where its own offsets say it does + set dataoffset $offsetbase + set offsetstyle archive + } else { + #file-relative offsets (or no preamble at all): the archive begins at the + #topmost local file header the directory points to. Looking at ALL records + #rather than just the first is what makes this reliable - records are in no + #guaranteed order. + set dataoffset $minoffset + set offsetstyle [expr {$minoffset > 0 ? "file" : "plain"}] + } + dict set info dataoffset $dataoffset + dict set info offsetstyle $offsetstyle + if {[llength $members]} { + #the derivation is only trustworthy if a local file header really sits + #where the first record says it does + chan seek $chan [expr {$offsetbase + $minoffset}] start + if {[read $chan 4] ne "\x50\x4b\x03\x04"} { + dict set info status unsupported + dict set info reason "no local file header at derived archive position [expr {$offsetbase + $minoffset}] - offsets do not describe this file" + } + } + return [dict create info $info members $members] + } + + #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) + #Otherwise extract an internal preamble. + #if neither -? + #review - reconsider auto-determination of internal vs external preamble + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile_preamble]} { + error "outfile_preamble $outfile_preamble already exists - please remove first" + } + if {$outfile_zip ne ""} { + if {[file exists $outfile_zip] && [file size $outfile_zip]} { + error "outfile_zip $outfile_zip already exists - please remove first" + } + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + + #Archive_read does the whole derivation: it finds the EOCD (rejecting the + #PK\5\6 byte sequences that occur in plain executables), decides whether the + #recorded offsets are archive-relative or file-relative, and walks ALL central + #directory records to find the topmost local file header in the file-relative + #case. dataoffset is the split point either way. + #expect CDFH PK\1\2 + #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + set info [dict get [Archive_read $inzip] info] + switch -- [dict get $info status] { + ok { + set baseoffset [dict get $info dataoffset] + } + nozip { + #no zip eocdr - consider entire file to be the zip preamble + set baseoffset $insize + } + default { + close $inzip + error "unable to determine zip baseoffset of file $infile - [dict get $info reason]" + } + } + + if {$baseoffset < $insize} { + set pout [open $outfile_preamble w] + fconfigure $pout -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $pout -size $baseoffset + close $pout + if {$outfile_zip ne ""} { + #A file-relative archive splits into a .zip whose offsets still count + #from the removed preamble - readers that only accept a bare .zip choke + #on it. punk::zip's own reader never needs the split: point it at the + #ORIGINAL file and the derived base offset makes the shape irrelevant. + #Rewriting the offsets here stays open for callers that must hand a + #plain .zip to something else. + set zout [open $outfile_zip w] + fconfigure $zout -encoding iso8859-1 -translation binary + chan copy $inzip $zout + close $zout + } + close $inzip + } else { + #no valid (from our perspective) eocdr found - baseoffset has been set to insize + close $inzip + file copy $infile $outfile_preamble + if {$outfile_zip ne ""} { + #touch equiv? + set fd [open $outfile_zip w] + close $fd + } + } + } + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Reading - archive_info / members / unzip + # + # Stock Tcl only: no zipfs, no vfs::zip, no tcllib. Works on a plain .zip and on + # a zip attached to an executable or script prefix, under either offset + # convention, because everything reads the ORIGINAL file at a derived base + # offset rather than a split-off intermediate. + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + #open + read structure + close, for the surfaces that take a filename + proc Open_archive {zipfile requirezip} { + if {![file exists $zipfile]} { + error "punk::zip: no such file '$zipfile'" + } + set chan [open $zipfile rb] + if {[catch {Archive_read $chan} arc erropts]} { + close $chan + return -options $erropts $arc + } + set info [dict get $arc info] + set status [dict get $info status] + if {$requirezip && $status ne "ok"} { + close $chan + switch -- $status { + nozip { + error "punk::zip: '$zipfile' is not a zip archive - [dict get $info reason]" + } + default { + error "punk::zip: cannot read '$zipfile' - [dict get $info reason]" + } + } + } + return [dict set arc chan $chan] + } + + #glob selection shared by members and unzip. Patterns are matched against the + #member name both as stored and with any trailing slash removed, so a pattern + #like lib/* selects the lib/ directory entry as well as its contents. + proc Select_members {members globs excludes} { + set selected [list] + foreach m $members { + set name [dict get $m name] + set bare [string trimright $name /] + set matched 0 + foreach g $globs { + if {[string match $g $name] || [string match $g $bare]} { + set matched 1 + break + } + } + if {!$matched} { + continue + } + set excluded 0 + foreach e $excludes { + if {[string match $e $name] || [string match $e $bare]} { + set excluded 1 + break + } + } + if {!$excluded} { + lappend selected $m + } + } + return $selected + } + + #Member names are archive data, not trusted paths: a name that escapes the target + #directory is refused rather than followed. Backslashes are normalised to forward + #slashes (some writers emit them) so the check cannot be side-stepped on windows. + proc Safe_member_path {name} { + set segments [list] + foreach seg [split [string map {\\ /} $name] /] { + if {$seg eq "" || $seg eq "."} { + continue + } + if {$seg eq ".."} { + error "punk::zip: refusing member '$name' - parent-directory segment would escape the target directory" + } + lappend segments $seg + } + if {![llength $segments]} { + error "punk::zip: refusing member '$name' - empty path" + } + if {[file pathtype [lindex $segments 0]] ne "relative"} { + error "punk::zip: refusing member '$name' - not a relative path" + } + return $segments + } + + #Reasons punk::zip cannot extract a member. Checked for every selected member + #BEFORE anything is written, so an unsupported archive produces an error instead + #of a partly-populated target directory. + proc Member_unsupported_reason {m} { + if {[dict get $m encrypted]} { + return "entry is encrypted - punk::zip cannot decrypt zip entries" + } + if {[dict get $m size] == 0xFFFFFFFF || [dict get $m csize] == 0xFFFFFFFF || [dict get $m offset] == 0xFFFFFFFF} { + return "entry uses zip64 size/offset fields - punk::zip reads zip32 entries only" + } + set method [dict get $m method] + if {$method ni {0 8}} { + return "entry uses compression method $method ([dict get $m methodname]) - punk::zip reads stored (0) and deflated (8) entries only" + } + return "" + } + + #Read one member's data from the archive and write it to target. + #Sizes and offsets come from the central directory, so entries written with a + #data descriptor (streamed, sizes zero in the local header) read correctly. + proc Extract_member {chan m target verify} { + set name [dict get $m name] + set fileoffset [dict get $m fileoffset] + set csize [dict get $m csize] + set size [dict get $m size] + set method [dict get $m method] + chan seek $chan $fileoffset start + set lfh [read $chan 30] + if {[string length $lfh] != 30} { + error "punk::zip: truncated local file header for member '$name' at offset $fileoffset" + } + binary scan $lfh isssssiiiss lsig lversion lflags lmethod ltime ldate lcrc lcsize lsize lnamelen lextralen + #dec2hex 67324752 = 4034B50 = PK\3\4 + if {$lsig != 67324752} { + error "punk::zip: no local file header for member '$name' at offset $fileoffset - archive offsets do not describe this file" + } + set lnamelen [expr {$lnamelen & 0xFFFF}] + set lextralen [expr {$lextralen & 0xFFFF}] + chan seek $chan [expr {$fileoffset + 30 + $lnamelen + $lextralen}] start + set out [open $target wb] + set crc 0 + set written 0 + try { + if {$size < 0x00200000} { + #small member - one chunk, mirroring Addentry's 2MB write threshold + set data "" + if {$csize > 0} { + set data [read $chan $csize] + if {[string length $data] != $csize} { + error "punk::zip: truncated data for member '$name' - wanted $csize bytes, got [string length $data]" + } + if {$method == 8} { + set data [zlib inflate $data] + } + } + set crc [zlib crc32 $data] + set written [string length $data] + puts -nonewline $out $data + } else { + #large member - stream, to avoid holding the whole thing in memory + set strm "" + if {$method == 8} { + set strm [zlib stream inflate] + } + set remaining $csize + while {$remaining > 0} { + set want [expr {$remaining > 65536 ? 65536 : $remaining}] + set chunk [read $chan $want] + if {[string length $chunk] != $want} { + error "punk::zip: truncated data for member '$name' - archive ends mid-entry" + } + incr remaining -$want + if {$strm eq ""} { + set crc [zlib crc32 $chunk $crc] + incr written [string length $chunk] + puts -nonewline $out $chunk + continue + } + if {$remaining == 0} { + $strm put -finalize $chunk + } else { + $strm put $chunk + } + #a single get returns only what the stream has already produced - + #drain until empty or the tail of the member is silently dropped + while {1} { + set plain [$strm get 65536] + if {$plain eq ""} { + break + } + set crc [zlib crc32 $plain $crc] + incr written [string length $plain] + puts -nonewline $out $plain + } + } + if {$strm ne ""} { + $strm close + } + } + close $out + set out "" + if {$written != $size} { + error "punk::zip: size mismatch for member '$name' - central directory says $size bytes, decompressed to $written" + } + if {$verify && ($crc & 0xFFFFFFFF) != [dict get $m crc]} { + error "punk::zip: crc mismatch for member '$name' - archive records [dict get $m crc], extracted data is [expr {$crc & 0xFFFFFFFF}]" + } + } on error {result erropts} { + if {$out ne ""} { + catch {close $out} + } + #never leave unverified bytes behind + catch {file delete -- $target} + return -options $erropts $result + } + return $written + } + + punk::args::define { + @id -id ::punk::zip::archive_info + @cmd -name punk::zip::archive_info\ + -summary\ + "Report the zip-archive geometry of a file"\ + -help\ + "Report where the zip archive inside a file begins and which offset + convention it uses, without extracting anything. + + The file may be a plain .zip or a zip attached to an executable or script + prefix - a punk kit, a tclsh carrying a zipfs image, a zip-based .tm + modpod. This is the derivation punk::zip::members, punk::zip::unzip and + punk::zip::extract_preamble all share. + + Does not raise for a file that simply is not an archive - read 'status'. + + Returned dict keys: + status ok | nozip | unsupported + reason why status is not ok + filesize size of the whole file + offsetstyle plain | archive | file | none + plain - a bare zip, no prefix + archive - prefixed, offsets counted from the zip + file - prefixed, offsets counted from the file + none - no archive found + dataoffset where the zip data starts, ie the prefix length + offsetbase add this to a member's stored offset for a file position + eocdoffset file position of the end-of-central-directory record + cdiroffset file position of the central directory + cdirsize size of the central directory + count number of members + diroffset central directory offset as recorded in the archive + comment archive comment + + Examples: + #which convention is this runtime using? + dict get [punk::zip::archive_info bin/punk91.exe] offsetstyle + + #how big is the executable prefix? + dict get [punk::zip::archive_info bin/punk91.exe] dataoffset + + #is there an archive attached at all? (status is ok when there is) + dict get [punk::zip::archive_info some.exe] status + " + @values -min 1 -max 1 + zipfile -type existingfile -help\ + "Path of a zip archive, or of a file with one attached" + } + proc archive_info {args} { + set argd [punk::args::parse $args withid ::punk::zip::archive_info] + set zipfile [dict get $argd values zipfile] + set arc [Open_archive $zipfile 0] + close [dict get $arc chan] + return [dict get $arc info] + } + + punk::args::define { + @id -id ::punk::zip::members + @cmd -name punk::zip::members\ + -summary\ + "List the members of a zip archive without extracting"\ + -help\ + "Read the central directory of a zip archive and return one dict per + member, in stored order, without decompressing anything. + + The archive may be a plain .zip or a zip attached to an executable or + script prefix - see punk::zip::archive_info. Requires only stock Tcl: no + zipfs, no vfs::zip, no tcllib. + + Entries punk::zip cannot EXTRACT (encrypted, zip64, an unsupported + compression method) are still listed - the refusal belongs to + punk::zip::unzip, which names the reason. + + Each member dict carries: + name member path as stored (directories keep a trailing /) + isdirectory 1 for a directory entry, else 0 + size uncompressed size in bytes + csize compressed size in bytes + method compression method id (0 store, 8 deflate) + methodname symbolic name for that method + mtime modification time as a unix timestamp (0 if unusable) + dostime the packed DOS date/time exactly as stored + crc crc32 of the uncompressed data + offset local header offset as stored in the central directory + fileoffset absolute position of that local header in the file + flags general purpose bit flag + encrypted 1 if the entry is encrypted + attributes external file attributes as stored + iattributes internal file attributes as stored + madeby version-made-by field + hostsystem host system code (upper byte of madeby - 0 fat, 3 unix) + version version needed to extract + comment per-member comment + + Examples: + #everything inside a kit + punk::zip::members bin/punk91.exe + + #just the tcl_library scripts + punk::zip::members bin/punk91.exe tcl_library/*.tcl + + #total uncompressed size + set bytes 0 + foreach m [punk::zip::members some.zip] {incr bytes [dict get \$m size]} + + #names only, files not directories + set names [list] + foreach m [punk::zip::members some.zip] { + if {![dict get \$m isdirectory]} {lappend names [dict get \$m name]} + } + " + @opts + -exclude -default {} -help\ + "List of glob expressions matched against member names. + A member matching any of them is left out of the result." + -- -type none -optional 1 -help\ + "End of options marker" + @values -min 1 -max -1 + zipfile -type existingfile -help\ + "Path of a zip archive, or of a file with one attached" + globs -default {*} -multiple 1 -help\ + "Glob patterns matched against member names with 'string match'. + A member is included if it matches any of them. + The whole stored name is matched, so * spans path separators: + *.txt selects sub/deeper/notes.txt as well as top.txt. + Directory entries match with or without their trailing slash." + } + proc members {args} { + set argd [punk::args::parse $args withid ::punk::zip::members] + set zipfile [dict get $argd values zipfile] + set globs [dict get $argd values globs] + set excludes [dict get $argd opts -exclude] + set arc [Open_archive $zipfile 1] + close [dict get $arc chan] + return [Select_members [dict get $arc members] $globs $excludes] + } + + punk::args::define { + @id -id ::punk::zip::unzip + @cmd -name punk::zip::unzip\ + -summary\ + "Extract a zip archive to a directory"\ + -help\ + "Extract all or part of a zip archive into targetdir, verifying each + member's crc32 as it is written. Directory entries are created as + directories; intermediate directories of a selected file are created + whether or not the archive stores an entry for them. + + The archive may be a plain .zip or a zip attached to an executable or + script prefix - see punk::zip::archive_info. Requires only stock Tcl: no + zipfs, no vfs::zip, no tcllib. + + Every selected member is checked for extractability BEFORE anything is + written, so an encrypted, zip64 or unknown-compression archive fails + naming the reason instead of leaving a half-populated directory. A + member whose path would escape targetdir is refused the same way. + + Returns the list of member names extracted (see -return). + + Examples: + #whole archive + punk::zip::unzip some.zip /tmp/out + + #lift a runtime's tcl_library out of the executable it is attached to + punk::zip::unzip bin/punk91.exe /tmp/rt tcl_library/* + + #everything except the docs, keeping timestamps + punk::zip::unzip -exclude {doc/*} -- some.zip /tmp/out + " + @opts + -exclude -default {} -help\ + "List of glob expressions matched against member names. + A member matching any of them is not extracted." + -overwrite -default 1 -type boolean -help\ + "Whether an existing file in targetdir may be replaced. + With -overwrite 0 an existing target is an error, raised before + anything is written." + -mtime -default 1 -type boolean -help\ + "Whether to restore each member's stored modification time. + Directory times are applied after their contents are written." + -verify -default 1 -type boolean -help\ + "Whether to check each extracted member against the crc32 stored in + the archive. A mismatch is an error and the partial file is removed." + -return -default list -choices {list pretty none} -help\ + "list - return the extracted member names (default) + pretty - format that list for terminal display + none - return the empty string" + -- -type none -optional 1 -help\ + "End of options marker" + @values -min 2 -max -1 + zipfile -type existingfile -help\ + "Path of a zip archive, or of a file with one attached" + targetdir -type directory -help\ + "Directory to extract into. Created if it does not exist." + globs -default {*} -multiple 1 -help\ + "Glob patterns matched against member names with 'string match'. + A member is extracted if it matches any of them. + The whole stored name is matched, so * spans path separators: + *.txt selects sub/deeper/notes.txt as well as top.txt. + Directory entries match with or without their trailing slash." + } + proc unzip {args} { + set argd [punk::args::parse $args withid ::punk::zip::unzip] + set zipfile [dict get $argd values zipfile] + set targetdir [dict get $argd values targetdir] + set globs [dict get $argd values globs] + set excludes [dict get $argd opts -exclude] + set overwrite [dict get $argd opts -overwrite] + set restoremtime [dict get $argd opts -mtime] + set verify [dict get $argd opts -verify] + + set arc [Open_archive $zipfile 1] + set chan [dict get $arc chan] + set extracted [list] + set dirtimes [list] + try { + set selected [Select_members [dict get $arc members] $globs $excludes] + #preflight - nothing is written until every selected member is known good + set targets [list] + foreach m $selected { + set reason [Member_unsupported_reason $m] + if {$reason ne ""} { + error "punk::zip::unzip: cannot extract '[dict get $m name]' from $zipfile - $reason" + } + set target [file join $targetdir {*}[Safe_member_path [dict get $m name]]] + if {!$overwrite && !([dict get $m isdirectory]) && [file exists $target]} { + error "punk::zip::unzip: '$target' already exists and -overwrite is 0" + } + lappend targets $target + } + file mkdir $targetdir + foreach m $selected target $targets { + set name [dict get $m name] + if {[dict get $m isdirectory]} { + file mkdir $target + if {$restoremtime && [dict get $m mtime]} { + lappend dirtimes $target [dict get $m mtime] + } + } else { + file mkdir [file dirname $target] + Extract_member $chan $m $target $verify + if {$restoremtime && [dict get $m mtime]} { + catch {file mtime $target [dict get $m mtime]} + } + } + lappend extracted $name + } + } finally { + close $chan + } + #directory times last - writing their contents would have reset them + foreach {dir mtime} $dirtimes { + catch {file mtime $dir $mtime} + } + + switch -exact -- [dict get $argd opts -return] { + pretty { + if {[info commands showlist] ne ""} { + return [plist -channel none extracted] + } + return $extracted + } + none { + return "" + } + default { + return $extracted + } + } + } + + + + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry\ + -summary\ + "Add zip-entry for file at 'path'"\ + -help\ + "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + + # Addentry - was Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Addentry {args} { + #*** !doctools + #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] + #[para] Add a single file to a zip archive + #[para] The zipchan channel should already be open and binary. + #[para] You can provide a -comment for the file. + #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + + set argd [punk::args::parse $args withid ::punk::zip::Addentry] + set zipchan [dict get $argd values zipchan] + set base [dict get $argd values base] + set path [dict get $argd values path] + set zipdataoffset [dict get $argd values zipdataoffset] + + set comment [dict get $argd opts -comment] + + set fullpath [file join $base $path] + set mtime [Timet_to_dos [file mtime $fullpath]] + set utfpath [encoding convertto utf-8 $path] + set utfcomment [encoding convertto utf-8 $comment] + set flags [expr {(1<<11)}] ;# utf-8 comment and path + set method 0 ;# store 0, deflate 8 + set attr 0 ;# text or binary (default binary) + set version 20 ;# minumum version req'd to extract + set extra "" + set crc 0 + set size 0 + set csize 0 + set data "" + set seekable [expr {[tell $zipchan] != -1}] + if {[file isdirectory $fullpath]} { + set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) + #set attrex 0x40000010 + } elseif {[file executable $fullpath]} { + set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) + } else { + set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) + if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { + set attr 1 ;# text + } + } + + if {[file isfile $fullpath]} { + set size [file size $fullpath] + if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} + } + + + set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip + set local [binary format a4sssiiiiss PK\03\04 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]] + append local $utfpath $extra + puts -nonewline $zipchan $local + + if {[file isfile $fullpath]} { + # If the file is under 2MB then zip in one chunk, otherwize we use + # streaming to avoid requiring excess memory. This helps to prevent + # storing re-compressed data that may be larger than the source when + # handling PNG or JPEG or nested ZIP files. + if {$size < 0x00200000} { + set fin [open $fullpath rb] + set data [read $fin] + set crc [zlib crc32 $data] + set cdata [zlib deflate $data] + if {[string length $cdata] < $size} { + set method 8 + set data $cdata + } + close $fin + set csize [string length $data] + puts -nonewline $zipchan $data + } else { + set method 8 + set fin [open $fullpath rb] + set zlib [zlib stream deflate] + while {![eof $fin]} { + set data [read $fin 4096] + set crc [zlib crc32 $data $crc] + $zlib put $data + if {[string length [set zdata [$zlib get]]]} { + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + } + } + close $fin + $zlib finalize + set zdata [$zlib get] + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + $zlib close + } + + if {$seekable} { + # update the header if the output is seekable + set local [binary format a4sssiiii PK\03\04 \ + $version $flags $method $mtime $crc $csize $size] + set current [tell $zipchan] + seek $zipchan $channeloffset + puts -nonewline $zipchan $local + seek $zipchan $current + } else { + # Write a data descriptor record + set ddesc [binary format a4iii PK\7\8 $crc $csize $size] + puts -nonewline $zipchan $ddesc + } + } + + #PK\x01\x02 Cdentral directory file header + #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 + set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) + + set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]\ + [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. + append hdr $utfpath $extra $utfcomment + return $hdr + } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -summary\ + "Create a zip archive in 'filename'."\ + -help\ + "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help\ + "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix." + -return -default "pretty" -choices {pretty list none}\ + -help\ + "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help\ + "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" + -runtime -default ""\ + -help\ + "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review)" + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "Scan for contents within this folder or current directory if not provided." + -base -default ""\ + -help\ + "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + -- -type none -help\ + "End of options marker" + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help\ + "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #todo - doctools - [arg ?globs...?] syntax? + + #*** !doctools + #[call [fun mkzip]\ + # [opt "[option -offsettype] [arg offsettype]"]\ + # [opt "[option -return] [arg returntype]"]\ + # [opt "[option -zipkit] [arg 0|1]"]\ + # [opt "[option -runtime] [arg preamble_filename]"]\ + # [opt "[option -comment] [arg zipfilecomment]"]\ + # [opt "[option -directory] [arg dir_to_zip]"]\ + # [opt "[option -base] [arg archive_root]"]\ + # [opt "[option -exclude] [arg globlist]"]\ + # [arg zipfilename]\ + # [arg ?glob...?]] + #[para] Create a zip archive in 'zipfilename' + #[para] If a file already exists, an error will be raised. + #[para] Call 'punk::zip::mkzip' with no arguments for usage display. + + set argd [punk::args::parse $args withid ::punk::zip::mkzip] + set filename [dict get $argd values filename] + if {$filename eq ""} { + error "mkzip filename cannot be empty string" + } + if {[regexp {[?*]} $filename]} { + #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name + error "mkzip filename should not contain glob characters ? *" + } + if {[file exists $filename]} { + error "mkzip filename:$filename already exists" + } + dict for {k v} [dict get $argd opts] { + switch -- $k { + -comment { + dict set argd opts $k [encoding convertto utf-8 $v] + } + -directory - -base { + dict set argd opts $k [file normalize $v] + } + } + } + + array set opts [dict get $argd opts] + + + if {$opts(-directory) ne ""} { + if {$opts(-base) ne ""} { + #-base and -directory have been normalized already + if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" + } + set base $opts(-base) + set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] + } else { + set base $opts(-directory) + set relpath "" + } + #will pick up intermediary folders as paths (ending with trailing slash) + set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] + + set norm_filename [file normalize $filename] + set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) + if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { + #check that we aren't adding the zipfile to itself + #REVIEW - now that we open zipfile after scanning - this isn't really a concern! + #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) + #In the case of -force - we may want to delay replacement of original until scan is done? + + #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each + #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths + set self_globs_match 0 + foreach g [dict get $argd values globs] { + if {[string match $g [file tail $filename]]} { + set self_globs_match 1 + break + } + } + if {$self_globs_match} { + #still dangerous + set self_excluded 0 + foreach e $opts(-exclude) { + if {[string match $e [file tail $filename]]} { + set self_excluded 1 + break + } + } + if {!$self_excluded} { + #still dangerous - likely to be in resultset - check each path + #puts stderr "zip file $filename is below directory $opts(-directory)" + set self_is_matched 0 + set i 0 + foreach p $paths { + set norm_p [file normalize [file join $opts(-directory) $p]] + if {[Path_a_at_b $norm_filename $norm_p]} { + set self_is_matched 1 + break + } + incr i + } + if {$self_is_matched} { + puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" + set paths [lremove $paths $i] + } + } + } + } + } else { + #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! + #ie - only the exact *files* matching the glob are stored. + set paths [list] + set dir [pwd] + if {$opts(-base) ne ""} { + if {![Path_a_atorbelow_b $dir $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above current directory" + } + set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] + } else { + set relpath "" + } + set base $opts(-base) + + set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] + foreach m $matches { + if {$m eq $filename} { + #puts stderr "--> excluding $filename" + continue + } + set isok 1 + foreach e [concat $opts(-exclude) $filename] { + if {[string match $e $m]} { + set isok 0 + break + } + } + if {$isok} { + lappend paths [file join $relpath $m] + } + } + } + + if {![llength $paths]} { + return "" + } + + set zf [open $filename wb] + if {$opts(-runtime) ne ""} { + #todo - strip any existing vfs - option to merge contents.. only if zip attached? + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod + set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" + append zkd "package require vfs::zip\n" + append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" + append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" + append zkd " source \[file join \[info script\] main.tcl\]\n" + append zkd "}\n" + append zkd \x1A + puts -nonewline $zf $zkd + } + + #todo - subtract this from the endrec offset + if {$opts(-offsettype) eq "archive"} { + set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 + } else { + set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ + } + + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath + incr count + } + set cdoffset [tell $zf] + set endrec [binary format a4ssssiis PK\05\06 0 0 \ + $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ + [string length $opts(-comment)]] + append endrec $opts(-comment) + puts -nonewline $zf $cd + puts -nonewline $zf $endrec + close $zf + + set result "" + switch -exact -- $opts(-return) { + list { + set result $members + } + pretty { + if {[info commands showlist] ne ""} { + set result [plist -channel none members] + } else { + set result $members + } + } + none { + set result "" + } + } + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::zip::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::zip [tcl::namespace::eval punk::zip { + variable pkg punk::zip + variable version + set version 0.2.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/make.tcl b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/make.tcl index 7d08906c..68653cf4 100644 --- a/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/make.tcl +++ b/src/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1/src/make.tcl @@ -5937,20 +5937,22 @@ foreach vfstail $vfs_tails { file copy -force $building_runtime $raw_runtime } } else { - #The driving tcl we are calling with doesn't have zipfs - can't mount + #The driving tcl we are calling with doesn't have zipfs - can't mount. + #punk::zip reads the attached archive with stock Tcl only (G-124), + #so this path needs no zipfs, no vfs::zip and no tcllib. package require punk::zip - puts stderr "WARNING: tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - falling back to punk::zip::extract_preamble" - set extractedzipfile $buildfolder/extracted_$runtime_fullname.zip + puts stdout "tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - reading the runtime's attached archive with punk::zip" set extractedzipfolder $buildfolder/extracted_$runtime_fullname file delete $raw_runtime - file delete $extractedzipfile file delete -force $extractedzipfolder if {![catch { - punk::zip::extract_preamble $building_runtime $raw_runtime $extractedzipfile - package require zipfile::decode - zipfile::decode::open $extractedzipfile - set archiveinfo [zipfile::decode::archive] - zipfile::decode::unzip $archiveinfo $extractedzipfolder + #Split off the executable prefix - the kit assembly needs it as a + #file. The MEMBERS are then read from the ORIGINAL runtime at its + #derived base offset: a runtime whose offsets are file-relative + #splits into a .zip no plain zip reader accepts, and reading the + #whole file sidesteps that intermediate entirely. + punk::zip::extract_preamble $building_runtime $raw_runtime + punk::zip::unzip -return none -- $building_runtime $extractedzipfolder } extracterr]} { set extraction_done 1 set extract_kit_type $extract_kit_try @@ -5958,10 +5960,7 @@ foreach vfstail $vfs_tails { merge_over $extractedzipfolder $targetvfs } else { #Do not swallow the reason: without the runtime's own - #zip contents the built kit has no tcl_library. Note - #zipfile::decode is a system tcllib package, not a - #vendored one - a tclsh without tcllib (e.g the msys2 - #/usr/bin/tclsh8.6) cannot take this path at all. + #zip contents the built kit has no tcl_library. puts stderr "zipfs-less extraction of $runtime_fullname FAILED: $extracterr" } } diff --git a/src/project_layouts/vendor/punk/basic/src/make.tcl b/src/project_layouts/vendor/punk/basic/src/make.tcl index 7d08906c..68653cf4 100644 --- a/src/project_layouts/vendor/punk/basic/src/make.tcl +++ b/src/project_layouts/vendor/punk/basic/src/make.tcl @@ -5937,20 +5937,22 @@ foreach vfstail $vfs_tails { file copy -force $building_runtime $raw_runtime } } else { - #The driving tcl we are calling with doesn't have zipfs - can't mount + #The driving tcl we are calling with doesn't have zipfs - can't mount. + #punk::zip reads the attached archive with stock Tcl only (G-124), + #so this path needs no zipfs, no vfs::zip and no tcllib. package require punk::zip - puts stderr "WARNING: tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - falling back to punk::zip::extract_preamble" - set extractedzipfile $buildfolder/extracted_$runtime_fullname.zip + puts stdout "tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - reading the runtime's attached archive with punk::zip" set extractedzipfolder $buildfolder/extracted_$runtime_fullname file delete $raw_runtime - file delete $extractedzipfile file delete -force $extractedzipfolder if {![catch { - punk::zip::extract_preamble $building_runtime $raw_runtime $extractedzipfile - package require zipfile::decode - zipfile::decode::open $extractedzipfile - set archiveinfo [zipfile::decode::archive] - zipfile::decode::unzip $archiveinfo $extractedzipfolder + #Split off the executable prefix - the kit assembly needs it as a + #file. The MEMBERS are then read from the ORIGINAL runtime at its + #derived base offset: a runtime whose offsets are file-relative + #splits into a .zip no plain zip reader accepts, and reading the + #whole file sidesteps that intermediate entirely. + punk::zip::extract_preamble $building_runtime $raw_runtime + punk::zip::unzip -return none -- $building_runtime $extractedzipfolder } extracterr]} { set extraction_done 1 set extract_kit_type $extract_kit_try @@ -5958,10 +5960,7 @@ foreach vfstail $vfs_tails { merge_over $extractedzipfolder $targetvfs } else { #Do not swallow the reason: without the runtime's own - #zip contents the built kit has no tcl_library. Note - #zipfile::decode is a system tcllib package, not a - #vendored one - a tclsh without tcllib (e.g the msys2 - #/usr/bin/tclsh8.6) cannot take this path at all. + #zip contents the built kit has no tcl_library. puts stderr "zipfs-less extraction of $runtime_fullname FAILED: $extracterr" } } diff --git a/src/project_layouts/vendor/punk/project-0.1/src/make.tcl b/src/project_layouts/vendor/punk/project-0.1/src/make.tcl index 7d08906c..68653cf4 100644 --- a/src/project_layouts/vendor/punk/project-0.1/src/make.tcl +++ b/src/project_layouts/vendor/punk/project-0.1/src/make.tcl @@ -5937,20 +5937,22 @@ foreach vfstail $vfs_tails { file copy -force $building_runtime $raw_runtime } } else { - #The driving tcl we are calling with doesn't have zipfs - can't mount + #The driving tcl we are calling with doesn't have zipfs - can't mount. + #punk::zip reads the attached archive with stock Tcl only (G-124), + #so this path needs no zipfs, no vfs::zip and no tcllib. package require punk::zip - puts stderr "WARNING: tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - falling back to punk::zip::extract_preamble" - set extractedzipfile $buildfolder/extracted_$runtime_fullname.zip + puts stdout "tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - reading the runtime's attached archive with punk::zip" set extractedzipfolder $buildfolder/extracted_$runtime_fullname file delete $raw_runtime - file delete $extractedzipfile file delete -force $extractedzipfolder if {![catch { - punk::zip::extract_preamble $building_runtime $raw_runtime $extractedzipfile - package require zipfile::decode - zipfile::decode::open $extractedzipfile - set archiveinfo [zipfile::decode::archive] - zipfile::decode::unzip $archiveinfo $extractedzipfolder + #Split off the executable prefix - the kit assembly needs it as a + #file. The MEMBERS are then read from the ORIGINAL runtime at its + #derived base offset: a runtime whose offsets are file-relative + #splits into a .zip no plain zip reader accepts, and reading the + #whole file sidesteps that intermediate entirely. + punk::zip::extract_preamble $building_runtime $raw_runtime + punk::zip::unzip -return none -- $building_runtime $extractedzipfolder } extracterr]} { set extraction_done 1 set extract_kit_type $extract_kit_try @@ -5958,10 +5960,7 @@ foreach vfstail $vfs_tails { merge_over $extractedzipfolder $targetvfs } else { #Do not swallow the reason: without the runtime's own - #zip contents the built kit has no tcl_library. Note - #zipfile::decode is a system tcllib package, not a - #vendored one - a tclsh without tcllib (e.g the msys2 - #/usr/bin/tclsh8.6) cannot take this path at all. + #zip contents the built kit has no tcl_library. puts stderr "zipfs-less extraction of $runtime_fullname FAILED: $extracterr" } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.2.7.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.2.8.tm similarity index 99% rename from src/vfs/_vfscommon.vfs/modules/punk-0.2.7.tm rename to src/vfs/_vfscommon.vfs/modules/punk-0.2.8.tm index aac58c5f..ce6dd983 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.2.7.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.2.8.tm @@ -9002,7 +9002,14 @@ namespace eval punk { runtime-artifact metadata target field. The raw Tcl platform-package identifiers are shown for comparison (punk::platform::normalize folds their version-dependent - aliases - amd64/aarch64/macos - into the canonical names)." + aliases - amd64/aarch64/macos - into the canonical names, and + folds the msys2 family - mingw64/mingw32/ucrt64/clang* - onto + the one 'msys' tag, since msys2's uname renders that token from + MSYSTEM rather than from the binary). + These are HOST names. What a name implies for build OUTPUT + (.exe suffixing, process tooling, which bin/runtime tier holds + a runtime) is a TARGET question src/make.tcl derives from the + name - a cygwin-family host targets win32-x86_64 by default." @values -min 0 -max 0 } proc platforms {context args} { @@ -9505,7 +9512,7 @@ punkcheck::cli set_alias punkcheck package provide punk [namespace eval punk { #FUNCTL variable version - set version 0.2.7 + set version 0.2.8 }] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.2.0.tm index 65c4a315..5b144e73 100644 Binary files a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.2.0.tm and b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.2.0.tm differ diff --git a/src/bootsupport/modules/punk/platform-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/platform-0.2.0.tm similarity index 73% rename from src/bootsupport/modules/punk/platform-0.1.0.tm rename to src/vfs/_vfscommon.vfs/modules/punk/platform-0.2.0.tm index 41b41736..b74ad186 100644 --- a/src/bootsupport/modules/punk/platform-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/platform-0.2.0.tm @@ -7,7 +7,7 @@ # (C) 2026 # # @@ Meta Begin -# Application punk::platform 0.1.0 +# Application punk::platform 0.2.0 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -40,6 +40,29 @@ namespace eval punk::platform { # the darwin 'arm64' machine name to 'arm'; Apple silicon is 64-bit only, # so the arm token on macosx always means arm64. Elsewhere 'arm' is a # genuine 32-bit token and is preserved.) + # - os mingw64/mingw32/ucrt64/clang64/clangarm64 -> msys (G-122; see the + # MSYSTEM-variance note below) + # + #MSYSTEM VARIANCE (cygwin-family hosts on windows). An msys2-runtime tclsh + #reports tcl_platform(platform) 'unix' with an os string msys2's uname + #renders from the MSYSTEM environment variable, so ONE binary canonizes + #differently per launching shell - verified 2026-07-26 with msys2's + #/usr/bin/tclsh8.6: MSYSTEM=MSYS -> MSYS_NT-10.0-26200 (msys-x86_64), and + #MSYSTEM=MINGW64, =UCRT64 or unset (msys2 defaults it) -> MINGW64_NT-10.0-26200 + #(mingw64-x86_64). The MSYSTEM token names the shell that launched the + #process, not the binary's ABI: a genuinely MINGW-built tclsh is a native + #windows binary reporting os 'Windows NT' and canonizes as win32-*. So every + #msys2-runtime token folds to the one stable tag 'msys'. Real cygwin keeps + #its own tag 'cygwin' - a separate runtime dll and mount world, so a store + #tier serving one does not serve the other. Windows build numbers never + #reach a tag (platform::generic cuts the os at its first _ or -; normalize_os + #re-folds a raw uname-style string anyway). + #These are HOST canon names. What a tag implies for BUILD OUTPUT - .exe + #suffixing, which process tooling manages a running artifact, which + #bin/runtime store tier holds a runtime - is a TARGET question that + #src/make.tcl derives from the tag (G-122 host/target split): cygwin-family + #hosts default their build target to win32-x86_64, since the kits they bake + #are native windows binaries. #The special name 'macosx' (no cpu suffix) is the RUNTIME-tier convention for #universal (multi-arch) macOS binaries - punkbin and bin/runtime keep one #universal folder; the per-arch macosx-x86_64/macosx-arm64 names serve the @@ -83,7 +106,8 @@ namespace eval punk::platform { macosx-arm64 {status supported tiers {lib} buildsuite none notes "Apple silicon; would follow a macosx runtime arc"} freebsd-x86_64 {status supported tiers {runtime lib} buildsuite candidate notes ""} freebsd-arm64 {status supported tiers {runtime lib} buildsuite candidate notes "no artifacts yet"} - msys-x86_64 {status dormant tiers {lib} buildsuite none notes "msys/cygwin-built tclsh runtimes; utility under review"} + msys-x86_64 {status dormant tiers {runtime lib} buildsuite none notes "msys2-runtime tclsh on windows (posix personality, .exe files); host canon for every MSYSTEM shell - see normalize"} + cygwin-x86_64 {status recognized tiers {runtime lib} buildsuite none notes "cygwin-runtime tclsh on windows; separate dll/mount world from msys2, so a distinct tier"} openbsd-x86_64 {status recognized tiers {runtime} buildsuite none notes "hosted third-party runtimes possible"} netbsd-x86_64 {status recognized tiers {runtime} buildsuite none notes "hosted third-party runtimes possible"} dragonflybsd-x86_64 {status recognized tiers {runtime} buildsuite none notes "hosted third-party runtimes possible"} @@ -124,6 +148,45 @@ namespace eval punk::platform { return $platforms } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::platform::normalize_os + @cmd -name punk::platform::normalize_os\ + -summary\ + "Fold an os token to its canonical punkshell spelling."\ + -help\ + "Fold a single os token (the half of an - platform + identifier) to its canonical punkshell spelling: + macos -> macosx + mingw32|mingw64|ucrt64|clang* -> msys + MSYS_NT- -> msys + CYGWIN_NT- -> cygwin + The msys2 family folds to one tag because msys2's uname renders + the os string from the MSYSTEM environment variable: the same + binary reports MSYS_NT or MINGW64_NT depending on which shell + launched it, while a genuinely MINGW-built (native windows) + tclsh reports 'Windows NT' and canonizes as win32. Raw + uname-style strings carrying a windows build number fold too - + a build number never belongs in a platform tag. + Unrecognized tokens pass through unchanged." + @values -min 1 -max 1 + os -type string -help\ + "os token, e.g the half of platform::generic's result." + }] + } + proc normalize_os {os} { + switch -glob -- [string tolower $os] { + macos {return macosx} + msys - msys_nt-* {return msys} + mingw32 - mingw64 - mingw_nt-* - mingw32_nt-* - mingw64_nt-* {return msys} + ucrt64 - ucrt64_nt-* {return msys} + clang32 - clang64 - clangarm64 - clang32_nt-* - clang64_nt-* - clangarm64_nt-* {return msys} + cygwin_nt-* {return cygwin} + } + return $os + } + namespace eval argdoc { variable PUNKARGS lappend PUNKARGS [list { @@ -137,6 +200,9 @@ namespace eval punk::platform { platform-dir name: cpu amd64 -> x86_64, aarch64 -> arm64 os macos -> macosx (Tcl platform 1.1.x renamed modern macOS) + os mingw64/mingw32/ucrt64/clang* -> msys (one stable tag for + the msys2 runtime family - the reported name follows MSYSTEM, + not the binary; see punk::platform::normalize_os) macosx cpu arm -> arm64 (platform::generic's arm* glob folds the darwin arm64 machine name to arm; Apple silicon is 64-bit only - non-macosx 'arm' stays 32-bit arm) @@ -150,18 +216,13 @@ namespace eval punk::platform { proc normalize {platform} { set parts [split $platform -] if {[llength $parts] < 2} { - #single-token names (e.g the universal 'macosx') - fold macos only - if {$platform eq "macos"} { - return macosx - } - return $platform + #single-token names (e.g the universal 'macosx') - fold the os token only + return [normalize_os $platform] } #os may itself contain a dash in principle - treat last token as cpu set cpu [lindex $parts end] set os [join [lrange $parts 0 end-1] -] - switch -- $os { - macos {set os macosx} - } + set os [normalize_os $os] switch -- $cpu { amd64 {set cpu x86_64} aarch64 {set cpu arm64} @@ -232,6 +293,6 @@ namespace eval ::punk::args::register { ## Ready package provide punk::platform [namespace eval punk::platform { variable version - set version 0.1.0 + set version 0.2.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm deleted file mode 100644 index 02415ccd..00000000 --- a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm +++ /dev/null @@ -1,914 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt -# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm -# -# 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) 2024 JMN -# (C) 2009 Path Thoyts -# -# @@ Meta Begin -# Application punk::zip 0.1.1 -# Meta platform tcl -# Meta license MIT -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin punkshell_module_punk::zip 0 0.1.1] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require punk::zip] -#[keywords module zip fileformat] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of punk::zip -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by punk::zip -#[list_begin itemized] - -package require Tcl 8.6- -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package {punk::args}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::zip { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - #variable xyz - - #*** !doctools - #[subsection {Namespace punk::zip}] - #[para] Core API functions for punk::zip - #[list_begin definitions] - - proc Path_a_atorbelow_b {path_a path_b} { - return [expr {[StripPath $path_b $path_a] ne $path_a}] - } - proc Path_a_at_b {path_a path_b} { - return [expr {[StripPath $path_a $path_b] eq "." }] - } - - proc Path_strip_alreadynormalized_prefixdepth {path prefix} { - if {$prefix eq ""} { - return $path - } - set pathparts [file split $path] - set prefixparts [file split $prefix] - if {[llength $prefixparts] >= [llength $pathparts]} { - return "" - } - return [file join \ - {*}[lrange \ - $pathparts \ - [llength $prefixparts] \ - end]] - } - - #StripPath - borrowed from tcllib fileutil - # ::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 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 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 - } - } - - proc Timet_to_dos {time_t} { - #*** !doctools - #[call [fun Timet_to_dos] [arg time_t]] - #[para] convert a unix timestamp into a DOS timestamp for ZIP times. - #[example { - # DOS timestamps are 32 bits split into bit regions as follows: - # 24 16 8 0 - # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ - # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| - # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ - #}] - set s [clock format $time_t -format {%Y %m %e %k %M %S}] - scan $s {%d %d %d %d %d %d} year month day hour min sec - expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) - | ($hour << 11) | ($min << 5) | ($sec >> 1)} - } - punk::args::define { - @id -id ::punk::zip::walk - @cmd -name punk::zip::walk -help\ - "Walk the directory structure starting at base/<-subpath> - and return a list of the files and folders encountered. - Resulting paths are relative to base unless -resultrelative - is supplied. - Folder names will end with a trailing slash. - " - -resultrelative -optional 1 -help\ - "Resulting paths are relative to this value. - Defaults to the value of base. If empty string - is given to -resultrelative the paths returned - are effectively absolute paths." - -emptydirs -default 0 -type boolean -help\ - "Whether to include directory trees in the result which had no - matches for the given fileglobs. - Intermediate dirs are always returned if there is a match with - fileglobs further down even if -emptdirs is 0. - " - -excludes -default "" -help "list of glob expressions to match against files and exclude" - -subpath -default "" -help\ - "May contain glob chars for folder elements" - #If we don't include --, the call walk -- .. will return nothing as 'base' will receive the -- - -- -type none -optional 1 - @values -min 1 -max -1 - base - fileglobs -default {*} -multiple 1 - } - proc walk {args} { - #*** !doctools - #[call [fun walk] [arg ?options?] [arg base]] - #[para] Walk a directory tree rooted at base - #[para] the -excludes list can be a set of glob expressions to match against files and avoid - #[para] e.g - #[example { - # punk::zip::walk -exclude {CVS/* *~.#*} library - #}] - - #todo: -relative 0|1 flag? - set argd [punk::args::parse $args withid ::punk::zip::walk] - set base [dict get $argd values base] - set fileglobs [dict get $argd values fileglobs] - set subpath [dict get $argd opts -subpath] - set excludes [dict get $argd opts -excludes] - set emptydirs [dict get $argd opts -emptydirs] - - set received [dict get $argd received] - - set imatch [list] - foreach fg $fileglobs { - lappend imatch [file join $subpath $fg] - } - - if {![dict exists $received -resultrelative]} { - set relto $base - set prefix "" - } else { - set relto [file normalize [dict get $argd opts -resultrelative]] - if {$relto ne ""} { - if {![Path_a_atorbelow_b $base $relto]} { - error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" - } - set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] - } else { - set prefix $base - } - } - - set result {} - #set imatch [file join $subpath $match] - set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] - foreach file $files { - set excluded 0 - foreach glob $excludes { - if {[string match $glob $file]} { - set excluded 1 - break - } - } - if {!$excluded} {lappend result [file join $prefix $file]} - } - foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { - set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] - set subdir_entries [list] - set thisdir_match [list] - set has_file 0 - foreach sd $submatches { - set fullpath [file join $prefix $sd] ;#file join destroys trailing slash - if {[string index $sd end] eq "/"} { - lappend subdir_entries $fullpath/ - } else { - set has_file 1 - lappend subdir_entries $fullpath - } - } - if {$emptydirs} { - set thisdir_match [list "[file join $prefix $dir]/"] - } else { - if {$has_file} { - set thisdir_match [list "[file join $prefix $dir]/"] - } else { - set subdir_entries [list] - } - } - #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" - #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash - #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. - set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] - } - return $result - } - - #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) - #Otherwise extract an internal preamble. - #if neither -? - #review - reconsider auto-determination of internal vs external preamble - punk::args::define { - @id -id ::punk::zip::extract_preamble - @cmd -name punk::zip::extract_preamble -help\ - "Split a zipfs based executable or library into its constituent - binary and zip parts. - - Note that the binary preamble might be either 'within' the zip offsets, - or simply catenated prior to an unadjusted zip. - Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file - ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip - ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper - split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. - - Either way, extract_preamble can usually separate them, but in the unusual case that there is both an - external preamble and a preamble within the zip, only the external preamble will be split, with the - internal one remaining in the zip. - - The inverse of this process would be to extract the .zip file created by this split to a folder, - e.g extracted_zip_folder (adjusting contents as required) and then to run: - zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" - " - @values -min 2 -max 3 - infile -type file -optional 0 -help\ - "Name of existing tcl executable or shared lib with attached zipfs filesystem" - outfile_preamble -optional 0 -type file -help\ - "Name of output file for binary preamble to be extracted to. - If this file already exists, an error will be raised" - outfile_zip -default "" -type file -help\ - "Name of output file for zip data to be extracted to. - If this file already exists, an error will be raised" - } - proc extract_preamble {args} { - set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] - lassign [dict values $argd] leaders opts values received - - set infile [dict get $values infile] - set outfile_preamble [dict get $values outfile_preamble] - set outfile_zip [dict get $values outfile_zip] - - set inzip [open $infile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - if {[file exists $outfile_preamble]} { - error "outfile_preamble $outfile_preamble already exists - please remove first" - } - if {$outfile_zip ne ""} { - if {[file exists $outfile_zip] && [file size $outfile_zip]} { - error "outfile_zip $outfile_zip already exists - please remove first" - } - } - chan seek $inzip 0 end - set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent - chan seek $inzip 0 start - #only scan last 64k - cover max signature size?? review - if {$insize < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$insize - 65559}] - } - chan seek $inzip $tailsearch_start start - set scan [read $inzip] - #EOCD - End Of Central Directory record - set start_of_end [string last "\x50\x4b\x05\x06" $scan] - puts stdout "==>start_of_end: $start_of_end" - - if {$start_of_end == -1} { - #no zip eocdr - consider entire file to be the zip preamble - set baseoffset $insize - } else { - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - chan seek $inzip $filerelative_eocd_posn - set cdir_record_plus [read $inzip] ;#can have trailing data - binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - #rule out a false positive from within a nonzip (e.g plain exe) - #There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. - #It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway - #we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros - #todo - just search for Pk\5\6\0\0\0\0 in the first place? //review - if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { - #review - should keep searching? - #for now we assume not a zip - set baseoffset $insize - } else { - #use the central dir size to jump back tko start of central dir - #determine if diroffset is file or archive relative - - set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] - puts stdout "---> [read $inzip 4]" - if {$filerelative_cdir_start > $eocd(diroffset)} { - #'external preamble' easy case - # - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier - #though we are assuming zip offsets are not corrupted - set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] - } else { - #'internal preamble' hard case - # - either no preamble - or offsets have been adjusted to be file relative. - #we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers - #we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? - #or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete - - #step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) - #we can't assume they're ordered in any particular way - so we in theory have to look at them all. - set baseoffset "unknown" - chan seek $inzip $filerelative_cdir_start start - #binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - # eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - #load the whole central dir into cdir - - #todo! loop through all cdr file headers - find highest offset? - #tclZipfs.c just looks at first file header in Central Directory - #looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW - - set cdirdata [read $inzip $eocd(dirsize)] - binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ - cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ - cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) - - #since we're in this branch - we assume cdir(relativeoffset) is from the start of the file - chan seek $inzip $cdir(relativeoffset) - #let's at least check that we landed on a local file header.. - set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field - binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ - lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) - #dec2hex 67324752 = 4034B50 = PK\3\4 - puts stdout "1st local file header sig: $lfh(signature)" - if {$lfh(signature) == 67324752} { - #looks like a local file header - #use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) - set baseoffset $cdir(relativeoffset) - } - } - puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" - } - } - puts stdout "baseoffset: $baseoffset" - #expect CDFH PK\1\2 - #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) - #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script - - if {![string is integer -strict $baseoffset]} { - error "unable to determine zip baseoffset of file $infile" - } - - if {$baseoffset < $insize} { - set pout [open $outfile_preamble w] - fconfigure $pout -encoding iso8859-1 -translation binary - chan seek $inzip 0 start - chan copy $inzip $pout -size $baseoffset - close $pout - if {$outfile_zip ne ""} { - #todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile - set zout [open $outfile_zip w] - fconfigure $zout -encoding iso8859-1 -translation binary - chan copy $inzip $zout - close $zout - } - close $inzip - } else { - #no valid (from our perspective) eocdr found - baseoffset has been set to insize - close $inzip - file copy $infile $outfile_preamble - if {$outfile_zip ne ""} { - #touch equiv? - set fd [open $outfile_zip w] - close $fd - } - } - } - - - - punk::args::define { - @id -id ::punk::zip::Addentry - @cmd -name punk::zip::Addentry\ - -summary\ - "Add zip-entry for file at 'path'"\ - -help\ - "Add a single file at 'path' to open channel 'zipchan' - return a central directory file record" - @opts - -comment -default "" -help "An optional comment specific to the added file" - @values -min 3 -max 4 - zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" - base -help "base path for entries" - path -type file -help "path of file to add" - zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe - Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" - } - - # Addentry - was Mkzipfile -- - # - # FIX ME: should handle the current offset for non-seekable channels - # - proc Addentry {args} { - #*** !doctools - #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] - #[para] Add a single file to a zip archive - #[para] The zipchan channel should already be open and binary. - #[para] You can provide a -comment for the file. - #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. - - set argd [punk::args::parse $args withid ::punk::zip::Addentry] - set zipchan [dict get $argd values zipchan] - set base [dict get $argd values base] - set path [dict get $argd values path] - set zipdataoffset [dict get $argd values zipdataoffset] - - set comment [dict get $argd opts -comment] - - set fullpath [file join $base $path] - set mtime [Timet_to_dos [file mtime $fullpath]] - set utfpath [encoding convertto utf-8 $path] - set utfcomment [encoding convertto utf-8 $comment] - set flags [expr {(1<<11)}] ;# utf-8 comment and path - set method 0 ;# store 0, deflate 8 - set attr 0 ;# text or binary (default binary) - set version 20 ;# minumum version req'd to extract - set extra "" - set crc 0 - set size 0 - set csize 0 - set data "" - set seekable [expr {[tell $zipchan] != -1}] - if {[file isdirectory $fullpath]} { - set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) - #set attrex 0x40000010 - } elseif {[file executable $fullpath]} { - set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) - } else { - set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) - if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { - set attr 1 ;# text - } - } - - if {[file isfile $fullpath]} { - set size [file size $fullpath] - if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} - } - - - set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip - set local [binary format a4sssiiiiss PK\03\04 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]] - append local $utfpath $extra - puts -nonewline $zipchan $local - - if {[file isfile $fullpath]} { - # If the file is under 2MB then zip in one chunk, otherwize we use - # streaming to avoid requiring excess memory. This helps to prevent - # storing re-compressed data that may be larger than the source when - # handling PNG or JPEG or nested ZIP files. - if {$size < 0x00200000} { - set fin [open $fullpath rb] - set data [read $fin] - set crc [zlib crc32 $data] - set cdata [zlib deflate $data] - if {[string length $cdata] < $size} { - set method 8 - set data $cdata - } - close $fin - set csize [string length $data] - puts -nonewline $zipchan $data - } else { - set method 8 - set fin [open $fullpath rb] - set zlib [zlib stream deflate] - while {![eof $fin]} { - set data [read $fin 4096] - set crc [zlib crc32 $data $crc] - $zlib put $data - if {[string length [set zdata [$zlib get]]]} { - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - } - } - close $fin - $zlib finalize - set zdata [$zlib get] - incr csize [string length $zdata] - puts -nonewline $zipchan $zdata - $zlib close - } - - if {$seekable} { - # update the header if the output is seekable - set local [binary format a4sssiiii PK\03\04 \ - $version $flags $method $mtime $crc $csize $size] - set current [tell $zipchan] - seek $zipchan $channeloffset - puts -nonewline $zipchan $local - seek $zipchan $current - } else { - # Write a data descriptor record - set ddesc [binary format a4iii PK\7\8 $crc $csize $size] - puts -nonewline $zipchan $ddesc - } - } - - #PK\x01\x02 Cdentral directory file header - #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 - set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) - - set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ - $version $flags $method $mtime $crc $csize $size \ - [string length $utfpath] [string length $extra]\ - [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. - append hdr $utfpath $extra $utfcomment - return $hdr - } - - #### REVIEW!!! - #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') - # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) - #### - - - punk::args::define { - @id -id ::punk::zip::mkzip - @cmd -name punk::zip::mkzip\ - -summary\ - "Create a zip archive in 'filename'."\ - -help\ - "Create a zip archive in 'filename'" - @opts - -offsettype -default "archive" -choices {archive file}\ - -help\ - "zip offsets stored relative to start of entire file or relative to start of zip-archive - Only relevant if the created file has a script/runtime prefix." - -return -default "pretty" -choices {pretty list none}\ - -help\ - "mkzip can return a list of the files and folders added to the archive - the option -return pretty is the default and uses the punk::lib pdict/plist system - to return a formatted list for the terminal - " - -zipkit -default 0 -type none\ - -help\ - "whether to add mounting script - mutually exclusive with -runtime option - currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" - -runtime -default ""\ - -help\ - "specify a prefix file - e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip - will create a self-extracting zip archive from the subdir/ folder. - Expects runtime with no existing vfs attached (review)" - -comment -default ""\ - -help "An optional comment for the archive" - -directory -default ""\ - -help "Scan for contents within this folder or current directory if not provided." - -base -default ""\ - -help\ - "The new zip archive will be rooted in this directory if provided - it must be a parent of -directory or the same path as -directory" - -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - -- -type none -help\ - "End of options marker" - - @values -min 1 -max -1 - filename -type file -default ""\ - -help "name of zipfile to create" - globs -default {*} -multiple 1\ - -help\ - "list of glob patterns to match. - Only directories with matching files will be included in the archive." - } - - # zip::mkzip -- - # - # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt - # - proc mkzip {args} { - #todo - doctools - [arg ?globs...?] syntax? - - #*** !doctools - #[call [fun mkzip]\ - # [opt "[option -offsettype] [arg offsettype]"]\ - # [opt "[option -return] [arg returntype]"]\ - # [opt "[option -zipkit] [arg 0|1]"]\ - # [opt "[option -runtime] [arg preamble_filename]"]\ - # [opt "[option -comment] [arg zipfilecomment]"]\ - # [opt "[option -directory] [arg dir_to_zip]"]\ - # [opt "[option -base] [arg archive_root]"]\ - # [opt "[option -exclude] [arg globlist]"]\ - # [arg zipfilename]\ - # [arg ?glob...?]] - #[para] Create a zip archive in 'zipfilename' - #[para] If a file already exists, an error will be raised. - #[para] Call 'punk::zip::mkzip' with no arguments for usage display. - - set argd [punk::args::parse $args withid ::punk::zip::mkzip] - set filename [dict get $argd values filename] - if {$filename eq ""} { - error "mkzip filename cannot be empty string" - } - if {[regexp {[?*]} $filename]} { - #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name - error "mkzip filename should not contain glob characters ? *" - } - if {[file exists $filename]} { - error "mkzip filename:$filename already exists" - } - dict for {k v} [dict get $argd opts] { - switch -- $k { - -comment { - dict set argd opts $k [encoding convertto utf-8 $v] - } - -directory - -base { - dict set argd opts $k [file normalize $v] - } - } - } - - array set opts [dict get $argd opts] - - - if {$opts(-directory) ne ""} { - if {$opts(-base) ne ""} { - #-base and -directory have been normalized already - if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" - } - set base $opts(-base) - set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] - } else { - set base $opts(-directory) - set relpath "" - } - #will pick up intermediary folders as paths (ending with trailing slash) - set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] - - set norm_filename [file normalize $filename] - set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) - if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { - #check that we aren't adding the zipfile to itself - #REVIEW - now that we open zipfile after scanning - this isn't really a concern! - #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) - #In the case of -force - we may want to delay replacement of original until scan is done? - - #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each - #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths - set self_globs_match 0 - foreach g [dict get $argd values globs] { - if {[string match $g [file tail $filename]]} { - set self_globs_match 1 - break - } - } - if {$self_globs_match} { - #still dangerous - set self_excluded 0 - foreach e $opts(-exclude) { - if {[string match $e [file tail $filename]]} { - set self_excluded 1 - break - } - } - if {!$self_excluded} { - #still dangerous - likely to be in resultset - check each path - #puts stderr "zip file $filename is below directory $opts(-directory)" - set self_is_matched 0 - set i 0 - foreach p $paths { - set norm_p [file normalize [file join $opts(-directory) $p]] - if {[Path_a_at_b $norm_filename $norm_p]} { - set self_is_matched 1 - break - } - incr i - } - if {$self_is_matched} { - puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" - set paths [lremove $paths $i] - } - } - } - } - } else { - #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! - #ie - only the exact *files* matching the glob are stored. - set paths [list] - set dir [pwd] - if {$opts(-base) ne ""} { - if {![Path_a_atorbelow_b $dir $opts(-base)]} { - error "punk::zip::mkzip -base $opts(-base) must be above current directory" - } - set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] - } else { - set relpath "" - } - set base $opts(-base) - - set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] - foreach m $matches { - if {$m eq $filename} { - #puts stderr "--> excluding $filename" - continue - } - set isok 1 - foreach e [concat $opts(-exclude) $filename] { - if {[string match $e $m]} { - set isok 0 - break - } - } - if {$isok} { - lappend paths [file join $relpath $m] - } - } - } - - if {![llength $paths]} { - return "" - } - - set zf [open $filename wb] - if {$opts(-runtime) ne ""} { - #todo - strip any existing vfs - option to merge contents.. only if zip attached? - set rt [open $opts(-runtime) rb] - fcopy $rt $zf - close $rt - } elseif {$opts(-zipkit)} { - #TODO - update to zipfs ? - #see modpod - set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" - append zkd "package require vfs::zip\n" - append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" - append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" - append zkd " source \[file join \[info script\] main.tcl\]\n" - append zkd "}\n" - append zkd \x1A - puts -nonewline $zf $zkd - } - - #todo - subtract this from the endrec offset - if {$opts(-offsettype) eq "archive"} { - set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 - } else { - set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ - } - - set count 0 - set cd "" - - set members [list] - foreach path $paths { - #puts $path - lappend members $path - append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath - incr count - } - set cdoffset [tell $zf] - set endrec [binary format a4ssssiis PK\05\06 0 0 \ - $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ - [string length $opts(-comment)]] - append endrec $opts(-comment) - puts -nonewline $zf $cd - puts -nonewline $zf $endrec - close $zf - - set result "" - switch -exact -- $opts(-return) { - list { - set result $members - } - pretty { - if {[info commands showlist] ne ""} { - set result [plist -channel none members] - } else { - set result $members - } - } - none { - set result "" - } - } - return $result - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::zip ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::zip::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace punk::zip::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide punk::zip [tcl::namespace::eval punk::zip { - variable pkg punk::zip - variable version - set version 0.1.1 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vfs/_vfscommon.vfs/modules/punk/zip-0.2.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.2.0.tm new file mode 100644 index 00000000..eb1651da --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/zip-0.2.0.tm @@ -0,0 +1,1698 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# 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) 2024 JMN +# (C) 2009 Path Thoyts +# +# @@ Meta Begin +# Application punk::zip 0.2.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::zip 0 0.2.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::zip] +#[keywords module zip fileformat] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::zip +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::zip +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::zip}] + #[para] Core API functions for punk::zip + #[list_begin definitions] + + proc Path_a_atorbelow_b {path_a path_b} { + return [expr {[StripPath $path_b $path_a] ne $path_a}] + } + proc Path_a_at_b {path_a path_b} { + return [expr {[StripPath $path_a $path_b] eq "." }] + } + + proc Path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + set pathparts [file split $path] + set prefixparts [file split $prefix] + if {[llength $prefixparts] >= [llength $pathparts]} { + return "" + } + return [file join \ + {*}[lrange \ + $pathparts \ + [llength $prefixparts] \ + end]] + } + + #StripPath - borrowed from tcllib fileutil + # ::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 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 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 + } + } + + proc Timet_to_dos {time_t} { + #*** !doctools + #[call [fun Timet_to_dos] [arg time_t]] + #[para] convert a unix timestamp into a DOS timestamp for ZIP times. + #[example { + # DOS timestamps are 32 bits split into bit regions as follows: + # 24 16 8 0 + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + #}] + set s [clock format $time_t -format {%Y %m %e %k %M %S}] + scan $s {%d %d %d %d %d %d} year month day hour min sec + expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) + | ($hour << 11) | ($min << 5) | ($sec >> 1)} + } + + #Inverse of Timet_to_dos. DOS timestamps carry no timezone, and Timet_to_dos + #formats in local time - so this scans in local time to keep the pair symmetric. + #Entries stored with an unrepresentable date (zero, or corrupt) yield 0. + proc Dos_to_timet {dosdatetime} { + set dosdate [expr {($dosdatetime >> 16) & 0xFFFF}] + set dostime [expr {$dosdatetime & 0xFFFF}] + set year [expr {(($dosdate >> 9) & 0x7F) + 1980}] + set month [expr {($dosdate >> 5) & 0x0F}] + set day [expr {$dosdate & 0x1F}] + set hour [expr {($dostime >> 11) & 0x1F}] + set minute [expr {($dostime >> 5) & 0x3F}] + set second [expr {($dostime & 0x1F) << 1}] + if {$month < 1 || $month > 12 || $day < 1 || $day > 31 || $hour > 23 || $minute > 59 || $second > 59} { + return 0 + } + set stamp [format {%04d %02d %02d %02d %02d %02d} $year $month $day $hour $minute $second] + if {[catch {clock scan $stamp -format {%Y %m %d %H %M %S}} timet]} { + return 0 + } + return $timet + } + + #Compression method ids as they appear in a zip central directory. + #punk::zip READS 0 (store) and 8 (deflate); the rest are named so an + #unsupported archive is refused by name rather than by number. + variable methodnames + set methodnames [dict create {*}{ + 0 store + 1 shrink + 2 reduce1 + 3 reduce2 + 4 reduce3 + 5 reduce4 + 6 implode + 8 deflate + 9 deflate64 + 10 pkware-implode + 12 bzip2 + 14 lzma + 16 cmpsc + 18 terse + 19 lz77 + 20 zstd-deprecated + 93 zstd + 94 mp3 + 95 xz + 96 jpeg + 97 wavpack + 98 ppmd + 99 aes + }] + + proc Method_name {method} { + variable methodnames + if {[dict exists $methodnames $method]} { + return [dict get $methodnames $method] + } + return method-$method + } + punk::args::define { + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -help\ + "Walk the directory structure starting at base/<-subpath> + and return a list of the files and folders encountered. + Resulting paths are relative to base unless -resultrelative + is supplied. + Folder names will end with a trailing slash. + " + -resultrelative -optional 1 -help\ + "Resulting paths are relative to this value. + Defaults to the value of base. If empty string + is given to -resultrelative the paths returned + are effectively absolute paths." + -emptydirs -default 0 -type boolean -help\ + "Whether to include directory trees in the result which had no + matches for the given fileglobs. + Intermediate dirs are always returned if there is a match with + fileglobs further down even if -emptdirs is 0. + " + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" -help\ + "May contain glob chars for folder elements" + #If we don't include --, the call walk -- .. will return nothing as 'base' will receive the -- + -- -type none -optional 1 + @values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } + proc walk {args} { + #*** !doctools + #[call [fun walk] [arg ?options?] [arg base]] + #[para] Walk a directory tree rooted at base + #[para] the -excludes list can be a set of glob expressions to match against files and avoid + #[para] e.g + #[example { + # punk::zip::walk -exclude {CVS/* *~.#*} library + #}] + + #todo: -relative 0|1 flag? + set argd [punk::args::parse $args withid ::punk::zip::walk] + set base [dict get $argd values base] + set fileglobs [dict get $argd values fileglobs] + set subpath [dict get $argd opts -subpath] + set excludes [dict get $argd opts -excludes] + set emptydirs [dict get $argd opts -emptydirs] + + set received [dict get $argd received] + + set imatch [list] + foreach fg $fileglobs { + lappend imatch [file join $subpath $fg] + } + + if {![dict exists $received -resultrelative]} { + set relto $base + set prefix "" + } else { + set relto [file normalize [dict get $argd opts -resultrelative]] + if {$relto ne ""} { + if {![Path_a_atorbelow_b $base $relto]} { + error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" + } + set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] + } else { + set prefix $base + } + } + + set result {} + #set imatch [file join $subpath $match] + set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] + foreach file $files { + set excluded 0 + foreach glob $excludes { + if {[string match $glob $file]} { + set excluded 1 + break + } + } + if {!$excluded} {lappend result [file join $prefix $file]} + } + foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { + set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] + set subdir_entries [list] + set thisdir_match [list] + set has_file 0 + foreach sd $submatches { + set fullpath [file join $prefix $sd] ;#file join destroys trailing slash + if {[string index $sd end] eq "/"} { + lappend subdir_entries $fullpath/ + } else { + set has_file 1 + lappend subdir_entries $fullpath + } + } + if {$emptydirs} { + set thisdir_match [list "[file join $prefix $dir]/"] + } else { + if {$has_file} { + set thisdir_match [list "[file join $prefix $dir]/"] + } else { + set subdir_entries [list] + } + } + #NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" + #This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash + #Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. + set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] + } + return $result + } + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Archive structure - the shared reader machinery. + # + # Every reading surface (extract_preamble, archive_info, members, unzip) goes + # through Archive_read, so a plain zip and a zip attached to an executable are + # one code path, and the archive-relative vs file-relative offset convention is + # decided in exactly one place. + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + #Locate and validate the End Of Central Directory record. + #Scans candidate PK\5\6 signatures from the end of the file backwards - a plain + #executable can contain that byte sequence in its data, so a candidate is only + #accepted if it describes a single-disk directory that really begins with PK\1\2. + #The first pass also requires the record to end exactly at EOF (comment length + #consistent); a second pass drops that so archives with trailing junk still read. + proc Eocd_scan {chan filesize} { + set info [dict create {*}{ + status nozip + reason {no end-of-central-directory record found} + eocdoffset -1 + cdiroffset -1 + cdirsize 0 + count 0 + diroffset 0 + offsetbase 0 + comment {} + }] + dict set info filesize $filesize + if {$filesize < 22} { + return $info + } + set tailstart [expr {$filesize < 65559 ? 0 : $filesize - 65559}] + chan seek $chan $tailstart start + set tail [read $chan] + set candidates [list] + set idx [string length $tail] + while {1} { + set p [string last "\x50\x4b\x05\x06" $tail [expr {$idx - 1}]] + if {$p < 0} { + break + } + lappend candidates [expr {$p + $tailstart}] + set idx $p + } + foreach strict {1 0} { + foreach eocdoffset $candidates { + set try [Eocd_try $chan $filesize $eocdoffset $strict] + if {[dict get $try status] ne "reject"} { + return $try + } + } + } + return $info + } + + proc Eocd_try {chan filesize eocdoffset strict} { + if {$eocdoffset + 22 > $filesize} { + return [dict create status reject] + } + chan seek $chan $eocdoffset start + set rec [read $chan 22] + binary scan $rec issssiis sig disknbr cdirdisk numondisk totalnum cdirsize diroffset commentlen + set disknbr [expr {$disknbr & 0xFFFF}] + set cdirdisk [expr {$cdirdisk & 0xFFFF}] + set numondisk [expr {$numondisk & 0xFFFF}] + set totalnum [expr {$totalnum & 0xFFFF}] + set commentlen [expr {$commentlen & 0xFFFF}] + set cdirsize [expr {$cdirsize & 0xFFFFFFFF}] + set diroffset [expr {$diroffset & 0xFFFFFFFF}] + #single-disk archives only - anything else is a spanned archive or a false positive + if {$disknbr != 0 || $cdirdisk != 0 || $numondisk != $totalnum} { + return [dict create status reject] + } + if {$strict && $eocdoffset + 22 + $commentlen != $filesize} { + return [dict create status reject] + } + set info [dict create {*}{ + status ok + reason {} + } filesize $filesize {*}{ + } eocdoffset $eocdoffset {*}{ + } cdirsize $cdirsize {*}{ + } count $totalnum {*}{ + } diroffset $diroffset {*}{ + }] + #A saturated field means the real value lives in a zip64 record we do not read. + if {$totalnum == 0xFFFF || $cdirsize == 0xFFFFFFFF || $diroffset == 0xFFFFFFFF} { + dict set info status unsupported + dict set info reason "zip64 archive - punk::zip reads single-disk zip32 archives only" + dict set info cdiroffset -1 + dict set info offsetbase 0 + dict set info comment "" + return $info + } + set cdiroffset [expr {$eocdoffset - $cdirsize}] + if {$cdiroffset < 0} { + return [dict create status reject] + } + if {$totalnum > 0} { + chan seek $chan $cdiroffset start + if {[read $chan 4] ne "\x50\x4b\x01\x02"} { + return [dict create status reject] + } + } elseif {$cdirsize != 0} { + return [dict create status reject] + } + #The recorded directory offset is either archive-relative (the directory sits + #that far past a preamble) or file-relative (it IS the file position). The + #difference between where the directory actually is and where the record says + #it is therefore gives the preamble length directly; negative means neither + #reading holds and this candidate is not a real EOCD. + set offsetbase [expr {$cdiroffset - $diroffset}] + if {$offsetbase < 0} { + return [dict create status reject] + } + set comment "" + if {$commentlen > 0} { + chan seek $chan [expr {$eocdoffset + 22}] start + set comment [read $chan $commentlen] + } + dict set info cdiroffset $cdiroffset + dict set info offsetbase $offsetbase + dict set info comment $comment + return $info + } + + punk::args::define { + @id -id ::punk::zip::Cdir_records + @cmd -name punk::zip::Cdir_records\ + -summary\ + "Parse every central directory record of an archive"\ + -help\ + "Walk ALL central directory file headers and return one member dict per + entry, in stored order. Sizes and offsets come from the central + directory, which sidesteps data descriptors entirely. + See punk::zip::members for the member dict keys." + @values -min 2 -max 2 + chan -help "open binary channel positioned anywhere in the archive" + info -type dict -help "archive dict from Eocd_scan with status ok" + } + proc Cdir_records {chan info} { + set cdiroffset [dict get $info cdiroffset] + set cdirsize [dict get $info cdirsize] + set count [dict get $info count] + set offsetbase [dict get $info offsetbase] + if {$count == 0} { + return [list] + } + chan seek $chan $cdiroffset start + set cd [read $chan $cdirsize] + if {[string length $cd] != $cdirsize} { + error "punk::zip: central directory truncated - wanted $cdirsize bytes at $cdiroffset, got [string length $cd]" + } + set members [list] + set pos 0 + for {set i 0} {$i < $count} {incr i} { + if {$pos + 46 > $cdirsize} { + error "punk::zip: central directory truncated - record [expr {$i + 1}] of $count starts beyond the directory" + } + binary scan $cd @${pos}issssssiiisssssii sig madeby version flags method dostime dosdate crc csize size namelen extralen commentlen disknbr iattr eattr offset + if {$sig != 33639248} { + error "punk::zip: bad central directory record [expr {$i + 1}] of $count - expected signature PK\\1\\2" + } + set madeby [expr {$madeby & 0xFFFF}] + set version [expr {$version & 0xFFFF}] + set flags [expr {$flags & 0xFFFF}] + set method [expr {$method & 0xFFFF}] + set dostime [expr {$dostime & 0xFFFF}] + set dosdate [expr {$dosdate & 0xFFFF}] + set namelen [expr {$namelen & 0xFFFF}] + set extralen [expr {$extralen & 0xFFFF}] + set commentlen [expr {$commentlen & 0xFFFF}] + set iattr [expr {$iattr & 0xFFFF}] + set crc [expr {$crc & 0xFFFFFFFF}] + set csize [expr {$csize & 0xFFFFFFFF}] + set size [expr {$size & 0xFFFFFFFF}] + set eattr [expr {$eattr & 0xFFFFFFFF}] + set offset [expr {$offset & 0xFFFFFFFF}] + set namestart [expr {$pos + 46}] + set rawname [string range $cd $namestart [expr {$namestart + $namelen - 1}]] + set commentstart [expr {$namestart + $namelen + $extralen}] + set rawcomment [string range $cd $commentstart [expr {$commentstart + $commentlen - 1}]] + set packedtime [expr {($dosdate << 16) | $dostime}] + set name [Decode_text $rawname $flags] + set hostsystem [expr {($madeby >> 8) & 0xFF}] + lappend members [dict create {*}{ + } name $name {*}{ + } isdirectory [Is_directory_entry $name $size $eattr $hostsystem] {*}{ + } size $size {*}{ + } csize $csize {*}{ + } method $method {*}{ + } methodname [Method_name $method] {*}{ + } mtime [Dos_to_timet $packedtime] {*}{ + } dostime $packedtime {*}{ + } crc $crc {*}{ + } offset $offset {*}{ + } fileoffset [expr {$offsetbase + $offset}] {*}{ + } flags $flags {*}{ + } encrypted [expr {($flags & 0x41) != 0}] {*}{ + } attributes $eattr {*}{ + } iattributes $iattr {*}{ + } madeby $madeby {*}{ + } hostsystem $hostsystem {*}{ + } version $version {*}{ + } comment [Decode_text $rawcomment $flags] {*}{ + }] + incr pos [expr {46 + $namelen + $extralen + $commentlen}] + } + return $members + } + + #Member names and comments are utf-8 when general purpose bit 11 is set + #(punk::zip::mkzip always sets it), and cp437 otherwise. + proc Decode_text {bytes flags} { + if {$bytes eq ""} { + return "" + } + if {$flags & 0x800} { + return [encoding convertfrom utf-8 $bytes] + } + if {[catch {encoding convertfrom cp437 $bytes} decoded]} { + set decoded [encoding convertfrom iso8859-1 $bytes] + } + return $decoded + } + + #A trailing slash is the portable marker; the FAT directory attribute and the + #unix S_IFDIR mode bits are accepted as secondary evidence for archives that + #store directory entries without one. + proc Is_directory_entry {name size eattr hostsystem} { + if {[string index $name end] eq "/"} { + return 1 + } + if {$hostsystem == 3 && (($eattr >> 16) & 0xF000) == 0x4000} { + return 1 + } + if {$size == 0 && ($eattr & 0x10)} { + return 1 + } + return 0 + } + + punk::args::define { + @id -id ::punk::zip::Archive_read + @cmd -name punk::zip::Archive_read\ + -summary\ + "Read the structure of a zip archive on an open channel"\ + -help\ + "Derive the archive geometry and read every central directory record. + Returns a 2-element dict: 'info' (see punk::zip::archive_info for the + keys) and 'members' (see punk::zip::members). + + Never raises for a file that simply is not an archive - callers decide + what a non-ok status means. Does raise for an archive whose central + directory is truncated or malformed." + @values -min 1 -max 1 + chan -help "open channel - reconfigured to binary translation by this call" + } + proc Archive_read {chan} { + chan configure $chan -translation binary + chan seek $chan 0 end + set filesize [tell $chan] + set info [Eocd_scan $chan $filesize] + if {[dict get $info status] ne "ok"} { + #the whole file is preamble as far as any splitting caller is concerned + dict set info dataoffset $filesize + dict set info offsetstyle none + return [dict create info $info members {}] + } + set members [Cdir_records $chan $info] + set offsetbase [dict get $info offsetbase] + set minoffset "" + foreach m $members { + set o [dict get $m offset] + if {$minoffset eq "" || $o < $minoffset} { + set minoffset $o + } + } + if {$minoffset eq ""} { + set minoffset 0 + } + if {$offsetbase > 0} { + #external preamble, archive-relative offsets: the archive begins exactly + #where its own offsets say it does + set dataoffset $offsetbase + set offsetstyle archive + } else { + #file-relative offsets (or no preamble at all): the archive begins at the + #topmost local file header the directory points to. Looking at ALL records + #rather than just the first is what makes this reliable - records are in no + #guaranteed order. + set dataoffset $minoffset + set offsetstyle [expr {$minoffset > 0 ? "file" : "plain"}] + } + dict set info dataoffset $dataoffset + dict set info offsetstyle $offsetstyle + if {[llength $members]} { + #the derivation is only trustworthy if a local file header really sits + #where the first record says it does + chan seek $chan [expr {$offsetbase + $minoffset}] start + if {[read $chan 4] ne "\x50\x4b\x03\x04"} { + dict set info status unsupported + dict set info reason "no local file header at derived archive position [expr {$offsetbase + $minoffset}] - offsets do not describe this file" + } + } + return [dict create info $info members $members] + } + + #if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) + #Otherwise extract an internal preamble. + #if neither -? + #review - reconsider auto-determination of internal vs external preamble + punk::args::define { + @id -id ::punk::zip::extract_preamble + @cmd -name punk::zip::extract_preamble -help\ + "Split a zipfs based executable or library into its constituent + binary and zip parts. + + Note that the binary preamble might be either 'within' the zip offsets, + or simply catenated prior to an unadjusted zip. + Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file + ('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip + ('archive based' offset). An archive-based offset is simpler and more reliably points to the proper + split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. + + Either way, extract_preamble can usually separate them, but in the unusual case that there is both an + external preamble and a preamble within the zip, only the external preamble will be split, with the + internal one remaining in the zip. + + The inverse of this process would be to extract the .zip file created by this split to a folder, + e.g extracted_zip_folder (adjusting contents as required) and then to run: + zipfs mkimg newbinaryname.exe extracted_zip_folder \"\" + " + @values -min 2 -max 3 + infile -type file -optional 0 -help\ + "Name of existing tcl executable or shared lib with attached zipfs filesystem" + outfile_preamble -optional 0 -type file -help\ + "Name of output file for binary preamble to be extracted to. + If this file already exists, an error will be raised" + outfile_zip -default "" -type file -help\ + "Name of output file for zip data to be extracted to. + If this file already exists, an error will be raised" + } + proc extract_preamble {args} { + set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] + lassign [dict values $argd] leaders opts values received + + set infile [dict get $values infile] + set outfile_preamble [dict get $values outfile_preamble] + set outfile_zip [dict get $values outfile_zip] + + set inzip [open $infile r] + fconfigure $inzip -encoding iso8859-1 -translation binary + if {[file exists $outfile_preamble]} { + error "outfile_preamble $outfile_preamble already exists - please remove first" + } + if {$outfile_zip ne ""} { + if {[file exists $outfile_zip] && [file size $outfile_zip]} { + error "outfile_zip $outfile_zip already exists - please remove first" + } + } + chan seek $inzip 0 end + set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent + + #Archive_read does the whole derivation: it finds the EOCD (rejecting the + #PK\5\6 byte sequences that occur in plain executables), decides whether the + #recorded offsets are archive-relative or file-relative, and walks ALL central + #directory records to find the topmost local file header in the file-relative + #case. dataoffset is the split point either way. + #expect CDFH PK\1\2 + #above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) + #above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script + set info [dict get [Archive_read $inzip] info] + switch -- [dict get $info status] { + ok { + set baseoffset [dict get $info dataoffset] + } + nozip { + #no zip eocdr - consider entire file to be the zip preamble + set baseoffset $insize + } + default { + close $inzip + error "unable to determine zip baseoffset of file $infile - [dict get $info reason]" + } + } + + if {$baseoffset < $insize} { + set pout [open $outfile_preamble w] + fconfigure $pout -encoding iso8859-1 -translation binary + chan seek $inzip 0 start + chan copy $inzip $pout -size $baseoffset + close $pout + if {$outfile_zip ne ""} { + #A file-relative archive splits into a .zip whose offsets still count + #from the removed preamble - readers that only accept a bare .zip choke + #on it. punk::zip's own reader never needs the split: point it at the + #ORIGINAL file and the derived base offset makes the shape irrelevant. + #Rewriting the offsets here stays open for callers that must hand a + #plain .zip to something else. + set zout [open $outfile_zip w] + fconfigure $zout -encoding iso8859-1 -translation binary + chan copy $inzip $zout + close $zout + } + close $inzip + } else { + #no valid (from our perspective) eocdr found - baseoffset has been set to insize + close $inzip + file copy $infile $outfile_preamble + if {$outfile_zip ne ""} { + #touch equiv? + set fd [open $outfile_zip w] + close $fd + } + } + } + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Reading - archive_info / members / unzip + # + # Stock Tcl only: no zipfs, no vfs::zip, no tcllib. Works on a plain .zip and on + # a zip attached to an executable or script prefix, under either offset + # convention, because everything reads the ORIGINAL file at a derived base + # offset rather than a split-off intermediate. + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + #open + read structure + close, for the surfaces that take a filename + proc Open_archive {zipfile requirezip} { + if {![file exists $zipfile]} { + error "punk::zip: no such file '$zipfile'" + } + set chan [open $zipfile rb] + if {[catch {Archive_read $chan} arc erropts]} { + close $chan + return -options $erropts $arc + } + set info [dict get $arc info] + set status [dict get $info status] + if {$requirezip && $status ne "ok"} { + close $chan + switch -- $status { + nozip { + error "punk::zip: '$zipfile' is not a zip archive - [dict get $info reason]" + } + default { + error "punk::zip: cannot read '$zipfile' - [dict get $info reason]" + } + } + } + return [dict set arc chan $chan] + } + + #glob selection shared by members and unzip. Patterns are matched against the + #member name both as stored and with any trailing slash removed, so a pattern + #like lib/* selects the lib/ directory entry as well as its contents. + proc Select_members {members globs excludes} { + set selected [list] + foreach m $members { + set name [dict get $m name] + set bare [string trimright $name /] + set matched 0 + foreach g $globs { + if {[string match $g $name] || [string match $g $bare]} { + set matched 1 + break + } + } + if {!$matched} { + continue + } + set excluded 0 + foreach e $excludes { + if {[string match $e $name] || [string match $e $bare]} { + set excluded 1 + break + } + } + if {!$excluded} { + lappend selected $m + } + } + return $selected + } + + #Member names are archive data, not trusted paths: a name that escapes the target + #directory is refused rather than followed. Backslashes are normalised to forward + #slashes (some writers emit them) so the check cannot be side-stepped on windows. + proc Safe_member_path {name} { + set segments [list] + foreach seg [split [string map {\\ /} $name] /] { + if {$seg eq "" || $seg eq "."} { + continue + } + if {$seg eq ".."} { + error "punk::zip: refusing member '$name' - parent-directory segment would escape the target directory" + } + lappend segments $seg + } + if {![llength $segments]} { + error "punk::zip: refusing member '$name' - empty path" + } + if {[file pathtype [lindex $segments 0]] ne "relative"} { + error "punk::zip: refusing member '$name' - not a relative path" + } + return $segments + } + + #Reasons punk::zip cannot extract a member. Checked for every selected member + #BEFORE anything is written, so an unsupported archive produces an error instead + #of a partly-populated target directory. + proc Member_unsupported_reason {m} { + if {[dict get $m encrypted]} { + return "entry is encrypted - punk::zip cannot decrypt zip entries" + } + if {[dict get $m size] == 0xFFFFFFFF || [dict get $m csize] == 0xFFFFFFFF || [dict get $m offset] == 0xFFFFFFFF} { + return "entry uses zip64 size/offset fields - punk::zip reads zip32 entries only" + } + set method [dict get $m method] + if {$method ni {0 8}} { + return "entry uses compression method $method ([dict get $m methodname]) - punk::zip reads stored (0) and deflated (8) entries only" + } + return "" + } + + #Read one member's data from the archive and write it to target. + #Sizes and offsets come from the central directory, so entries written with a + #data descriptor (streamed, sizes zero in the local header) read correctly. + proc Extract_member {chan m target verify} { + set name [dict get $m name] + set fileoffset [dict get $m fileoffset] + set csize [dict get $m csize] + set size [dict get $m size] + set method [dict get $m method] + chan seek $chan $fileoffset start + set lfh [read $chan 30] + if {[string length $lfh] != 30} { + error "punk::zip: truncated local file header for member '$name' at offset $fileoffset" + } + binary scan $lfh isssssiiiss lsig lversion lflags lmethod ltime ldate lcrc lcsize lsize lnamelen lextralen + #dec2hex 67324752 = 4034B50 = PK\3\4 + if {$lsig != 67324752} { + error "punk::zip: no local file header for member '$name' at offset $fileoffset - archive offsets do not describe this file" + } + set lnamelen [expr {$lnamelen & 0xFFFF}] + set lextralen [expr {$lextralen & 0xFFFF}] + chan seek $chan [expr {$fileoffset + 30 + $lnamelen + $lextralen}] start + set out [open $target wb] + set crc 0 + set written 0 + try { + if {$size < 0x00200000} { + #small member - one chunk, mirroring Addentry's 2MB write threshold + set data "" + if {$csize > 0} { + set data [read $chan $csize] + if {[string length $data] != $csize} { + error "punk::zip: truncated data for member '$name' - wanted $csize bytes, got [string length $data]" + } + if {$method == 8} { + set data [zlib inflate $data] + } + } + set crc [zlib crc32 $data] + set written [string length $data] + puts -nonewline $out $data + } else { + #large member - stream, to avoid holding the whole thing in memory + set strm "" + if {$method == 8} { + set strm [zlib stream inflate] + } + set remaining $csize + while {$remaining > 0} { + set want [expr {$remaining > 65536 ? 65536 : $remaining}] + set chunk [read $chan $want] + if {[string length $chunk] != $want} { + error "punk::zip: truncated data for member '$name' - archive ends mid-entry" + } + incr remaining -$want + if {$strm eq ""} { + set crc [zlib crc32 $chunk $crc] + incr written [string length $chunk] + puts -nonewline $out $chunk + continue + } + if {$remaining == 0} { + $strm put -finalize $chunk + } else { + $strm put $chunk + } + #a single get returns only what the stream has already produced - + #drain until empty or the tail of the member is silently dropped + while {1} { + set plain [$strm get 65536] + if {$plain eq ""} { + break + } + set crc [zlib crc32 $plain $crc] + incr written [string length $plain] + puts -nonewline $out $plain + } + } + if {$strm ne ""} { + $strm close + } + } + close $out + set out "" + if {$written != $size} { + error "punk::zip: size mismatch for member '$name' - central directory says $size bytes, decompressed to $written" + } + if {$verify && ($crc & 0xFFFFFFFF) != [dict get $m crc]} { + error "punk::zip: crc mismatch for member '$name' - archive records [dict get $m crc], extracted data is [expr {$crc & 0xFFFFFFFF}]" + } + } on error {result erropts} { + if {$out ne ""} { + catch {close $out} + } + #never leave unverified bytes behind + catch {file delete -- $target} + return -options $erropts $result + } + return $written + } + + punk::args::define { + @id -id ::punk::zip::archive_info + @cmd -name punk::zip::archive_info\ + -summary\ + "Report the zip-archive geometry of a file"\ + -help\ + "Report where the zip archive inside a file begins and which offset + convention it uses, without extracting anything. + + The file may be a plain .zip or a zip attached to an executable or script + prefix - a punk kit, a tclsh carrying a zipfs image, a zip-based .tm + modpod. This is the derivation punk::zip::members, punk::zip::unzip and + punk::zip::extract_preamble all share. + + Does not raise for a file that simply is not an archive - read 'status'. + + Returned dict keys: + status ok | nozip | unsupported + reason why status is not ok + filesize size of the whole file + offsetstyle plain | archive | file | none + plain - a bare zip, no prefix + archive - prefixed, offsets counted from the zip + file - prefixed, offsets counted from the file + none - no archive found + dataoffset where the zip data starts, ie the prefix length + offsetbase add this to a member's stored offset for a file position + eocdoffset file position of the end-of-central-directory record + cdiroffset file position of the central directory + cdirsize size of the central directory + count number of members + diroffset central directory offset as recorded in the archive + comment archive comment + + Examples: + #which convention is this runtime using? + dict get [punk::zip::archive_info bin/punk91.exe] offsetstyle + + #how big is the executable prefix? + dict get [punk::zip::archive_info bin/punk91.exe] dataoffset + + #is there an archive attached at all? (status is ok when there is) + dict get [punk::zip::archive_info some.exe] status + " + @values -min 1 -max 1 + zipfile -type existingfile -help\ + "Path of a zip archive, or of a file with one attached" + } + proc archive_info {args} { + set argd [punk::args::parse $args withid ::punk::zip::archive_info] + set zipfile [dict get $argd values zipfile] + set arc [Open_archive $zipfile 0] + close [dict get $arc chan] + return [dict get $arc info] + } + + punk::args::define { + @id -id ::punk::zip::members + @cmd -name punk::zip::members\ + -summary\ + "List the members of a zip archive without extracting"\ + -help\ + "Read the central directory of a zip archive and return one dict per + member, in stored order, without decompressing anything. + + The archive may be a plain .zip or a zip attached to an executable or + script prefix - see punk::zip::archive_info. Requires only stock Tcl: no + zipfs, no vfs::zip, no tcllib. + + Entries punk::zip cannot EXTRACT (encrypted, zip64, an unsupported + compression method) are still listed - the refusal belongs to + punk::zip::unzip, which names the reason. + + Each member dict carries: + name member path as stored (directories keep a trailing /) + isdirectory 1 for a directory entry, else 0 + size uncompressed size in bytes + csize compressed size in bytes + method compression method id (0 store, 8 deflate) + methodname symbolic name for that method + mtime modification time as a unix timestamp (0 if unusable) + dostime the packed DOS date/time exactly as stored + crc crc32 of the uncompressed data + offset local header offset as stored in the central directory + fileoffset absolute position of that local header in the file + flags general purpose bit flag + encrypted 1 if the entry is encrypted + attributes external file attributes as stored + iattributes internal file attributes as stored + madeby version-made-by field + hostsystem host system code (upper byte of madeby - 0 fat, 3 unix) + version version needed to extract + comment per-member comment + + Examples: + #everything inside a kit + punk::zip::members bin/punk91.exe + + #just the tcl_library scripts + punk::zip::members bin/punk91.exe tcl_library/*.tcl + + #total uncompressed size + set bytes 0 + foreach m [punk::zip::members some.zip] {incr bytes [dict get \$m size]} + + #names only, files not directories + set names [list] + foreach m [punk::zip::members some.zip] { + if {![dict get \$m isdirectory]} {lappend names [dict get \$m name]} + } + " + @opts + -exclude -default {} -help\ + "List of glob expressions matched against member names. + A member matching any of them is left out of the result." + -- -type none -optional 1 -help\ + "End of options marker" + @values -min 1 -max -1 + zipfile -type existingfile -help\ + "Path of a zip archive, or of a file with one attached" + globs -default {*} -multiple 1 -help\ + "Glob patterns matched against member names with 'string match'. + A member is included if it matches any of them. + The whole stored name is matched, so * spans path separators: + *.txt selects sub/deeper/notes.txt as well as top.txt. + Directory entries match with or without their trailing slash." + } + proc members {args} { + set argd [punk::args::parse $args withid ::punk::zip::members] + set zipfile [dict get $argd values zipfile] + set globs [dict get $argd values globs] + set excludes [dict get $argd opts -exclude] + set arc [Open_archive $zipfile 1] + close [dict get $arc chan] + return [Select_members [dict get $arc members] $globs $excludes] + } + + punk::args::define { + @id -id ::punk::zip::unzip + @cmd -name punk::zip::unzip\ + -summary\ + "Extract a zip archive to a directory"\ + -help\ + "Extract all or part of a zip archive into targetdir, verifying each + member's crc32 as it is written. Directory entries are created as + directories; intermediate directories of a selected file are created + whether or not the archive stores an entry for them. + + The archive may be a plain .zip or a zip attached to an executable or + script prefix - see punk::zip::archive_info. Requires only stock Tcl: no + zipfs, no vfs::zip, no tcllib. + + Every selected member is checked for extractability BEFORE anything is + written, so an encrypted, zip64 or unknown-compression archive fails + naming the reason instead of leaving a half-populated directory. A + member whose path would escape targetdir is refused the same way. + + Returns the list of member names extracted (see -return). + + Examples: + #whole archive + punk::zip::unzip some.zip /tmp/out + + #lift a runtime's tcl_library out of the executable it is attached to + punk::zip::unzip bin/punk91.exe /tmp/rt tcl_library/* + + #everything except the docs, keeping timestamps + punk::zip::unzip -exclude {doc/*} -- some.zip /tmp/out + " + @opts + -exclude -default {} -help\ + "List of glob expressions matched against member names. + A member matching any of them is not extracted." + -overwrite -default 1 -type boolean -help\ + "Whether an existing file in targetdir may be replaced. + With -overwrite 0 an existing target is an error, raised before + anything is written." + -mtime -default 1 -type boolean -help\ + "Whether to restore each member's stored modification time. + Directory times are applied after their contents are written." + -verify -default 1 -type boolean -help\ + "Whether to check each extracted member against the crc32 stored in + the archive. A mismatch is an error and the partial file is removed." + -return -default list -choices {list pretty none} -help\ + "list - return the extracted member names (default) + pretty - format that list for terminal display + none - return the empty string" + -- -type none -optional 1 -help\ + "End of options marker" + @values -min 2 -max -1 + zipfile -type existingfile -help\ + "Path of a zip archive, or of a file with one attached" + targetdir -type directory -help\ + "Directory to extract into. Created if it does not exist." + globs -default {*} -multiple 1 -help\ + "Glob patterns matched against member names with 'string match'. + A member is extracted if it matches any of them. + The whole stored name is matched, so * spans path separators: + *.txt selects sub/deeper/notes.txt as well as top.txt. + Directory entries match with or without their trailing slash." + } + proc unzip {args} { + set argd [punk::args::parse $args withid ::punk::zip::unzip] + set zipfile [dict get $argd values zipfile] + set targetdir [dict get $argd values targetdir] + set globs [dict get $argd values globs] + set excludes [dict get $argd opts -exclude] + set overwrite [dict get $argd opts -overwrite] + set restoremtime [dict get $argd opts -mtime] + set verify [dict get $argd opts -verify] + + set arc [Open_archive $zipfile 1] + set chan [dict get $arc chan] + set extracted [list] + set dirtimes [list] + try { + set selected [Select_members [dict get $arc members] $globs $excludes] + #preflight - nothing is written until every selected member is known good + set targets [list] + foreach m $selected { + set reason [Member_unsupported_reason $m] + if {$reason ne ""} { + error "punk::zip::unzip: cannot extract '[dict get $m name]' from $zipfile - $reason" + } + set target [file join $targetdir {*}[Safe_member_path [dict get $m name]]] + if {!$overwrite && !([dict get $m isdirectory]) && [file exists $target]} { + error "punk::zip::unzip: '$target' already exists and -overwrite is 0" + } + lappend targets $target + } + file mkdir $targetdir + foreach m $selected target $targets { + set name [dict get $m name] + if {[dict get $m isdirectory]} { + file mkdir $target + if {$restoremtime && [dict get $m mtime]} { + lappend dirtimes $target [dict get $m mtime] + } + } else { + file mkdir [file dirname $target] + Extract_member $chan $m $target $verify + if {$restoremtime && [dict get $m mtime]} { + catch {file mtime $target [dict get $m mtime]} + } + } + lappend extracted $name + } + } finally { + close $chan + } + #directory times last - writing their contents would have reset them + foreach {dir mtime} $dirtimes { + catch {file mtime $dir $mtime} + } + + switch -exact -- [dict get $argd opts -return] { + pretty { + if {[info commands showlist] ne ""} { + return [plist -channel none extracted] + } + return $extracted + } + none { + return "" + } + default { + return $extracted + } + } + } + + + + punk::args::define { + @id -id ::punk::zip::Addentry + @cmd -name punk::zip::Addentry\ + -summary\ + "Add zip-entry for file at 'path'"\ + -help\ + "Add a single file at 'path' to open channel 'zipchan' + return a central directory file record" + @opts + -comment -default "" -help "An optional comment specific to the added file" + @values -min 3 -max 4 + zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" + base -help "base path for entries" + path -type file -help "path of file to add" + zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe + Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" + } + + # Addentry - was Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Addentry {args} { + #*** !doctools + #[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] + #[para] Add a single file to a zip archive + #[para] The zipchan channel should already be open and binary. + #[para] You can provide a -comment for the file. + #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + + set argd [punk::args::parse $args withid ::punk::zip::Addentry] + set zipchan [dict get $argd values zipchan] + set base [dict get $argd values base] + set path [dict get $argd values path] + set zipdataoffset [dict get $argd values zipdataoffset] + + set comment [dict get $argd opts -comment] + + set fullpath [file join $base $path] + set mtime [Timet_to_dos [file mtime $fullpath]] + set utfpath [encoding convertto utf-8 $path] + set utfcomment [encoding convertto utf-8 $comment] + set flags [expr {(1<<11)}] ;# utf-8 comment and path + set method 0 ;# store 0, deflate 8 + set attr 0 ;# text or binary (default binary) + set version 20 ;# minumum version req'd to extract + set extra "" + set crc 0 + set size 0 + set csize 0 + set data "" + set seekable [expr {[tell $zipchan] != -1}] + if {[file isdirectory $fullpath]} { + set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) + #set attrex 0x40000010 + } elseif {[file executable $fullpath]} { + set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) + } else { + set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) + if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { + set attr 1 ;# text + } + } + + if {[file isfile $fullpath]} { + set size [file size $fullpath] + if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} + } + + + set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip + set local [binary format a4sssiiiiss PK\03\04 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]] + append local $utfpath $extra + puts -nonewline $zipchan $local + + if {[file isfile $fullpath]} { + # If the file is under 2MB then zip in one chunk, otherwize we use + # streaming to avoid requiring excess memory. This helps to prevent + # storing re-compressed data that may be larger than the source when + # handling PNG or JPEG or nested ZIP files. + if {$size < 0x00200000} { + set fin [open $fullpath rb] + set data [read $fin] + set crc [zlib crc32 $data] + set cdata [zlib deflate $data] + if {[string length $cdata] < $size} { + set method 8 + set data $cdata + } + close $fin + set csize [string length $data] + puts -nonewline $zipchan $data + } else { + set method 8 + set fin [open $fullpath rb] + set zlib [zlib stream deflate] + while {![eof $fin]} { + set data [read $fin 4096] + set crc [zlib crc32 $data $crc] + $zlib put $data + if {[string length [set zdata [$zlib get]]]} { + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + } + } + close $fin + $zlib finalize + set zdata [$zlib get] + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + $zlib close + } + + if {$seekable} { + # update the header if the output is seekable + set local [binary format a4sssiiii PK\03\04 \ + $version $flags $method $mtime $crc $csize $size] + set current [tell $zipchan] + seek $zipchan $channeloffset + puts -nonewline $zipchan $local + seek $zipchan $current + } else { + # Write a data descriptor record + set ddesc [binary format a4iii PK\7\8 $crc $csize $size] + puts -nonewline $zipchan $ddesc + } + } + + #PK\x01\x02 Cdentral directory file header + #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 + set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) + + set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]\ + [string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. + append hdr $utfpath $extra $utfcomment + return $hdr + } + + #### REVIEW!!! + #JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') + # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) + #### + + + punk::args::define { + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ + -summary\ + "Create a zip archive in 'filename'."\ + -help\ + "Create a zip archive in 'filename'" + @opts + -offsettype -default "archive" -choices {archive file}\ + -help\ + "zip offsets stored relative to start of entire file or relative to start of zip-archive + Only relevant if the created file has a script/runtime prefix." + -return -default "pretty" -choices {pretty list none}\ + -help\ + "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none\ + -help\ + "whether to add mounting script + mutually exclusive with -runtime option + currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" + -runtime -default ""\ + -help\ + "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + Expects runtime with no existing vfs attached (review)" + -comment -default ""\ + -help "An optional comment for the archive" + -directory -default ""\ + -help "Scan for contents within this folder or current directory if not provided." + -base -default ""\ + -help\ + "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory or the same path as -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + -- -type none -help\ + "End of options marker" + + @values -min 1 -max -1 + filename -type file -default ""\ + -help "name of zipfile to create" + globs -default {*} -multiple 1\ + -help\ + "list of glob patterns to match. + Only directories with matching files will be included in the archive." + } + + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #todo - doctools - [arg ?globs...?] syntax? + + #*** !doctools + #[call [fun mkzip]\ + # [opt "[option -offsettype] [arg offsettype]"]\ + # [opt "[option -return] [arg returntype]"]\ + # [opt "[option -zipkit] [arg 0|1]"]\ + # [opt "[option -runtime] [arg preamble_filename]"]\ + # [opt "[option -comment] [arg zipfilecomment]"]\ + # [opt "[option -directory] [arg dir_to_zip]"]\ + # [opt "[option -base] [arg archive_root]"]\ + # [opt "[option -exclude] [arg globlist]"]\ + # [arg zipfilename]\ + # [arg ?glob...?]] + #[para] Create a zip archive in 'zipfilename' + #[para] If a file already exists, an error will be raised. + #[para] Call 'punk::zip::mkzip' with no arguments for usage display. + + set argd [punk::args::parse $args withid ::punk::zip::mkzip] + set filename [dict get $argd values filename] + if {$filename eq ""} { + error "mkzip filename cannot be empty string" + } + if {[regexp {[?*]} $filename]} { + #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name + error "mkzip filename should not contain glob characters ? *" + } + if {[file exists $filename]} { + error "mkzip filename:$filename already exists" + } + dict for {k v} [dict get $argd opts] { + switch -- $k { + -comment { + dict set argd opts $k [encoding convertto utf-8 $v] + } + -directory - -base { + dict set argd opts $k [file normalize $v] + } + } + } + + array set opts [dict get $argd opts] + + + if {$opts(-directory) ne ""} { + if {$opts(-base) ne ""} { + #-base and -directory have been normalized already + if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" + } + set base $opts(-base) + set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] + } else { + set base $opts(-directory) + set relpath "" + } + #will pick up intermediary folders as paths (ending with trailing slash) + set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] + + set norm_filename [file normalize $filename] + set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) + if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { + #check that we aren't adding the zipfile to itself + #REVIEW - now that we open zipfile after scanning - this isn't really a concern! + #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) + #In the case of -force - we may want to delay replacement of original until scan is done? + + #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each + #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths + set self_globs_match 0 + foreach g [dict get $argd values globs] { + if {[string match $g [file tail $filename]]} { + set self_globs_match 1 + break + } + } + if {$self_globs_match} { + #still dangerous + set self_excluded 0 + foreach e $opts(-exclude) { + if {[string match $e [file tail $filename]]} { + set self_excluded 1 + break + } + } + if {!$self_excluded} { + #still dangerous - likely to be in resultset - check each path + #puts stderr "zip file $filename is below directory $opts(-directory)" + set self_is_matched 0 + set i 0 + foreach p $paths { + set norm_p [file normalize [file join $opts(-directory) $p]] + if {[Path_a_at_b $norm_filename $norm_p]} { + set self_is_matched 1 + break + } + incr i + } + if {$self_is_matched} { + puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" + set paths [lremove $paths $i] + } + } + } + } + } else { + #NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! + #ie - only the exact *files* matching the glob are stored. + set paths [list] + set dir [pwd] + if {$opts(-base) ne ""} { + if {![Path_a_atorbelow_b $dir $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above current directory" + } + set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] + } else { + set relpath "" + } + set base $opts(-base) + + set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] + foreach m $matches { + if {$m eq $filename} { + #puts stderr "--> excluding $filename" + continue + } + set isok 1 + foreach e [concat $opts(-exclude) $filename] { + if {[string match $e $m]} { + set isok 0 + break + } + } + if {$isok} { + lappend paths [file join $relpath $m] + } + } + } + + if {![llength $paths]} { + return "" + } + + set zf [open $filename wb] + if {$opts(-runtime) ne ""} { + #todo - strip any existing vfs - option to merge contents.. only if zip attached? + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + #TODO - update to zipfs ? + #see modpod + set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" + append zkd "package require vfs::zip\n" + append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" + append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" + append zkd " source \[file join \[info script\] main.tcl\]\n" + append zkd "}\n" + append zkd \x1A + puts -nonewline $zf $zkd + } + + #todo - subtract this from the endrec offset + if {$opts(-offsettype) eq "archive"} { + set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 + } else { + set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ + } + + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath + incr count + } + set cdoffset [tell $zf] + set endrec [binary format a4ssssiis PK\05\06 0 0 \ + $count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ + [string length $opts(-comment)]] + append endrec $opts(-comment) + puts -nonewline $zf $cd + puts -nonewline $zf $endrec + close $zf + + set result "" + switch -exact -- $opts(-return) { + list { + set result $members + } + pretty { + if {[info commands showlist] ne ""} { + set result [plist -channel none members] + } else { + set result $members + } + } + none { + set result "" + } + } + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::zip::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::zip [tcl::namespace::eval punk::zip { + variable pkg punk::zip + variable version + set version 0.2.0 +}] +return + +#*** !doctools +#[manpage_end] +