Browse Source
Regenerated by 'make.tcl modules' + 'bootsupport' + 'vfscommonupdate' for the G-124
change. make.tcl loads punk::zip from bootsupport, so the reader only reaches the
zipfs-less bake path once the snapshot carries it.
Also carries two version propagations pending from earlier work, not authored here:
punk 0.2.7 -> 0.2.8 and punk::platform 0.1.0 -> 0.2.0 (the latter was added to
include_modules.config in 5c1e6927 but never snapshotted). Their source buildversion
files are unchanged by this change-set.
The templates modpod is rebuilt because the layout make.tcl inside it changed. Note for
next time: 'make.tcl bootsupport' cannot replace a bootsupport modpod that the running
make.tcl has itself mounted - it failed twice with 'BOOTSUPPORT module update FAILED:
... templates-0.2.0.tm (invalid argument)' while a plain tclsh copied the identical file
without complaint. Copied by hand, then re-run to reconcile the punkcheck record.
Assisted-by: harness=claude; primary-model=claude-opus-5[1m]; api-location=anthropic.com
master
13 changed files with 3594 additions and 1893 deletions
Binary file not shown.
@ -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 <pkg>-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 <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ 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 <options> -- <base> <globs>.. 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 <prefix> \"\" <extracted_preamble_or_alternative exe> |
||||
" |
||||
@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] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@ -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 <pkg>-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 <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ 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 <options> -- <base> <globs>.. 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 <prefix> \"\" <extracted_preamble_or_alternative exe> |
||||
" |
||||
@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] |
||||
|
||||
Loading…
Reference in new issue