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.
1911 lines
83 KiB
1911 lines
83 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 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license MIT |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::zip 0 999999.0a1.0] |
|
#[copyright "2024"] |
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
#[require punk::zip] |
|
#[keywords module zip fileformat] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::zip |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::zip |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require punk::args |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
#[item] [package {punk::args}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::zip { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
|
|
#G-126 accelerator state - see punk::zip::accelerator and punk::zip::unzip. |
|
#The pure-Tcl reader is the always-available floor; the vendored punkzip |
|
#binary is an optional per-call extraction accelerator. |
|
variable accelerator_config auto ;#auto | none | <path to punkzip executable> |
|
variable accelerator_resolved "" |
|
variable accelerator_resolved_for "\uFFFF" ;#config value the cached resolution was computed for |
|
variable last_unzip_engine "" ;#tcl | accelerated - which engine the last unzip used |
|
variable last_accelerator_note "" ;#why the last unzip skipped the accelerator or fell back |
|
|
|
#*** !doctools |
|
#[subsection {Namespace punk::zip}] |
|
#[para] Core API functions for punk::zip |
|
#[list_begin definitions] |
|
|
|
proc Path_a_atorbelow_b {path_a path_b} { |
|
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
|
} |
|
proc Path_a_at_b {path_a path_b} { |
|
return [expr {[StripPath $path_a $path_b] eq "." }] |
|
} |
|
|
|
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
|
if {$prefix eq ""} { |
|
return $path |
|
} |
|
set pathparts [file split $path] |
|
set prefixparts [file split $prefix] |
|
if {[llength $prefixparts] >= [llength $pathparts]} { |
|
return "" |
|
} |
|
return [file join \ |
|
{*}[lrange \ |
|
$pathparts \ |
|
[llength $prefixparts] \ |
|
end]] |
|
} |
|
|
|
#StripPath - borrowed from tcllib fileutil |
|
# ::fileutil::stripPath -- |
|
# |
|
# If the specified path references/is a path in prefix (or prefix itself) it |
|
# is made relative to prefix. Otherwise it is left unchanged. |
|
# In the case of it being prefix itself the result is the string '.'. |
|
# |
|
# Arguments: |
|
# prefix prefix to strip from the path. |
|
# path path to modify |
|
# |
|
# Results: |
|
# path The (possibly) modified path. |
|
|
|
if {[string equal $::tcl_platform(platform) windows]} { |
|
# Windows. While paths are stored with letter-case preserved al |
|
# comparisons have to be done case-insensitive. For reference see |
|
# SF Tcllib Bug 2499641. |
|
|
|
proc StripPath {prefix path} { |
|
# [file split] is used to generate a canonical form for both |
|
# paths, for easy comparison, and also one which is easy to modify |
|
# using list commands. |
|
|
|
set prefix [file split $prefix] |
|
set npath [file split $path] |
|
|
|
if {[string equal -nocase $prefix $npath]} { |
|
return "." |
|
} |
|
|
|
if {[string match -nocase "${prefix} *" $npath]} { |
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
|
} |
|
return $path |
|
} |
|
} else { |
|
proc StripPath {prefix path} { |
|
# [file split] is used to generate a canonical form for both |
|
# paths, for easy comparison, and also one which is easy to modify |
|
# using list commands. |
|
|
|
set prefix [file split $prefix] |
|
set npath [file split $path] |
|
|
|
if {[string equal $prefix $npath]} { |
|
return "." |
|
} |
|
|
|
if {[string match "${prefix} *" $npath]} { |
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
|
} |
|
return $path |
|
} |
|
} |
|
|
|
proc Timet_to_dos {time_t} { |
|
#*** !doctools |
|
#[call [fun Timet_to_dos] [arg time_t]] |
|
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
|
#[example { |
|
# DOS timestamps are 32 bits split into bit regions as follows: |
|
# 24 16 8 0 |
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
|
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
|
#}] |
|
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
|
scan $s {%d %d %d %d %d %d} year month day hour min sec |
|
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
|
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
|
} |
|
|
|
#Inverse of Timet_to_dos. DOS timestamps carry no timezone, and Timet_to_dos |
|
#formats in local time - so this scans in local time to keep the pair symmetric. |
|
#Entries stored with an unrepresentable date (zero, or corrupt) yield 0. |
|
proc Dos_to_timet {dosdatetime} { |
|
set dosdate [expr {($dosdatetime >> 16) & 0xFFFF}] |
|
set dostime [expr {$dosdatetime & 0xFFFF}] |
|
set year [expr {(($dosdate >> 9) & 0x7F) + 1980}] |
|
set month [expr {($dosdate >> 5) & 0x0F}] |
|
set day [expr {$dosdate & 0x1F}] |
|
set hour [expr {($dostime >> 11) & 0x1F}] |
|
set minute [expr {($dostime >> 5) & 0x3F}] |
|
set second [expr {($dostime & 0x1F) << 1}] |
|
if {$month < 1 || $month > 12 || $day < 1 || $day > 31 || $hour > 23 || $minute > 59 || $second > 59} { |
|
return 0 |
|
} |
|
set stamp [format {%04d %02d %02d %02d %02d %02d} $year $month $day $hour $minute $second] |
|
if {[catch {clock scan $stamp -format {%Y %m %d %H %M %S}} timet]} { |
|
return 0 |
|
} |
|
return $timet |
|
} |
|
|
|
#Compression method ids as they appear in a zip central directory. |
|
#punk::zip READS 0 (store) and 8 (deflate); the rest are named so an |
|
#unsupported archive is refused by name rather than by number. |
|
variable methodnames |
|
set methodnames [dict create {*}{ |
|
0 store |
|
1 shrink |
|
2 reduce1 |
|
3 reduce2 |
|
4 reduce3 |
|
5 reduce4 |
|
6 implode |
|
8 deflate |
|
9 deflate64 |
|
10 pkware-implode |
|
12 bzip2 |
|
14 lzma |
|
16 cmpsc |
|
18 terse |
|
19 lz77 |
|
20 zstd-deprecated |
|
93 zstd |
|
94 mp3 |
|
95 xz |
|
96 jpeg |
|
97 wavpack |
|
98 ppmd |
|
99 aes |
|
}] |
|
|
|
proc Method_name {method} { |
|
variable methodnames |
|
if {[dict exists $methodnames $method]} { |
|
return [dict get $methodnames $method] |
|
} |
|
return method-$method |
|
} |
|
punk::args::define { |
|
@id -id ::punk::zip::walk |
|
@cmd -name punk::zip::walk -help\ |
|
"Walk the directory structure starting at base/<-subpath> |
|
and return a list of the files and folders encountered. |
|
Resulting paths are relative to base unless -resultrelative |
|
is supplied. |
|
Folder names will end with a trailing slash. |
|
" |
|
-resultrelative -optional 1 -help\ |
|
"Resulting paths are relative to this value. |
|
Defaults to the value of base. If empty string |
|
is given to -resultrelative the paths returned |
|
are effectively absolute paths." |
|
-emptydirs -default 0 -type boolean -help\ |
|
"Whether to include directory trees in the result which had no |
|
matches for the given fileglobs. |
|
Intermediate dirs are always returned if there is a match with |
|
fileglobs further down even if -emptdirs is 0. |
|
" |
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
|
-subpath -default "" -help\ |
|
"May contain glob chars for folder elements" |
|
#If we don't include --, the call walk <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 |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Archive structure - the shared reader machinery. |
|
# |
|
# Every reading surface (extract_preamble, archive_info, members, unzip) goes |
|
# through Archive_read, so a plain zip and a zip attached to an executable are |
|
# one code path, and the archive-relative vs file-relative offset convention is |
|
# decided in exactly one place. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#Locate and validate the End Of Central Directory record. |
|
#Scans candidate PK\5\6 signatures from the end of the file backwards - a plain |
|
#executable can contain that byte sequence in its data, so a candidate is only |
|
#accepted if it describes a single-disk directory that really begins with PK\1\2. |
|
#The first pass also requires the record to end exactly at EOF (comment length |
|
#consistent); a second pass drops that so archives with trailing junk still read. |
|
proc Eocd_scan {chan filesize} { |
|
set info [dict create {*}{ |
|
status nozip |
|
reason {no end-of-central-directory record found} |
|
eocdoffset -1 |
|
cdiroffset -1 |
|
cdirsize 0 |
|
count 0 |
|
diroffset 0 |
|
offsetbase 0 |
|
comment {} |
|
}] |
|
dict set info filesize $filesize |
|
if {$filesize < 22} { |
|
return $info |
|
} |
|
set tailstart [expr {$filesize < 65559 ? 0 : $filesize - 65559}] |
|
chan seek $chan $tailstart start |
|
set tail [read $chan] |
|
set candidates [list] |
|
set idx [string length $tail] |
|
while {1} { |
|
set p [string last "\x50\x4b\x05\x06" $tail [expr {$idx - 1}]] |
|
if {$p < 0} { |
|
break |
|
} |
|
lappend candidates [expr {$p + $tailstart}] |
|
set idx $p |
|
} |
|
foreach strict {1 0} { |
|
foreach eocdoffset $candidates { |
|
set try [Eocd_try $chan $filesize $eocdoffset $strict] |
|
if {[dict get $try status] ne "reject"} { |
|
return $try |
|
} |
|
} |
|
} |
|
return $info |
|
} |
|
|
|
proc Eocd_try {chan filesize eocdoffset strict} { |
|
if {$eocdoffset + 22 > $filesize} { |
|
return [dict create status reject] |
|
} |
|
chan seek $chan $eocdoffset start |
|
set rec [read $chan 22] |
|
binary scan $rec issssiis sig disknbr cdirdisk numondisk totalnum cdirsize diroffset commentlen |
|
set disknbr [expr {$disknbr & 0xFFFF}] |
|
set cdirdisk [expr {$cdirdisk & 0xFFFF}] |
|
set numondisk [expr {$numondisk & 0xFFFF}] |
|
set totalnum [expr {$totalnum & 0xFFFF}] |
|
set commentlen [expr {$commentlen & 0xFFFF}] |
|
set cdirsize [expr {$cdirsize & 0xFFFFFFFF}] |
|
set diroffset [expr {$diroffset & 0xFFFFFFFF}] |
|
#single-disk archives only - anything else is a spanned archive or a false positive |
|
if {$disknbr != 0 || $cdirdisk != 0 || $numondisk != $totalnum} { |
|
return [dict create status reject] |
|
} |
|
if {$strict && $eocdoffset + 22 + $commentlen != $filesize} { |
|
return [dict create status reject] |
|
} |
|
set info [dict create {*}{ |
|
status ok |
|
reason {} |
|
} filesize $filesize {*}{ |
|
} eocdoffset $eocdoffset {*}{ |
|
} cdirsize $cdirsize {*}{ |
|
} count $totalnum {*}{ |
|
} diroffset $diroffset {*}{ |
|
}] |
|
#A saturated field means the real value lives in a zip64 record we do not read. |
|
if {$totalnum == 0xFFFF || $cdirsize == 0xFFFFFFFF || $diroffset == 0xFFFFFFFF} { |
|
dict set info status unsupported |
|
dict set info reason "zip64 archive - punk::zip reads single-disk zip32 archives only" |
|
dict set info cdiroffset -1 |
|
dict set info offsetbase 0 |
|
dict set info comment "" |
|
return $info |
|
} |
|
set cdiroffset [expr {$eocdoffset - $cdirsize}] |
|
if {$cdiroffset < 0} { |
|
return [dict create status reject] |
|
} |
|
if {$totalnum > 0} { |
|
chan seek $chan $cdiroffset start |
|
if {[read $chan 4] ne "\x50\x4b\x01\x02"} { |
|
return [dict create status reject] |
|
} |
|
} elseif {$cdirsize != 0} { |
|
return [dict create status reject] |
|
} |
|
#The recorded directory offset is either archive-relative (the directory sits |
|
#that far past a preamble) or file-relative (it IS the file position). The |
|
#difference between where the directory actually is and where the record says |
|
#it is therefore gives the preamble length directly; negative means neither |
|
#reading holds and this candidate is not a real EOCD. |
|
set offsetbase [expr {$cdiroffset - $diroffset}] |
|
if {$offsetbase < 0} { |
|
return [dict create status reject] |
|
} |
|
set comment "" |
|
if {$commentlen > 0} { |
|
chan seek $chan [expr {$eocdoffset + 22}] start |
|
set comment [read $chan $commentlen] |
|
} |
|
dict set info cdiroffset $cdiroffset |
|
dict set info offsetbase $offsetbase |
|
dict set info comment $comment |
|
return $info |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::Cdir_records |
|
@cmd -name punk::zip::Cdir_records\ |
|
-summary\ |
|
"Parse every central directory record of an archive"\ |
|
-help\ |
|
"Walk ALL central directory file headers and return one member dict per |
|
entry, in stored order. Sizes and offsets come from the central |
|
directory, which sidesteps data descriptors entirely. |
|
See punk::zip::members for the member dict keys." |
|
@values -min 2 -max 2 |
|
chan -help "open binary channel positioned anywhere in the archive" |
|
info -type dict -help "archive dict from Eocd_scan with status ok" |
|
} |
|
proc Cdir_records {chan info} { |
|
set cdiroffset [dict get $info cdiroffset] |
|
set cdirsize [dict get $info cdirsize] |
|
set count [dict get $info count] |
|
set offsetbase [dict get $info offsetbase] |
|
if {$count == 0} { |
|
return [list] |
|
} |
|
chan seek $chan $cdiroffset start |
|
set cd [read $chan $cdirsize] |
|
if {[string length $cd] != $cdirsize} { |
|
error "punk::zip: central directory truncated - wanted $cdirsize bytes at $cdiroffset, got [string length $cd]" |
|
} |
|
set members [list] |
|
set pos 0 |
|
for {set i 0} {$i < $count} {incr i} { |
|
if {$pos + 46 > $cdirsize} { |
|
error "punk::zip: central directory truncated - record [expr {$i + 1}] of $count starts beyond the directory" |
|
} |
|
binary scan $cd @${pos}issssssiiisssssii sig madeby version flags method dostime dosdate crc csize size namelen extralen commentlen disknbr iattr eattr offset |
|
if {$sig != 33639248} { |
|
error "punk::zip: bad central directory record [expr {$i + 1}] of $count - expected signature PK\\1\\2" |
|
} |
|
set madeby [expr {$madeby & 0xFFFF}] |
|
set version [expr {$version & 0xFFFF}] |
|
set flags [expr {$flags & 0xFFFF}] |
|
set method [expr {$method & 0xFFFF}] |
|
set dostime [expr {$dostime & 0xFFFF}] |
|
set dosdate [expr {$dosdate & 0xFFFF}] |
|
set namelen [expr {$namelen & 0xFFFF}] |
|
set extralen [expr {$extralen & 0xFFFF}] |
|
set commentlen [expr {$commentlen & 0xFFFF}] |
|
set iattr [expr {$iattr & 0xFFFF}] |
|
set crc [expr {$crc & 0xFFFFFFFF}] |
|
set csize [expr {$csize & 0xFFFFFFFF}] |
|
set size [expr {$size & 0xFFFFFFFF}] |
|
set eattr [expr {$eattr & 0xFFFFFFFF}] |
|
set offset [expr {$offset & 0xFFFFFFFF}] |
|
set namestart [expr {$pos + 46}] |
|
set rawname [string range $cd $namestart [expr {$namestart + $namelen - 1}]] |
|
set commentstart [expr {$namestart + $namelen + $extralen}] |
|
set rawcomment [string range $cd $commentstart [expr {$commentstart + $commentlen - 1}]] |
|
set packedtime [expr {($dosdate << 16) | $dostime}] |
|
set name [Decode_text $rawname $flags] |
|
set hostsystem [expr {($madeby >> 8) & 0xFF}] |
|
lappend members [dict create {*}{ |
|
} name $name {*}{ |
|
} isdirectory [Is_directory_entry $name $size $eattr $hostsystem] {*}{ |
|
} size $size {*}{ |
|
} csize $csize {*}{ |
|
} method $method {*}{ |
|
} methodname [Method_name $method] {*}{ |
|
} mtime [Dos_to_timet $packedtime] {*}{ |
|
} dostime $packedtime {*}{ |
|
} crc $crc {*}{ |
|
} offset $offset {*}{ |
|
} fileoffset [expr {$offsetbase + $offset}] {*}{ |
|
} flags $flags {*}{ |
|
} encrypted [expr {($flags & 0x41) != 0}] {*}{ |
|
} attributes $eattr {*}{ |
|
} iattributes $iattr {*}{ |
|
} madeby $madeby {*}{ |
|
} hostsystem $hostsystem {*}{ |
|
} version $version {*}{ |
|
} comment [Decode_text $rawcomment $flags] {*}{ |
|
}] |
|
incr pos [expr {46 + $namelen + $extralen + $commentlen}] |
|
} |
|
return $members |
|
} |
|
|
|
#Member names and comments are utf-8 when general purpose bit 11 is set |
|
#(punk::zip::mkzip always sets it), and cp437 otherwise. |
|
proc Decode_text {bytes flags} { |
|
if {$bytes eq ""} { |
|
return "" |
|
} |
|
if {$flags & 0x800} { |
|
return [encoding convertfrom utf-8 $bytes] |
|
} |
|
if {[catch {encoding convertfrom cp437 $bytes} decoded]} { |
|
set decoded [encoding convertfrom iso8859-1 $bytes] |
|
} |
|
return $decoded |
|
} |
|
|
|
#A trailing slash is the portable marker; the FAT directory attribute and the |
|
#unix S_IFDIR mode bits are accepted as secondary evidence for archives that |
|
#store directory entries without one. |
|
proc Is_directory_entry {name size eattr hostsystem} { |
|
if {[string index $name end] eq "/"} { |
|
return 1 |
|
} |
|
if {$hostsystem == 3 && (($eattr >> 16) & 0xF000) == 0x4000} { |
|
return 1 |
|
} |
|
if {$size == 0 && ($eattr & 0x10)} { |
|
return 1 |
|
} |
|
return 0 |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::Archive_read |
|
@cmd -name punk::zip::Archive_read\ |
|
-summary\ |
|
"Read the structure of a zip archive on an open channel"\ |
|
-help\ |
|
"Derive the archive geometry and read every central directory record. |
|
Returns a 2-element dict: 'info' (see punk::zip::archive_info for the |
|
keys) and 'members' (see punk::zip::members). |
|
|
|
Never raises for a file that simply is not an archive - callers decide |
|
what a non-ok status means. Does raise for an archive whose central |
|
directory is truncated or malformed." |
|
@values -min 1 -max 1 |
|
chan -help "open channel - reconfigured to binary translation by this call" |
|
} |
|
proc Archive_read {chan} { |
|
chan configure $chan -translation binary |
|
chan seek $chan 0 end |
|
set filesize [tell $chan] |
|
set info [Eocd_scan $chan $filesize] |
|
if {[dict get $info status] ne "ok"} { |
|
#the whole file is preamble as far as any splitting caller is concerned |
|
dict set info dataoffset $filesize |
|
dict set info offsetstyle none |
|
return [dict create info $info members {}] |
|
} |
|
set members [Cdir_records $chan $info] |
|
set offsetbase [dict get $info offsetbase] |
|
set minoffset "" |
|
foreach m $members { |
|
set o [dict get $m offset] |
|
if {$minoffset eq "" || $o < $minoffset} { |
|
set minoffset $o |
|
} |
|
} |
|
if {$minoffset eq ""} { |
|
set minoffset 0 |
|
} |
|
if {$offsetbase > 0} { |
|
#external preamble, archive-relative offsets: the archive begins exactly |
|
#where its own offsets say it does |
|
set dataoffset $offsetbase |
|
set offsetstyle archive |
|
} else { |
|
#file-relative offsets (or no preamble at all): the archive begins at the |
|
#topmost local file header the directory points to. Looking at ALL records |
|
#rather than just the first is what makes this reliable - records are in no |
|
#guaranteed order. |
|
set dataoffset $minoffset |
|
set offsetstyle [expr {$minoffset > 0 ? "file" : "plain"}] |
|
} |
|
dict set info dataoffset $dataoffset |
|
dict set info offsetstyle $offsetstyle |
|
if {[llength $members]} { |
|
#the derivation is only trustworthy if a local file header really sits |
|
#where the first record says it does |
|
chan seek $chan [expr {$offsetbase + $minoffset}] start |
|
if {[read $chan 4] ne "\x50\x4b\x03\x04"} { |
|
dict set info status unsupported |
|
dict set info reason "no local file header at derived archive position [expr {$offsetbase + $minoffset}] - offsets do not describe this file" |
|
} |
|
} |
|
return [dict create info $info members $members] |
|
} |
|
|
|
#if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) |
|
#Otherwise extract an internal preamble. |
|
#if neither -? |
|
#review - reconsider auto-determination of internal vs external preamble |
|
punk::args::define { |
|
@id -id ::punk::zip::extract_preamble |
|
@cmd -name punk::zip::extract_preamble -help\ |
|
"Split a zipfs based executable or library into its constituent |
|
binary and zip parts. |
|
|
|
Note that the binary preamble might be either 'within' the zip offsets, |
|
or simply catenated prior to an unadjusted zip. |
|
Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file |
|
('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip |
|
('archive based' offset). An archive-based offset is simpler and more reliably points to the proper |
|
split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. |
|
|
|
Either way, extract_preamble can usually separate them, but in the unusual case that there is both an |
|
external preamble and a preamble within the zip, only the external preamble will be split, with the |
|
internal one remaining in the zip. |
|
|
|
The inverse of this process would be to extract the .zip file created by this split to a folder, |
|
e.g extracted_zip_folder (adjusting contents as required) and then to run: |
|
zipfs mkimg newbinaryname.exe extracted_zip_folder <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 |
|
|
|
#Archive_read does the whole derivation: it finds the EOCD (rejecting the |
|
#PK\5\6 byte sequences that occur in plain executables), decides whether the |
|
#recorded offsets are archive-relative or file-relative, and walks ALL central |
|
#directory records to find the topmost local file header in the file-relative |
|
#case. dataoffset is the split point either way. |
|
#expect CDFH PK\1\2 |
|
#above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
|
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
|
set info [dict get [Archive_read $inzip] info] |
|
switch -- [dict get $info status] { |
|
ok { |
|
set baseoffset [dict get $info dataoffset] |
|
} |
|
nozip { |
|
#no zip eocdr - consider entire file to be the zip preamble |
|
set baseoffset $insize |
|
} |
|
default { |
|
close $inzip |
|
error "unable to determine zip baseoffset of file $infile - [dict get $info reason]" |
|
} |
|
} |
|
|
|
if {$baseoffset < $insize} { |
|
set pout [open $outfile_preamble w] |
|
fconfigure $pout -encoding iso8859-1 -translation binary |
|
chan seek $inzip 0 start |
|
chan copy $inzip $pout -size $baseoffset |
|
close $pout |
|
if {$outfile_zip ne ""} { |
|
#A file-relative archive splits into a .zip whose offsets still count |
|
#from the removed preamble - readers that only accept a bare .zip choke |
|
#on it. punk::zip's own reader never needs the split: point it at the |
|
#ORIGINAL file and the derived base offset makes the shape irrelevant. |
|
#Rewriting the offsets here stays open for callers that must hand a |
|
#plain .zip to something else. |
|
set zout [open $outfile_zip w] |
|
fconfigure $zout -encoding iso8859-1 -translation binary |
|
chan copy $inzip $zout |
|
close $zout |
|
} |
|
close $inzip |
|
} else { |
|
#no valid (from our perspective) eocdr found - baseoffset has been set to insize |
|
close $inzip |
|
file copy $infile $outfile_preamble |
|
if {$outfile_zip ne ""} { |
|
#touch equiv? |
|
set fd [open $outfile_zip w] |
|
close $fd |
|
} |
|
} |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Reading - archive_info / members / unzip |
|
# |
|
# Stock Tcl only: no zipfs, no vfs::zip, no tcllib. Works on a plain .zip and on |
|
# a zip attached to an executable or script prefix, under either offset |
|
# convention, because everything reads the ORIGINAL file at a derived base |
|
# offset rather than a split-off intermediate. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#open + read structure + close, for the surfaces that take a filename |
|
proc Open_archive {zipfile requirezip} { |
|
if {![file exists $zipfile]} { |
|
error "punk::zip: no such file '$zipfile'" |
|
} |
|
set chan [open $zipfile rb] |
|
if {[catch {Archive_read $chan} arc erropts]} { |
|
close $chan |
|
return -options $erropts $arc |
|
} |
|
set info [dict get $arc info] |
|
set status [dict get $info status] |
|
if {$requirezip && $status ne "ok"} { |
|
close $chan |
|
switch -- $status { |
|
nozip { |
|
error "punk::zip: '$zipfile' is not a zip archive - [dict get $info reason]" |
|
} |
|
default { |
|
error "punk::zip: cannot read '$zipfile' - [dict get $info reason]" |
|
} |
|
} |
|
} |
|
return [dict set arc chan $chan] |
|
} |
|
|
|
#glob selection shared by members and unzip. Patterns are matched against the |
|
#member name both as stored and with any trailing slash removed, so a pattern |
|
#like lib/* selects the lib/ directory entry as well as its contents. |
|
proc Select_members {members globs excludes} { |
|
set selected [list] |
|
foreach m $members { |
|
set name [dict get $m name] |
|
set bare [string trimright $name /] |
|
set matched 0 |
|
foreach g $globs { |
|
if {[string match $g $name] || [string match $g $bare]} { |
|
set matched 1 |
|
break |
|
} |
|
} |
|
if {!$matched} { |
|
continue |
|
} |
|
set excluded 0 |
|
foreach e $excludes { |
|
if {[string match $e $name] || [string match $e $bare]} { |
|
set excluded 1 |
|
break |
|
} |
|
} |
|
if {!$excluded} { |
|
lappend selected $m |
|
} |
|
} |
|
return $selected |
|
} |
|
|
|
#Member names are archive data, not trusted paths: a name that escapes the target |
|
#directory is refused rather than followed. Backslashes are normalised to forward |
|
#slashes (some writers emit them) so the check cannot be side-stepped on windows. |
|
proc Safe_member_path {name} { |
|
set segments [list] |
|
foreach seg [split [string map {\\ /} $name] /] { |
|
if {$seg eq "" || $seg eq "."} { |
|
continue |
|
} |
|
if {$seg eq ".."} { |
|
error "punk::zip: refusing member '$name' - parent-directory segment would escape the target directory" |
|
} |
|
lappend segments $seg |
|
} |
|
if {![llength $segments]} { |
|
error "punk::zip: refusing member '$name' - empty path" |
|
} |
|
if {[file pathtype [lindex $segments 0]] ne "relative"} { |
|
error "punk::zip: refusing member '$name' - not a relative path" |
|
} |
|
return $segments |
|
} |
|
|
|
#Reasons punk::zip cannot extract a member. Checked for every selected member |
|
#BEFORE anything is written, so an unsupported archive produces an error instead |
|
#of a partly-populated target directory. |
|
proc Member_unsupported_reason {m} { |
|
if {[dict get $m encrypted]} { |
|
return "entry is encrypted - punk::zip cannot decrypt zip entries" |
|
} |
|
if {[dict get $m size] == 0xFFFFFFFF || [dict get $m csize] == 0xFFFFFFFF || [dict get $m offset] == 0xFFFFFFFF} { |
|
return "entry uses zip64 size/offset fields - punk::zip reads zip32 entries only" |
|
} |
|
set method [dict get $m method] |
|
if {$method ni {0 8}} { |
|
return "entry uses compression method $method ([dict get $m methodname]) - punk::zip reads stored (0) and deflated (8) entries only" |
|
} |
|
return "" |
|
} |
|
|
|
#Read one member's data from the archive and write it to target. |
|
#Sizes and offsets come from the central directory, so entries written with a |
|
#data descriptor (streamed, sizes zero in the local header) read correctly. |
|
proc Extract_member {chan m target verify} { |
|
set name [dict get $m name] |
|
set fileoffset [dict get $m fileoffset] |
|
set csize [dict get $m csize] |
|
set size [dict get $m size] |
|
set method [dict get $m method] |
|
chan seek $chan $fileoffset start |
|
set lfh [read $chan 30] |
|
if {[string length $lfh] != 30} { |
|
error "punk::zip: truncated local file header for member '$name' at offset $fileoffset" |
|
} |
|
binary scan $lfh isssssiiiss lsig lversion lflags lmethod ltime ldate lcrc lcsize lsize lnamelen lextralen |
|
#dec2hex 67324752 = 4034B50 = PK\3\4 |
|
if {$lsig != 67324752} { |
|
error "punk::zip: no local file header for member '$name' at offset $fileoffset - archive offsets do not describe this file" |
|
} |
|
set lnamelen [expr {$lnamelen & 0xFFFF}] |
|
set lextralen [expr {$lextralen & 0xFFFF}] |
|
chan seek $chan [expr {$fileoffset + 30 + $lnamelen + $lextralen}] start |
|
set out [open $target wb] |
|
set crc 0 |
|
set written 0 |
|
try { |
|
if {$size < 0x00200000} { |
|
#small member - one chunk, mirroring Addentry's 2MB write threshold |
|
set data "" |
|
if {$csize > 0} { |
|
set data [read $chan $csize] |
|
if {[string length $data] != $csize} { |
|
error "punk::zip: truncated data for member '$name' - wanted $csize bytes, got [string length $data]" |
|
} |
|
if {$method == 8} { |
|
set data [zlib inflate $data] |
|
} |
|
} |
|
set crc [zlib crc32 $data] |
|
set written [string length $data] |
|
puts -nonewline $out $data |
|
} else { |
|
#large member - stream, to avoid holding the whole thing in memory |
|
set strm "" |
|
if {$method == 8} { |
|
set strm [zlib stream inflate] |
|
} |
|
set remaining $csize |
|
while {$remaining > 0} { |
|
set want [expr {$remaining > 65536 ? 65536 : $remaining}] |
|
set chunk [read $chan $want] |
|
if {[string length $chunk] != $want} { |
|
error "punk::zip: truncated data for member '$name' - archive ends mid-entry" |
|
} |
|
incr remaining -$want |
|
if {$strm eq ""} { |
|
set crc [zlib crc32 $chunk $crc] |
|
incr written [string length $chunk] |
|
puts -nonewline $out $chunk |
|
continue |
|
} |
|
if {$remaining == 0} { |
|
$strm put -finalize $chunk |
|
} else { |
|
$strm put $chunk |
|
} |
|
#a single get returns only what the stream has already produced - |
|
#drain until empty or the tail of the member is silently dropped |
|
while {1} { |
|
set plain [$strm get 65536] |
|
if {$plain eq ""} { |
|
break |
|
} |
|
set crc [zlib crc32 $plain $crc] |
|
incr written [string length $plain] |
|
puts -nonewline $out $plain |
|
} |
|
} |
|
if {$strm ne ""} { |
|
$strm close |
|
} |
|
} |
|
close $out |
|
set out "" |
|
if {$written != $size} { |
|
error "punk::zip: size mismatch for member '$name' - central directory says $size bytes, decompressed to $written" |
|
} |
|
if {$verify && ($crc & 0xFFFFFFFF) != [dict get $m crc]} { |
|
error "punk::zip: crc mismatch for member '$name' - archive records [dict get $m crc], extracted data is [expr {$crc & 0xFFFFFFFF}]" |
|
} |
|
} on error {result erropts} { |
|
if {$out ne ""} { |
|
catch {close $out} |
|
} |
|
#never leave unverified bytes behind |
|
catch {file delete -- $target} |
|
return -options $erropts $result |
|
} |
|
return $written |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::archive_info |
|
@cmd -name punk::zip::archive_info\ |
|
-summary\ |
|
"Report the zip-archive geometry of a file"\ |
|
-help\ |
|
"Report where the zip archive inside a file begins and which offset |
|
convention it uses, without extracting anything. |
|
|
|
The file may be a plain .zip or a zip attached to an executable or script |
|
prefix - a punk kit, a tclsh carrying a zipfs image, a zip-based .tm |
|
modpod. This is the derivation punk::zip::members, punk::zip::unzip and |
|
punk::zip::extract_preamble all share. |
|
|
|
Does not raise for a file that simply is not an archive - read 'status'. |
|
|
|
Returned dict keys: |
|
status ok | nozip | unsupported |
|
reason why status is not ok |
|
filesize size of the whole file |
|
offsetstyle plain | archive | file | none |
|
plain - a bare zip, no prefix |
|
archive - prefixed, offsets counted from the zip |
|
file - prefixed, offsets counted from the file |
|
none - no archive found |
|
dataoffset where the zip data starts, ie the prefix length |
|
offsetbase add this to a member's stored offset for a file position |
|
eocdoffset file position of the end-of-central-directory record |
|
cdiroffset file position of the central directory |
|
cdirsize size of the central directory |
|
count number of members |
|
diroffset central directory offset as recorded in the archive |
|
comment archive comment |
|
|
|
Examples: |
|
#which convention is this runtime using? |
|
dict get [punk::zip::archive_info bin/punk91.exe] offsetstyle |
|
|
|
#how big is the executable prefix? |
|
dict get [punk::zip::archive_info bin/punk91.exe] dataoffset |
|
|
|
#is there an archive attached at all? (status is ok when there is) |
|
dict get [punk::zip::archive_info some.exe] status |
|
" |
|
@values -min 1 -max 1 |
|
zipfile -type existingfile -help\ |
|
"Path of a zip archive, or of a file with one attached" |
|
} |
|
proc archive_info {args} { |
|
set argd [punk::args::parse $args withid ::punk::zip::archive_info] |
|
set zipfile [dict get $argd values zipfile] |
|
set arc [Open_archive $zipfile 0] |
|
close [dict get $arc chan] |
|
return [dict get $arc info] |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::members |
|
@cmd -name punk::zip::members\ |
|
-summary\ |
|
"List the members of a zip archive without extracting"\ |
|
-help\ |
|
"Read the central directory of a zip archive and return one dict per |
|
member, in stored order, without decompressing anything. |
|
|
|
The archive may be a plain .zip or a zip attached to an executable or |
|
script prefix - see punk::zip::archive_info. Requires only stock Tcl: no |
|
zipfs, no vfs::zip, no tcllib. |
|
|
|
Entries punk::zip cannot EXTRACT (encrypted, zip64, an unsupported |
|
compression method) are still listed - the refusal belongs to |
|
punk::zip::unzip, which names the reason. |
|
|
|
Each member dict carries: |
|
name member path as stored (directories keep a trailing /) |
|
isdirectory 1 for a directory entry, else 0 |
|
size uncompressed size in bytes |
|
csize compressed size in bytes |
|
method compression method id (0 store, 8 deflate) |
|
methodname symbolic name for that method |
|
mtime modification time as a unix timestamp (0 if unusable) |
|
dostime the packed DOS date/time exactly as stored |
|
crc crc32 of the uncompressed data |
|
offset local header offset as stored in the central directory |
|
fileoffset absolute position of that local header in the file |
|
flags general purpose bit flag |
|
encrypted 1 if the entry is encrypted |
|
attributes external file attributes as stored |
|
iattributes internal file attributes as stored |
|
madeby version-made-by field |
|
hostsystem host system code (upper byte of madeby - 0 fat, 3 unix) |
|
version version needed to extract |
|
comment per-member comment |
|
|
|
Examples: |
|
#everything inside a kit |
|
punk::zip::members bin/punk91.exe |
|
|
|
#just the tcl_library scripts |
|
punk::zip::members bin/punk91.exe tcl_library/*.tcl |
|
|
|
#total uncompressed size |
|
set bytes 0 |
|
foreach m [punk::zip::members some.zip] {incr bytes [dict get \$m size]} |
|
|
|
#names only, files not directories |
|
set names [list] |
|
foreach m [punk::zip::members some.zip] { |
|
if {![dict get \$m isdirectory]} {lappend names [dict get \$m name]} |
|
} |
|
" |
|
@opts |
|
-exclude -default {} -help\ |
|
"List of glob expressions matched against member names. |
|
A member matching any of them is left out of the result." |
|
-- -type none -optional 1 -help\ |
|
"End of options marker" |
|
@values -min 1 -max -1 |
|
zipfile -type existingfile -help\ |
|
"Path of a zip archive, or of a file with one attached" |
|
globs -default {*} -multiple 1 -help\ |
|
"Glob patterns matched against member names with 'string match'. |
|
A member is included if it matches any of them. |
|
The whole stored name is matched, so * spans path separators: |
|
*.txt selects sub/deeper/notes.txt as well as top.txt. |
|
Directory entries match with or without their trailing slash." |
|
} |
|
proc members {args} { |
|
set argd [punk::args::parse $args withid ::punk::zip::members] |
|
set zipfile [dict get $argd values zipfile] |
|
set globs [dict get $argd values globs] |
|
set excludes [dict get $argd opts -exclude] |
|
set arc [Open_archive $zipfile 1] |
|
close [dict get $arc chan] |
|
return [Select_members [dict get $arc members] $globs $excludes] |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::accelerator |
|
@cmd -name punk::zip::accelerator\ |
|
-summary\ |
|
"Query or configure the optional punkzip extraction accelerator"\ |
|
-help\ |
|
"punk::zip can hand whole-archive extraction to the vendored punkzip |
|
tool (goal G-126; built to bin/ by 'make.tcl tool build punkzip') |
|
when a usable binary is present - materially faster for large member |
|
counts - while the pure-Tcl reader remains the always-available |
|
floor and the authority on preflight refusals, member selection and |
|
returned names. |
|
|
|
With no argument, returns the currently resolved accelerator path, |
|
or an empty string when none is usable. With an argument, sets the |
|
configuration and returns the new resolution: |
|
auto - (default) probe: env(PUNKZIP_EXE) if set, else a punkzip |
|
executable beside [info nameofexecutable] |
|
none - disable the accelerator (pure-Tcl always) |
|
<path> - use the punkzip binary at an explicit path |
|
|
|
Resolution is cached until the configuration changes. See |
|
punk::zip::unzip for when the accelerator is actually used: calls it |
|
cannot serve identically run pure-Tcl, and an accelerator failure |
|
falls back to pure-Tcl silently. For diagnostics and tests, |
|
punk::zip::last_unzip_engine records which engine the last unzip |
|
used (tcl|accelerated) and punk::zip::last_accelerator_note records |
|
why the accelerator was skipped or abandoned." |
|
@values -min 0 -max 1 |
|
config -optional 1 -default "" -help\ |
|
"auto | none | path of a punkzip executable. |
|
Empty (or omitted) queries without changing the configuration." |
|
} |
|
proc accelerator {args} { |
|
set argd [punk::args::parse $args withid ::punk::zip::accelerator] |
|
variable accelerator_config |
|
variable accelerator_resolved |
|
variable accelerator_resolved_for |
|
set config [dict get $argd values config] |
|
if {$config ne ""} { |
|
set accelerator_config $config |
|
} |
|
if {$accelerator_resolved_for eq $accelerator_config} { |
|
return $accelerator_resolved |
|
} |
|
set resolved "" |
|
set candidates [list] |
|
switch -exact -- $accelerator_config { |
|
none {} |
|
auto { |
|
if {[info exists ::env(PUNKZIP_EXE)] && $::env(PUNKZIP_EXE) ne ""} { |
|
lappend candidates $::env(PUNKZIP_EXE) |
|
} else { |
|
set exedir [file dirname [info nameofexecutable]] |
|
lappend candidates [file join $exedir punkzip.exe] [file join $exedir punkzip] |
|
} |
|
} |
|
default { |
|
lappend candidates $accelerator_config |
|
} |
|
} |
|
foreach c $candidates { |
|
#file executable is unreliable for some windows setups - existence suffices there |
|
if {[file isfile $c] && ([file executable $c] || $::tcl_platform(platform) eq "windows")} { |
|
set resolved [file normalize $c] |
|
break |
|
} |
|
} |
|
set accelerator_resolved $resolved |
|
set accelerator_resolved_for $accelerator_config |
|
return $resolved |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::unzip |
|
@cmd -name punk::zip::unzip\ |
|
-summary\ |
|
"Extract a zip archive to a directory"\ |
|
-help\ |
|
"Extract all or part of a zip archive into targetdir, verifying each |
|
member's crc32 as it is written. Directory entries are created as |
|
directories; intermediate directories of a selected file are created |
|
whether or not the archive stores an entry for them. |
|
|
|
The archive may be a plain .zip or a zip attached to an executable or |
|
script prefix - see punk::zip::archive_info. Requires only stock Tcl: no |
|
zipfs, no vfs::zip, no tcllib. |
|
|
|
Every selected member is checked for extractability BEFORE anything is |
|
written, so an encrypted, zip64 or unknown-compression archive fails |
|
naming the reason instead of leaving a half-populated directory. A |
|
member whose path would escape targetdir is refused the same way. |
|
|
|
When the punkzip accelerator is available (see punk::zip::accelerator) |
|
and the call is one it serves identically - whole archive, default |
|
-overwrite/-mtime/-verify, ascii member names - the member data is |
|
written by the accelerator instead of the pure-Tcl loop, with mtimes |
|
re-stamped to this module's convention afterwards; preflight, member |
|
selection and the returned names always come from punk::zip's own |
|
reader, and any accelerator failure falls back to pure Tcl silently. |
|
punk::zip::last_unzip_engine records which engine ran. |
|
|
|
Returns the list of member names extracted (see -return). |
|
|
|
Examples: |
|
#whole archive |
|
punk::zip::unzip some.zip /tmp/out |
|
|
|
#lift a runtime's tcl_library out of the executable it is attached to |
|
punk::zip::unzip bin/punk91.exe /tmp/rt tcl_library/* |
|
|
|
#everything except the docs, keeping timestamps |
|
punk::zip::unzip -exclude {doc/*} -- some.zip /tmp/out |
|
" |
|
@opts |
|
-exclude -default {} -help\ |
|
"List of glob expressions matched against member names. |
|
A member matching any of them is not extracted." |
|
-overwrite -default 1 -type boolean -help\ |
|
"Whether an existing file in targetdir may be replaced. |
|
With -overwrite 0 an existing target is an error, raised before |
|
anything is written." |
|
-mtime -default 1 -type boolean -help\ |
|
"Whether to restore each member's stored modification time. |
|
Directory times are applied after their contents are written." |
|
-verify -default 1 -type boolean -help\ |
|
"Whether to check each extracted member against the crc32 stored in |
|
the archive. A mismatch is an error and the partial file is removed." |
|
-return -default list -choices {list pretty none} -help\ |
|
"list - return the extracted member names (default) |
|
pretty - format that list for terminal display |
|
none - return the empty string" |
|
-- -type none -optional 1 -help\ |
|
"End of options marker" |
|
@values -min 2 -max -1 |
|
zipfile -type existingfile -help\ |
|
"Path of a zip archive, or of a file with one attached" |
|
targetdir -type directory -help\ |
|
"Directory to extract into. Created if it does not exist." |
|
globs -default {*} -multiple 1 -help\ |
|
"Glob patterns matched against member names with 'string match'. |
|
A member is extracted if it matches any of them. |
|
The whole stored name is matched, so * spans path separators: |
|
*.txt selects sub/deeper/notes.txt as well as top.txt. |
|
Directory entries match with or without their trailing slash." |
|
} |
|
proc unzip {args} { |
|
set argd [punk::args::parse $args withid ::punk::zip::unzip] |
|
set zipfile [dict get $argd values zipfile] |
|
set targetdir [dict get $argd values targetdir] |
|
set globs [dict get $argd values globs] |
|
set excludes [dict get $argd opts -exclude] |
|
set overwrite [dict get $argd opts -overwrite] |
|
set restoremtime [dict get $argd opts -mtime] |
|
set verify [dict get $argd opts -verify] |
|
|
|
variable last_unzip_engine |
|
variable last_accelerator_note |
|
set last_unzip_engine tcl |
|
set last_accelerator_note "" |
|
|
|
set arc [Open_archive $zipfile 1] |
|
set chan [dict get $arc chan] |
|
set extracted [list] |
|
set dirtimes [list] |
|
try { |
|
set selected [Select_members [dict get $arc members] $globs $excludes] |
|
#preflight - nothing is written until every selected member is known good |
|
set targets [list] |
|
set names_ascii 1 |
|
foreach m $selected { |
|
set reason [Member_unsupported_reason $m] |
|
if {$reason ne ""} { |
|
error "punk::zip::unzip: cannot extract '[dict get $m name]' from $zipfile - $reason" |
|
} |
|
set target [file join $targetdir {*}[Safe_member_path [dict get $m name]]] |
|
if {!$overwrite && !([dict get $m isdirectory]) && [file exists $target]} { |
|
error "punk::zip::unzip: '$target' already exists and -overwrite is 0" |
|
} |
|
if {![string is ascii [dict get $m name]]} { |
|
set names_ascii 0 |
|
} |
|
lappend targets $target |
|
} |
|
file mkdir $targetdir |
|
|
|
#G-126 accelerator: hand whole-archive member WRITING to the vendored |
|
#punkzip binary when this call is one it serves identically. punk::zip's |
|
#own parse above stays authoritative for preflight refusals, member |
|
#selection and the returned names; the pure-Tcl loop below is the |
|
#always-available floor and any accelerator failure falls back to it |
|
#silently. Eligibility: whole archive (globs {*}, no excludes), the |
|
#default -overwrite/-mtime/-verify semantics punkzip matches (it always |
|
#overwrites, restores times and crc-verifies), and ascii member names |
|
#(punkzip's name handling is wtf-8; punk::zip decodes cp437/utf-8 flags). |
|
#punkzip stamps mtimes with its tz-free utc convention, so after a |
|
#successful run the members are re-stamped below with this module's |
|
#local-time convention - the two engines produce identical trees. |
|
set accelerated 0 |
|
if {$verify && $overwrite && $restoremtime && $names_ascii |
|
&& [llength $excludes] == 0 && [llength $globs] == 1 && [lindex $globs 0] eq "*"} { |
|
set acc [accelerator] |
|
if {$acc eq ""} { |
|
set last_accelerator_note "no accelerator binary resolved (see punk::zip::accelerator)" |
|
} elseif {[catch {exec $acc extract -d $targetdir $zipfile 2>@1} accout]} { |
|
set last_accelerator_note "accelerator '$acc' failed - fell back to pure tcl: [string range $accout 0 300]" |
|
} else { |
|
set accelerated 1 |
|
} |
|
} else { |
|
set last_accelerator_note "call not accelerator-eligible (selective, non-default options, or non-ascii names) - pure tcl" |
|
} |
|
|
|
if {$accelerated} { |
|
set last_unzip_engine accelerated |
|
foreach m $selected target $targets { |
|
if {[dict get $m isdirectory]} { |
|
if {[dict get $m mtime]} { |
|
lappend dirtimes $target [dict get $m mtime] |
|
} |
|
} else { |
|
if {[dict get $m mtime]} { |
|
catch {file mtime $target [dict get $m mtime]} |
|
} |
|
} |
|
lappend extracted [dict get $m name] |
|
} |
|
} else { |
|
foreach m $selected target $targets { |
|
set name [dict get $m name] |
|
if {[dict get $m isdirectory]} { |
|
file mkdir $target |
|
if {$restoremtime && [dict get $m mtime]} { |
|
lappend dirtimes $target [dict get $m mtime] |
|
} |
|
} else { |
|
file mkdir [file dirname $target] |
|
Extract_member $chan $m $target $verify |
|
if {$restoremtime && [dict get $m mtime]} { |
|
catch {file mtime $target [dict get $m mtime]} |
|
} |
|
} |
|
lappend extracted $name |
|
} |
|
} |
|
} finally { |
|
close $chan |
|
} |
|
#directory times last - writing their contents would have reset them |
|
foreach {dir mtime} $dirtimes { |
|
catch {file mtime $dir $mtime} |
|
} |
|
|
|
switch -exact -- [dict get $argd opts -return] { |
|
pretty { |
|
if {[info commands showlist] ne ""} { |
|
return [plist -channel none extracted] |
|
} |
|
return $extracted |
|
} |
|
none { |
|
return "" |
|
} |
|
default { |
|
return $extracted |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::Addentry |
|
@cmd -name punk::zip::Addentry\ |
|
-summary\ |
|
"Add zip-entry for file at 'path'"\ |
|
-help\ |
|
"Add a single file at 'path' to open channel 'zipchan' |
|
return a central directory file record" |
|
@opts |
|
-comment -default "" -help "An optional comment specific to the added file" |
|
@values -min 3 -max 4 |
|
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" |
|
base -help "base path for entries" |
|
path -type file -help "path of file to add" |
|
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe |
|
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" |
|
} |
|
|
|
# Addentry - was Mkzipfile -- |
|
# |
|
# FIX ME: should handle the current offset for non-seekable channels |
|
# |
|
proc Addentry {args} { |
|
#*** !doctools |
|
#[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
|
#[para] Add a single file to a zip archive |
|
#[para] The zipchan channel should already be open and binary. |
|
#[para] You can provide a -comment for the file. |
|
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
|
|
|
set argd [punk::args::parse $args withid ::punk::zip::Addentry] |
|
set zipchan [dict get $argd values zipchan] |
|
set base [dict get $argd values base] |
|
set path [dict get $argd values path] |
|
set zipdataoffset [dict get $argd values zipdataoffset] |
|
|
|
set comment [dict get $argd opts -comment] |
|
|
|
set fullpath [file join $base $path] |
|
set mtime [Timet_to_dos [file mtime $fullpath]] |
|
set utfpath [encoding convertto utf-8 $path] |
|
set utfcomment [encoding convertto utf-8 $comment] |
|
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
|
set method 0 ;# store 0, deflate 8 |
|
set attr 0 ;# text or binary (default binary) |
|
set version 20 ;# minumum version req'd to extract |
|
set extra "" |
|
set crc 0 |
|
set size 0 |
|
set csize 0 |
|
set data "" |
|
set seekable [expr {[tell $zipchan] != -1}] |
|
if {[file isdirectory $fullpath]} { |
|
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
|
#set attrex 0x40000010 |
|
} elseif {[file executable $fullpath]} { |
|
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
|
} else { |
|
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
|
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
|
set attr 1 ;# text |
|
} |
|
} |
|
|
|
if {[file isfile $fullpath]} { |
|
set size [file size $fullpath] |
|
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
|
} |
|
|
|
|
|
set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip |
|
set local [binary format a4sssiiiiss PK\03\04 \ |
|
$version $flags $method $mtime $crc $csize $size \ |
|
[string length $utfpath] [string length $extra]] |
|
append local $utfpath $extra |
|
puts -nonewline $zipchan $local |
|
|
|
if {[file isfile $fullpath]} { |
|
# If the file is under 2MB then zip in one chunk, otherwize we use |
|
# streaming to avoid requiring excess memory. This helps to prevent |
|
# storing re-compressed data that may be larger than the source when |
|
# handling PNG or JPEG or nested ZIP files. |
|
if {$size < 0x00200000} { |
|
set fin [open $fullpath rb] |
|
set data [read $fin] |
|
set crc [zlib crc32 $data] |
|
set cdata [zlib deflate $data] |
|
if {[string length $cdata] < $size} { |
|
set method 8 |
|
set data $cdata |
|
} |
|
close $fin |
|
set csize [string length $data] |
|
puts -nonewline $zipchan $data |
|
} else { |
|
set method 8 |
|
set fin [open $fullpath rb] |
|
set zlib [zlib stream deflate] |
|
while {![eof $fin]} { |
|
set data [read $fin 4096] |
|
set crc [zlib crc32 $data $crc] |
|
$zlib put $data |
|
if {[string length [set zdata [$zlib get]]]} { |
|
incr csize [string length $zdata] |
|
puts -nonewline $zipchan $zdata |
|
} |
|
} |
|
close $fin |
|
$zlib finalize |
|
set zdata [$zlib get] |
|
incr csize [string length $zdata] |
|
puts -nonewline $zipchan $zdata |
|
$zlib close |
|
} |
|
|
|
if {$seekable} { |
|
# update the header if the output is seekable |
|
set local [binary format a4sssiiii PK\03\04 \ |
|
$version $flags $method $mtime $crc $csize $size] |
|
set current [tell $zipchan] |
|
seek $zipchan $channeloffset |
|
puts -nonewline $zipchan $local |
|
seek $zipchan $current |
|
} else { |
|
# Write a data descriptor record |
|
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
|
puts -nonewline $zipchan $ddesc |
|
} |
|
} |
|
|
|
#PK\x01\x02 Cdentral directory file header |
|
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
|
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
|
|
|
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
|
$version $flags $method $mtime $crc $csize $size \ |
|
[string length $utfpath] [string length $extra]\ |
|
[string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. |
|
append hdr $utfpath $extra $utfcomment |
|
return $hdr |
|
} |
|
|
|
#### REVIEW!!! |
|
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
|
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
|
#### |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::zip::mkzip |
|
@cmd -name punk::zip::mkzip\ |
|
-summary\ |
|
"Create a zip archive in 'filename'."\ |
|
-help\ |
|
"Create a zip archive in 'filename'. |
|
|
|
When the punkzip accelerator is available (see punk::zip::accelerator) |
|
and the call is one it serves identically - directory-scan mode, |
|
archive-relative offsets, no -runtime/-zipkit prefix, whole-tree |
|
globs, ascii comment - the archive is written by punkzip's build |
|
(rooted at the same base, same exclusion set) instead of the |
|
pure-Tcl writer, and verified against this module's own walk |
|
result; any accelerator failure falls back to pure Tcl silently. |
|
punk::zip::last_write_engine records which engine ran." |
|
@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 "" |
|
} |
|
|
|
#G-165 write-path acceleration (mirrors the G-126 read-path seam in |
|
#unzip): hand whole-tree archive WRITING to the vendored punkzip binary |
|
#when this call is one it serves identically - directory-scan mode, |
|
#archive-relative offsets, no -runtime/-zipkit prefix (prefix |
|
#composition is the caller's concern, e.g assemble_zipcat_image), |
|
#default whole-tree globs and an ascii comment. punk::zip's own walk |
|
#above stays authoritative for the member set and the returned names |
|
#(identical to the floor's, order included); punkzip's build re-walks |
|
#with -b rooting at the same base and the same -x exclusion patterns |
|
#(Tcl string match by entry name, both engines). The produced archive |
|
#is read back and its member names compared against the walk result - |
|
#any accelerator failure, unreadable output or mismatch deletes the |
|
#file and falls back to the pure-Tcl writer silently. |
|
#punk::zip::last_write_engine records which engine ran (tcl|accelerated) |
|
#and punk::zip::last_write_note why the accelerator was skipped. |
|
set accelerated 0 |
|
variable last_write_engine |
|
variable last_write_note |
|
set last_write_engine tcl |
|
set last_write_note "" |
|
if {$opts(-directory) ne "" && $opts(-offsettype) eq "archive" |
|
&& $opts(-runtime) eq "" && !$opts(-zipkit) |
|
&& [llength [dict get $argd values globs]] == 1 |
|
&& [lindex [dict get $argd values globs] 0] eq "*" |
|
&& [string is ascii $opts(-comment)]} { |
|
set acc [accelerator] |
|
if {$acc eq ""} { |
|
set last_write_note "no accelerator binary resolved (see punk::zip::accelerator)" |
|
} else { |
|
set acccmd [list $acc build] |
|
if {$opts(-comment) ne ""} { |
|
lappend acccmd -c $opts(-comment) |
|
} |
|
lappend acccmd -b $base |
|
foreach pat $opts(-exclude) { |
|
lappend acccmd -x $pat |
|
} |
|
lappend acccmd $filename $opts(-directory) |
|
if {[catch {exec {*}$acccmd 2>@1} accout]} { |
|
file delete -force $filename |
|
set last_write_note "accelerator '$acc' failed - fell back to pure tcl: [string range $accout 0 300]" |
|
} elseif {[catch {set accnames [lsort [lmap m [members $filename] {dict get $m name}]]} verr]} { |
|
file delete -force $filename |
|
set last_write_note "accelerator output unreadable - fell back to pure tcl: $verr" |
|
} elseif {$accnames ne [lsort $paths]} { |
|
file delete -force $filename |
|
set last_write_note "accelerator member set mismatch - fell back to pure tcl" |
|
} else { |
|
set accelerated 1 |
|
} |
|
} |
|
} else { |
|
set last_write_note "call not write-accelerator eligible (non-directory scan, -offsettype file, -runtime/-zipkit prefix, selective globs, or non-ascii comment) - pure tcl" |
|
} |
|
|
|
if {$accelerated} { |
|
set last_write_engine accelerated |
|
puts stderr "punk::zip::mkzip: accelerated write via $acc (punkzip build -b $base - [llength $paths] members)" |
|
set members $paths |
|
} else { |
|
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 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|