You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
835 lines
36 KiB
835 lines
36 KiB
# -*- 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)} |
|
} |
|
|
|
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::get_dict { |
|
@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." |
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
|
-subpath -default "" -help\ |
|
"May contain glob chars for folder elements" |
|
@values -min 1 -max -1 |
|
base |
|
fileglobs -default {*} -multiple 1 |
|
} $args] |
|
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 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 subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
|
if {[llength $subdir_entries]>0} { |
|
#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 "[file join $prefix $dir]/" {*}$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 |
|
proc extract_preamble {infile outfile_preamble {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 |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
# 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::get_dict { |
|
@id -id ::punk::zip::Addentry |
|
@cmd -name punk::zip::Addentry -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'" |
|
} $args] |
|
|
|
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) |
|
#### |
|
|
|
# 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::get_dict { |
|
@id -id ::punk::zip::mkzip |
|
@cmd -name punk::zip::mkzip\ |
|
-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 "The new zip archive will scan for contents within this folder or current directory if not provided. |
|
Note that this will |
|
" |
|
-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/* *~ ".#*" "*/.#*"} |
|
|
|
@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." |
|
} $args] |
|
|
|
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] |
|
|
|
|