Browse Source
Regenerated by 'make.tcl modules' + 'bootsupport' + 'vfscommonupdate' for the G-124
change. make.tcl loads punk::zip from bootsupport, so the reader only reaches the
zipfs-less bake path once the snapshot carries it.
Also carries two version propagations pending from earlier work, not authored here:
punk 0.2.7 -> 0.2.8 and punk::platform 0.1.0 -> 0.2.0 (the latter was added to
include_modules.config in 5c1e6927 but never snapshotted). Their source buildversion
files are unchanged by this change-set.
The templates modpod is rebuilt because the layout make.tcl inside it changed. Note for
next time: 'make.tcl bootsupport' cannot replace a bootsupport modpod that the running
make.tcl has itself mounted - it failed twice with 'BOOTSUPPORT module update FAILED:
... templates-0.2.0.tm (invalid argument)' while a plain tclsh copied the identical file
without complaint. Copied by hand, then re-run to reconcile the punkcheck record.
Assisted-by: harness=claude; primary-model=claude-opus-5[1m]; api-location=anthropic.com
master
13 changed files with 3594 additions and 1893 deletions
Binary file not shown.
@ -1,914 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
|
||||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
||||||
# |
|
||||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
||||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# (C) 2024 JMN |
|
||||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
|
||||||
# |
|
||||||
# @@ Meta Begin |
|
||||||
# Application punk::zip 0.1.1 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license MIT |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# doctools header |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[manpage_begin punkshell_module_punk::zip 0 0.1.1] |
|
||||||
#[copyright "2024"] |
|
||||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
||||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
||||||
#[require punk::zip] |
|
||||||
#[keywords module zip fileformat] |
|
||||||
#[description] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section Overview] |
|
||||||
#[para] overview of punk::zip |
|
||||||
#[subsection Concepts] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Requirements |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection dependencies] |
|
||||||
#[para] packages used by punk::zip |
|
||||||
#[list_begin itemized] |
|
||||||
|
|
||||||
package require Tcl 8.6- |
|
||||||
package require punk::args |
|
||||||
#*** !doctools |
|
||||||
#[item] [package {Tcl 8.6}] |
|
||||||
#[item] [package {punk::args}] |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section API] |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Base namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
tcl::namespace::eval punk::zip { |
|
||||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
||||||
#variable xyz |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace punk::zip}] |
|
||||||
#[para] Core API functions for punk::zip |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
proc Path_a_atorbelow_b {path_a path_b} { |
|
||||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
|
||||||
} |
|
||||||
proc Path_a_at_b {path_a path_b} { |
|
||||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
|
||||||
} |
|
||||||
|
|
||||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
|
||||||
if {$prefix eq ""} { |
|
||||||
return $path |
|
||||||
} |
|
||||||
set pathparts [file split $path] |
|
||||||
set prefixparts [file split $prefix] |
|
||||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
|
||||||
return "" |
|
||||||
} |
|
||||||
return [file join \ |
|
||||||
{*}[lrange \ |
|
||||||
$pathparts \ |
|
||||||
[llength $prefixparts] \ |
|
||||||
end]] |
|
||||||
} |
|
||||||
|
|
||||||
#StripPath - borrowed from tcllib fileutil |
|
||||||
# ::fileutil::stripPath -- |
|
||||||
# |
|
||||||
# If the specified path references/is a path in prefix (or prefix itself) it |
|
||||||
# is made relative to prefix. Otherwise it is left unchanged. |
|
||||||
# In the case of it being prefix itself the result is the string '.'. |
|
||||||
# |
|
||||||
# Arguments: |
|
||||||
# prefix prefix to strip from the path. |
|
||||||
# path path to modify |
|
||||||
# |
|
||||||
# Results: |
|
||||||
# path The (possibly) modified path. |
|
||||||
|
|
||||||
if {[string equal $::tcl_platform(platform) windows]} { |
|
||||||
# Windows. While paths are stored with letter-case preserved al |
|
||||||
# comparisons have to be done case-insensitive. For reference see |
|
||||||
# SF Tcllib Bug 2499641. |
|
||||||
|
|
||||||
proc StripPath {prefix path} { |
|
||||||
# [file split] is used to generate a canonical form for both |
|
||||||
# paths, for easy comparison, and also one which is easy to modify |
|
||||||
# using list commands. |
|
||||||
|
|
||||||
set prefix [file split $prefix] |
|
||||||
set npath [file split $path] |
|
||||||
|
|
||||||
if {[string equal -nocase $prefix $npath]} { |
|
||||||
return "." |
|
||||||
} |
|
||||||
|
|
||||||
if {[string match -nocase "${prefix} *" $npath]} { |
|
||||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
|
||||||
} |
|
||||||
return $path |
|
||||||
} |
|
||||||
} else { |
|
||||||
proc StripPath {prefix path} { |
|
||||||
# [file split] is used to generate a canonical form for both |
|
||||||
# paths, for easy comparison, and also one which is easy to modify |
|
||||||
# using list commands. |
|
||||||
|
|
||||||
set prefix [file split $prefix] |
|
||||||
set npath [file split $path] |
|
||||||
|
|
||||||
if {[string equal $prefix $npath]} { |
|
||||||
return "." |
|
||||||
} |
|
||||||
|
|
||||||
if {[string match "${prefix} *" $npath]} { |
|
||||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
|
||||||
} |
|
||||||
return $path |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc Timet_to_dos {time_t} { |
|
||||||
#*** !doctools |
|
||||||
#[call [fun Timet_to_dos] [arg time_t]] |
|
||||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
|
||||||
#[example { |
|
||||||
# DOS timestamps are 32 bits split into bit regions as follows: |
|
||||||
# 24 16 8 0 |
|
||||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
|
||||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
|
||||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
|
||||||
#}] |
|
||||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
|
||||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
|
||||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
|
||||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
|
||||||
} |
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::walk |
|
||||||
@cmd -name punk::zip::walk -help\ |
|
||||||
"Walk the directory structure starting at base/<-subpath> |
|
||||||
and return a list of the files and folders encountered. |
|
||||||
Resulting paths are relative to base unless -resultrelative |
|
||||||
is supplied. |
|
||||||
Folder names will end with a trailing slash. |
|
||||||
" |
|
||||||
-resultrelative -optional 1 -help\ |
|
||||||
"Resulting paths are relative to this value. |
|
||||||
Defaults to the value of base. If empty string |
|
||||||
is given to -resultrelative the paths returned |
|
||||||
are effectively absolute paths." |
|
||||||
-emptydirs -default 0 -type boolean -help\ |
|
||||||
"Whether to include directory trees in the result which had no |
|
||||||
matches for the given fileglobs. |
|
||||||
Intermediate dirs are always returned if there is a match with |
|
||||||
fileglobs further down even if -emptdirs is 0. |
|
||||||
" |
|
||||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
|
||||||
-subpath -default "" -help\ |
|
||||||
"May contain glob chars for folder elements" |
|
||||||
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the -- |
|
||||||
-- -type none -optional 1 |
|
||||||
@values -min 1 -max -1 |
|
||||||
base |
|
||||||
fileglobs -default {*} -multiple 1 |
|
||||||
} |
|
||||||
proc walk {args} { |
|
||||||
#*** !doctools |
|
||||||
#[call [fun walk] [arg ?options?] [arg base]] |
|
||||||
#[para] Walk a directory tree rooted at base |
|
||||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
|
||||||
#[para] e.g |
|
||||||
#[example { |
|
||||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
|
||||||
#}] |
|
||||||
|
|
||||||
#todo: -relative 0|1 flag? |
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::walk] |
|
||||||
set base [dict get $argd values base] |
|
||||||
set fileglobs [dict get $argd values fileglobs] |
|
||||||
set subpath [dict get $argd opts -subpath] |
|
||||||
set excludes [dict get $argd opts -excludes] |
|
||||||
set emptydirs [dict get $argd opts -emptydirs] |
|
||||||
|
|
||||||
set received [dict get $argd received] |
|
||||||
|
|
||||||
set imatch [list] |
|
||||||
foreach fg $fileglobs { |
|
||||||
lappend imatch [file join $subpath $fg] |
|
||||||
} |
|
||||||
|
|
||||||
if {![dict exists $received -resultrelative]} { |
|
||||||
set relto $base |
|
||||||
set prefix "" |
|
||||||
} else { |
|
||||||
set relto [file normalize [dict get $argd opts -resultrelative]] |
|
||||||
if {$relto ne ""} { |
|
||||||
if {![Path_a_atorbelow_b $base $relto]} { |
|
||||||
error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" |
|
||||||
} |
|
||||||
set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] |
|
||||||
} else { |
|
||||||
set prefix $base |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
set result {} |
|
||||||
#set imatch [file join $subpath $match] |
|
||||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
|
||||||
foreach file $files { |
|
||||||
set excluded 0 |
|
||||||
foreach glob $excludes { |
|
||||||
if {[string match $glob $file]} { |
|
||||||
set excluded 1 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {!$excluded} {lappend result [file join $prefix $file]} |
|
||||||
} |
|
||||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
|
||||||
set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] |
|
||||||
set subdir_entries [list] |
|
||||||
set thisdir_match [list] |
|
||||||
set has_file 0 |
|
||||||
foreach sd $submatches { |
|
||||||
set fullpath [file join $prefix $sd] ;#file join destroys trailing slash |
|
||||||
if {[string index $sd end] eq "/"} { |
|
||||||
lappend subdir_entries $fullpath/ |
|
||||||
} else { |
|
||||||
set has_file 1 |
|
||||||
lappend subdir_entries $fullpath |
|
||||||
} |
|
||||||
} |
|
||||||
if {$emptydirs} { |
|
||||||
set thisdir_match [list "[file join $prefix $dir]/"] |
|
||||||
} else { |
|
||||||
if {$has_file} { |
|
||||||
set thisdir_match [list "[file join $prefix $dir]/"] |
|
||||||
} else { |
|
||||||
set subdir_entries [list] |
|
||||||
} |
|
||||||
} |
|
||||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
|
||||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
|
||||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
|
||||||
set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] |
|
||||||
} |
|
||||||
return $result |
|
||||||
} |
|
||||||
|
|
||||||
#if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) |
|
||||||
#Otherwise extract an internal preamble. |
|
||||||
#if neither -? |
|
||||||
#review - reconsider auto-determination of internal vs external preamble |
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::extract_preamble |
|
||||||
@cmd -name punk::zip::extract_preamble -help\ |
|
||||||
"Split a zipfs based executable or library into its constituent |
|
||||||
binary and zip parts. |
|
||||||
|
|
||||||
Note that the binary preamble might be either 'within' the zip offsets, |
|
||||||
or simply catenated prior to an unadjusted zip. |
|
||||||
Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file |
|
||||||
('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip |
|
||||||
('archive based' offset). An archive-based offset is simpler and more reliably points to the proper |
|
||||||
split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. |
|
||||||
|
|
||||||
Either way, extract_preamble can usually separate them, but in the unusual case that there is both an |
|
||||||
external preamble and a preamble within the zip, only the external preamble will be split, with the |
|
||||||
internal one remaining in the zip. |
|
||||||
|
|
||||||
The inverse of this process would be to extract the .zip file created by this split to a folder, |
|
||||||
e.g extracted_zip_folder (adjusting contents as required) and then to run: |
|
||||||
zipfs mkimg newbinaryname.exe extracted_zip_folder <prefix> \"\" <extracted_preamble_or_alternative exe> |
|
||||||
" |
|
||||||
@values -min 2 -max 3 |
|
||||||
infile -type file -optional 0 -help\ |
|
||||||
"Name of existing tcl executable or shared lib with attached zipfs filesystem" |
|
||||||
outfile_preamble -optional 0 -type file -help\ |
|
||||||
"Name of output file for binary preamble to be extracted to. |
|
||||||
If this file already exists, an error will be raised" |
|
||||||
outfile_zip -default "" -type file -help\ |
|
||||||
"Name of output file for zip data to be extracted to. |
|
||||||
If this file already exists, an error will be raised" |
|
||||||
} |
|
||||||
proc extract_preamble {args} { |
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] |
|
||||||
lassign [dict values $argd] leaders opts values received |
|
||||||
|
|
||||||
set infile [dict get $values infile] |
|
||||||
set outfile_preamble [dict get $values outfile_preamble] |
|
||||||
set outfile_zip [dict get $values outfile_zip] |
|
||||||
|
|
||||||
set inzip [open $infile r] |
|
||||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
|
||||||
if {[file exists $outfile_preamble]} { |
|
||||||
error "outfile_preamble $outfile_preamble already exists - please remove first" |
|
||||||
} |
|
||||||
if {$outfile_zip ne ""} { |
|
||||||
if {[file exists $outfile_zip] && [file size $outfile_zip]} { |
|
||||||
error "outfile_zip $outfile_zip already exists - please remove first" |
|
||||||
} |
|
||||||
} |
|
||||||
chan seek $inzip 0 end |
|
||||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
|
||||||
chan seek $inzip 0 start |
|
||||||
#only scan last 64k - cover max signature size?? review |
|
||||||
if {$insize < 65559} { |
|
||||||
set tailsearch_start 0 |
|
||||||
} else { |
|
||||||
set tailsearch_start [expr {$insize - 65559}] |
|
||||||
} |
|
||||||
chan seek $inzip $tailsearch_start start |
|
||||||
set scan [read $inzip] |
|
||||||
#EOCD - End Of Central Directory record |
|
||||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
|
||||||
puts stdout "==>start_of_end: $start_of_end" |
|
||||||
|
|
||||||
if {$start_of_end == -1} { |
|
||||||
#no zip eocdr - consider entire file to be the zip preamble |
|
||||||
set baseoffset $insize |
|
||||||
} else { |
|
||||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
|
||||||
chan seek $inzip $filerelative_eocd_posn |
|
||||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
|
||||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
#rule out a false positive from within a nonzip (e.g plain exe) |
|
||||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
|
||||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
|
||||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
|
||||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
|
||||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
|
||||||
#review - should keep searching? |
|
||||||
#for now we assume not a zip |
|
||||||
set baseoffset $insize |
|
||||||
} else { |
|
||||||
#use the central dir size to jump back tko start of central dir |
|
||||||
#determine if diroffset is file or archive relative |
|
||||||
|
|
||||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
|
||||||
puts stdout "---> [read $inzip 4]" |
|
||||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
|
||||||
#'external preamble' easy case |
|
||||||
# - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
|
||||||
#though we are assuming zip offsets are not corrupted |
|
||||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
|
||||||
} else { |
|
||||||
#'internal preamble' hard case |
|
||||||
# - either no preamble - or offsets have been adjusted to be file relative. |
|
||||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
|
||||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
|
||||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
|
||||||
|
|
||||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
|
||||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
|
||||||
set baseoffset "unknown" |
|
||||||
chan seek $inzip $filerelative_cdir_start start |
|
||||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
#load the whole central dir into cdir |
|
||||||
|
|
||||||
#todo! loop through all cdr file headers - find highest offset? |
|
||||||
#tclZipfs.c just looks at first file header in Central Directory |
|
||||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
|
||||||
|
|
||||||
set cdirdata [read $inzip $eocd(dirsize)] |
|
||||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
|
||||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
|
||||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
|
||||||
|
|
||||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
|
||||||
chan seek $inzip $cdir(relativeoffset) |
|
||||||
#let's at least check that we landed on a local file header.. |
|
||||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
|
||||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
|
||||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
|
||||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
|
||||||
puts stdout "1st local file header sig: $lfh(signature)" |
|
||||||
if {$lfh(signature) == 67324752} { |
|
||||||
#looks like a local file header |
|
||||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
|
||||||
set baseoffset $cdir(relativeoffset) |
|
||||||
} |
|
||||||
} |
|
||||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
|
||||||
} |
|
||||||
} |
|
||||||
puts stdout "baseoffset: $baseoffset" |
|
||||||
#expect CDFH PK\1\2 |
|
||||||
#above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
|
||||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
|
||||||
|
|
||||||
if {![string is integer -strict $baseoffset]} { |
|
||||||
error "unable to determine zip baseoffset of file $infile" |
|
||||||
} |
|
||||||
|
|
||||||
if {$baseoffset < $insize} { |
|
||||||
set pout [open $outfile_preamble w] |
|
||||||
fconfigure $pout -encoding iso8859-1 -translation binary |
|
||||||
chan seek $inzip 0 start |
|
||||||
chan copy $inzip $pout -size $baseoffset |
|
||||||
close $pout |
|
||||||
if {$outfile_zip ne ""} { |
|
||||||
#todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile |
|
||||||
set zout [open $outfile_zip w] |
|
||||||
fconfigure $zout -encoding iso8859-1 -translation binary |
|
||||||
chan copy $inzip $zout |
|
||||||
close $zout |
|
||||||
} |
|
||||||
close $inzip |
|
||||||
} else { |
|
||||||
#no valid (from our perspective) eocdr found - baseoffset has been set to insize |
|
||||||
close $inzip |
|
||||||
file copy $infile $outfile_preamble |
|
||||||
if {$outfile_zip ne ""} { |
|
||||||
#touch equiv? |
|
||||||
set fd [open $outfile_zip w] |
|
||||||
close $fd |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::Addentry |
|
||||||
@cmd -name punk::zip::Addentry\ |
|
||||||
-summary\ |
|
||||||
"Add zip-entry for file at 'path'"\ |
|
||||||
-help\ |
|
||||||
"Add a single file at 'path' to open channel 'zipchan' |
|
||||||
return a central directory file record" |
|
||||||
@opts |
|
||||||
-comment -default "" -help "An optional comment specific to the added file" |
|
||||||
@values -min 3 -max 4 |
|
||||||
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" |
|
||||||
base -help "base path for entries" |
|
||||||
path -type file -help "path of file to add" |
|
||||||
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe |
|
||||||
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" |
|
||||||
} |
|
||||||
|
|
||||||
# Addentry - was Mkzipfile -- |
|
||||||
# |
|
||||||
# FIX ME: should handle the current offset for non-seekable channels |
|
||||||
# |
|
||||||
proc Addentry {args} { |
|
||||||
#*** !doctools |
|
||||||
#[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
|
||||||
#[para] Add a single file to a zip archive |
|
||||||
#[para] The zipchan channel should already be open and binary. |
|
||||||
#[para] You can provide a -comment for the file. |
|
||||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
|
||||||
|
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::Addentry] |
|
||||||
set zipchan [dict get $argd values zipchan] |
|
||||||
set base [dict get $argd values base] |
|
||||||
set path [dict get $argd values path] |
|
||||||
set zipdataoffset [dict get $argd values zipdataoffset] |
|
||||||
|
|
||||||
set comment [dict get $argd opts -comment] |
|
||||||
|
|
||||||
set fullpath [file join $base $path] |
|
||||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
|
||||||
set utfpath [encoding convertto utf-8 $path] |
|
||||||
set utfcomment [encoding convertto utf-8 $comment] |
|
||||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
|
||||||
set method 0 ;# store 0, deflate 8 |
|
||||||
set attr 0 ;# text or binary (default binary) |
|
||||||
set version 20 ;# minumum version req'd to extract |
|
||||||
set extra "" |
|
||||||
set crc 0 |
|
||||||
set size 0 |
|
||||||
set csize 0 |
|
||||||
set data "" |
|
||||||
set seekable [expr {[tell $zipchan] != -1}] |
|
||||||
if {[file isdirectory $fullpath]} { |
|
||||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
|
||||||
#set attrex 0x40000010 |
|
||||||
} elseif {[file executable $fullpath]} { |
|
||||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
|
||||||
} else { |
|
||||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
|
||||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
|
||||||
set attr 1 ;# text |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
if {[file isfile $fullpath]} { |
|
||||||
set size [file size $fullpath] |
|
||||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip |
|
||||||
set local [binary format a4sssiiiiss PK\03\04 \ |
|
||||||
$version $flags $method $mtime $crc $csize $size \ |
|
||||||
[string length $utfpath] [string length $extra]] |
|
||||||
append local $utfpath $extra |
|
||||||
puts -nonewline $zipchan $local |
|
||||||
|
|
||||||
if {[file isfile $fullpath]} { |
|
||||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
|
||||||
# streaming to avoid requiring excess memory. This helps to prevent |
|
||||||
# storing re-compressed data that may be larger than the source when |
|
||||||
# handling PNG or JPEG or nested ZIP files. |
|
||||||
if {$size < 0x00200000} { |
|
||||||
set fin [open $fullpath rb] |
|
||||||
set data [read $fin] |
|
||||||
set crc [zlib crc32 $data] |
|
||||||
set cdata [zlib deflate $data] |
|
||||||
if {[string length $cdata] < $size} { |
|
||||||
set method 8 |
|
||||||
set data $cdata |
|
||||||
} |
|
||||||
close $fin |
|
||||||
set csize [string length $data] |
|
||||||
puts -nonewline $zipchan $data |
|
||||||
} else { |
|
||||||
set method 8 |
|
||||||
set fin [open $fullpath rb] |
|
||||||
set zlib [zlib stream deflate] |
|
||||||
while {![eof $fin]} { |
|
||||||
set data [read $fin 4096] |
|
||||||
set crc [zlib crc32 $data $crc] |
|
||||||
$zlib put $data |
|
||||||
if {[string length [set zdata [$zlib get]]]} { |
|
||||||
incr csize [string length $zdata] |
|
||||||
puts -nonewline $zipchan $zdata |
|
||||||
} |
|
||||||
} |
|
||||||
close $fin |
|
||||||
$zlib finalize |
|
||||||
set zdata [$zlib get] |
|
||||||
incr csize [string length $zdata] |
|
||||||
puts -nonewline $zipchan $zdata |
|
||||||
$zlib close |
|
||||||
} |
|
||||||
|
|
||||||
if {$seekable} { |
|
||||||
# update the header if the output is seekable |
|
||||||
set local [binary format a4sssiiii PK\03\04 \ |
|
||||||
$version $flags $method $mtime $crc $csize $size] |
|
||||||
set current [tell $zipchan] |
|
||||||
seek $zipchan $channeloffset |
|
||||||
puts -nonewline $zipchan $local |
|
||||||
seek $zipchan $current |
|
||||||
} else { |
|
||||||
# Write a data descriptor record |
|
||||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
|
||||||
puts -nonewline $zipchan $ddesc |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#PK\x01\x02 Cdentral directory file header |
|
||||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
|
||||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
|
||||||
|
|
||||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
|
||||||
$version $flags $method $mtime $crc $csize $size \ |
|
||||||
[string length $utfpath] [string length $extra]\ |
|
||||||
[string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. |
|
||||||
append hdr $utfpath $extra $utfcomment |
|
||||||
return $hdr |
|
||||||
} |
|
||||||
|
|
||||||
#### REVIEW!!! |
|
||||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
|
||||||
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
|
||||||
#### |
|
||||||
|
|
||||||
|
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::mkzip |
|
||||||
@cmd -name punk::zip::mkzip\ |
|
||||||
-summary\ |
|
||||||
"Create a zip archive in 'filename'."\ |
|
||||||
-help\ |
|
||||||
"Create a zip archive in 'filename'" |
|
||||||
@opts |
|
||||||
-offsettype -default "archive" -choices {archive file}\ |
|
||||||
-help\ |
|
||||||
"zip offsets stored relative to start of entire file or relative to start of zip-archive |
|
||||||
Only relevant if the created file has a script/runtime prefix." |
|
||||||
-return -default "pretty" -choices {pretty list none}\ |
|
||||||
-help\ |
|
||||||
"mkzip can return a list of the files and folders added to the archive |
|
||||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
|
||||||
to return a formatted list for the terminal |
|
||||||
" |
|
||||||
-zipkit -default 0 -type none\ |
|
||||||
-help\ |
|
||||||
"whether to add mounting script |
|
||||||
mutually exclusive with -runtime option |
|
||||||
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" |
|
||||||
-runtime -default ""\ |
|
||||||
-help\ |
|
||||||
"specify a prefix file |
|
||||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip |
|
||||||
will create a self-extracting zip archive from the subdir/ folder. |
|
||||||
Expects runtime with no existing vfs attached (review)" |
|
||||||
-comment -default ""\ |
|
||||||
-help "An optional comment for the archive" |
|
||||||
-directory -default ""\ |
|
||||||
-help "Scan for contents within this folder or current directory if not provided." |
|
||||||
-base -default ""\ |
|
||||||
-help\ |
|
||||||
"The new zip archive will be rooted in this directory if provided |
|
||||||
it must be a parent of -directory or the same path as -directory" |
|
||||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
|
||||||
-- -type none -help\ |
|
||||||
"End of options marker" |
|
||||||
|
|
||||||
@values -min 1 -max -1 |
|
||||||
filename -type file -default ""\ |
|
||||||
-help "name of zipfile to create" |
|
||||||
globs -default {*} -multiple 1\ |
|
||||||
-help\ |
|
||||||
"list of glob patterns to match. |
|
||||||
Only directories with matching files will be included in the archive." |
|
||||||
} |
|
||||||
|
|
||||||
# zip::mkzip -- |
|
||||||
# |
|
||||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
|
||||||
# |
|
||||||
proc mkzip {args} { |
|
||||||
#todo - doctools - [arg ?globs...?] syntax? |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[call [fun mkzip]\ |
|
||||||
# [opt "[option -offsettype] [arg offsettype]"]\ |
|
||||||
# [opt "[option -return] [arg returntype]"]\ |
|
||||||
# [opt "[option -zipkit] [arg 0|1]"]\ |
|
||||||
# [opt "[option -runtime] [arg preamble_filename]"]\ |
|
||||||
# [opt "[option -comment] [arg zipfilecomment]"]\ |
|
||||||
# [opt "[option -directory] [arg dir_to_zip]"]\ |
|
||||||
# [opt "[option -base] [arg archive_root]"]\ |
|
||||||
# [opt "[option -exclude] [arg globlist]"]\ |
|
||||||
# [arg zipfilename]\ |
|
||||||
# [arg ?glob...?]] |
|
||||||
#[para] Create a zip archive in 'zipfilename' |
|
||||||
#[para] If a file already exists, an error will be raised. |
|
||||||
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. |
|
||||||
|
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::mkzip] |
|
||||||
set filename [dict get $argd values filename] |
|
||||||
if {$filename eq ""} { |
|
||||||
error "mkzip filename cannot be empty string" |
|
||||||
} |
|
||||||
if {[regexp {[?*]} $filename]} { |
|
||||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
|
||||||
error "mkzip filename should not contain glob characters ? *" |
|
||||||
} |
|
||||||
if {[file exists $filename]} { |
|
||||||
error "mkzip filename:$filename already exists" |
|
||||||
} |
|
||||||
dict for {k v} [dict get $argd opts] { |
|
||||||
switch -- $k { |
|
||||||
-comment { |
|
||||||
dict set argd opts $k [encoding convertto utf-8 $v] |
|
||||||
} |
|
||||||
-directory - -base { |
|
||||||
dict set argd opts $k [file normalize $v] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
array set opts [dict get $argd opts] |
|
||||||
|
|
||||||
|
|
||||||
if {$opts(-directory) ne ""} { |
|
||||||
if {$opts(-base) ne ""} { |
|
||||||
#-base and -directory have been normalized already |
|
||||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
|
||||||
error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" |
|
||||||
} |
|
||||||
set base $opts(-base) |
|
||||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
|
||||||
} else { |
|
||||||
set base $opts(-directory) |
|
||||||
set relpath "" |
|
||||||
} |
|
||||||
#will pick up intermediary folders as paths (ending with trailing slash) |
|
||||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
|
||||||
|
|
||||||
set norm_filename [file normalize $filename] |
|
||||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
|
||||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
|
||||||
#check that we aren't adding the zipfile to itself |
|
||||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
|
||||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
|
||||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
|
||||||
|
|
||||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
|
||||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
|
||||||
set self_globs_match 0 |
|
||||||
foreach g [dict get $argd values globs] { |
|
||||||
if {[string match $g [file tail $filename]]} { |
|
||||||
set self_globs_match 1 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {$self_globs_match} { |
|
||||||
#still dangerous |
|
||||||
set self_excluded 0 |
|
||||||
foreach e $opts(-exclude) { |
|
||||||
if {[string match $e [file tail $filename]]} { |
|
||||||
set self_excluded 1 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {!$self_excluded} { |
|
||||||
#still dangerous - likely to be in resultset - check each path |
|
||||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
|
||||||
set self_is_matched 0 |
|
||||||
set i 0 |
|
||||||
foreach p $paths { |
|
||||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
|
||||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
|
||||||
set self_is_matched 1 |
|
||||||
break |
|
||||||
} |
|
||||||
incr i |
|
||||||
} |
|
||||||
if {$self_is_matched} { |
|
||||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
|
||||||
set paths [lremove $paths $i] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} else { |
|
||||||
#NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! |
|
||||||
#ie - only the exact *files* matching the glob are stored. |
|
||||||
set paths [list] |
|
||||||
set dir [pwd] |
|
||||||
if {$opts(-base) ne ""} { |
|
||||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
|
||||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
|
||||||
} |
|
||||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
|
||||||
} else { |
|
||||||
set relpath "" |
|
||||||
} |
|
||||||
set base $opts(-base) |
|
||||||
|
|
||||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
|
||||||
foreach m $matches { |
|
||||||
if {$m eq $filename} { |
|
||||||
#puts stderr "--> excluding $filename" |
|
||||||
continue |
|
||||||
} |
|
||||||
set isok 1 |
|
||||||
foreach e [concat $opts(-exclude) $filename] { |
|
||||||
if {[string match $e $m]} { |
|
||||||
set isok 0 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {$isok} { |
|
||||||
lappend paths [file join $relpath $m] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
if {![llength $paths]} { |
|
||||||
return "" |
|
||||||
} |
|
||||||
|
|
||||||
set zf [open $filename wb] |
|
||||||
if {$opts(-runtime) ne ""} { |
|
||||||
#todo - strip any existing vfs - option to merge contents.. only if zip attached? |
|
||||||
set rt [open $opts(-runtime) rb] |
|
||||||
fcopy $rt $zf |
|
||||||
close $rt |
|
||||||
} elseif {$opts(-zipkit)} { |
|
||||||
#TODO - update to zipfs ? |
|
||||||
#see modpod |
|
||||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
|
||||||
append zkd "package require vfs::zip\n" |
|
||||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
|
||||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
|
||||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
|
||||||
append zkd "}\n" |
|
||||||
append zkd \x1A |
|
||||||
puts -nonewline $zf $zkd |
|
||||||
} |
|
||||||
|
|
||||||
#todo - subtract this from the endrec offset |
|
||||||
if {$opts(-offsettype) eq "archive"} { |
|
||||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 |
|
||||||
} else { |
|
||||||
set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ |
|
||||||
} |
|
||||||
|
|
||||||
set count 0 |
|
||||||
set cd "" |
|
||||||
|
|
||||||
set members [list] |
|
||||||
foreach path $paths { |
|
||||||
#puts $path |
|
||||||
lappend members $path |
|
||||||
append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath |
|
||||||
incr count |
|
||||||
} |
|
||||||
set cdoffset [tell $zf] |
|
||||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
|
||||||
$count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ |
|
||||||
[string length $opts(-comment)]] |
|
||||||
append endrec $opts(-comment) |
|
||||||
puts -nonewline $zf $cd |
|
||||||
puts -nonewline $zf $endrec |
|
||||||
close $zf |
|
||||||
|
|
||||||
set result "" |
|
||||||
switch -exact -- $opts(-return) { |
|
||||||
list { |
|
||||||
set result $members |
|
||||||
} |
|
||||||
pretty { |
|
||||||
if {[info commands showlist] ne ""} { |
|
||||||
set result [plist -channel none members] |
|
||||||
} else { |
|
||||||
set result $members |
|
||||||
} |
|
||||||
} |
|
||||||
none { |
|
||||||
set result "" |
|
||||||
} |
|
||||||
} |
|
||||||
return $result |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Secondary API namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
tcl::namespace::eval punk::zip::lib { |
|
||||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
||||||
tcl::namespace::path [tcl::namespace::parent] |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace punk::zip::lib}] |
|
||||||
#[para] Secondary functions that are part of the API |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
#proc utility1 {p1 args} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
||||||
# #[para]Description of utility1 |
|
||||||
# return 1 |
|
||||||
#} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Ready |
|
||||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
|
||||||
variable pkg punk::zip |
|
||||||
variable version |
|
||||||
set version 0.1.1 |
|
||||||
}] |
|
||||||
return |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[manpage_end] |
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@ -1,914 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
|
||||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
||||||
# |
|
||||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
||||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# (C) 2024 JMN |
|
||||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
|
||||||
# |
|
||||||
# @@ Meta Begin |
|
||||||
# Application punk::zip 0.1.1 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license MIT |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# doctools header |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[manpage_begin punkshell_module_punk::zip 0 0.1.1] |
|
||||||
#[copyright "2024"] |
|
||||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
|
||||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
|
||||||
#[require punk::zip] |
|
||||||
#[keywords module zip fileformat] |
|
||||||
#[description] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section Overview] |
|
||||||
#[para] overview of punk::zip |
|
||||||
#[subsection Concepts] |
|
||||||
#[para] - |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Requirements |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection dependencies] |
|
||||||
#[para] packages used by punk::zip |
|
||||||
#[list_begin itemized] |
|
||||||
|
|
||||||
package require Tcl 8.6- |
|
||||||
package require punk::args |
|
||||||
#*** !doctools |
|
||||||
#[item] [package {Tcl 8.6}] |
|
||||||
#[item] [package {punk::args}] |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] |
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[section API] |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Base namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
tcl::namespace::eval punk::zip { |
|
||||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
||||||
#variable xyz |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace punk::zip}] |
|
||||||
#[para] Core API functions for punk::zip |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
proc Path_a_atorbelow_b {path_a path_b} { |
|
||||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
|
||||||
} |
|
||||||
proc Path_a_at_b {path_a path_b} { |
|
||||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
|
||||||
} |
|
||||||
|
|
||||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
|
||||||
if {$prefix eq ""} { |
|
||||||
return $path |
|
||||||
} |
|
||||||
set pathparts [file split $path] |
|
||||||
set prefixparts [file split $prefix] |
|
||||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
|
||||||
return "" |
|
||||||
} |
|
||||||
return [file join \ |
|
||||||
{*}[lrange \ |
|
||||||
$pathparts \ |
|
||||||
[llength $prefixparts] \ |
|
||||||
end]] |
|
||||||
} |
|
||||||
|
|
||||||
#StripPath - borrowed from tcllib fileutil |
|
||||||
# ::fileutil::stripPath -- |
|
||||||
# |
|
||||||
# If the specified path references/is a path in prefix (or prefix itself) it |
|
||||||
# is made relative to prefix. Otherwise it is left unchanged. |
|
||||||
# In the case of it being prefix itself the result is the string '.'. |
|
||||||
# |
|
||||||
# Arguments: |
|
||||||
# prefix prefix to strip from the path. |
|
||||||
# path path to modify |
|
||||||
# |
|
||||||
# Results: |
|
||||||
# path The (possibly) modified path. |
|
||||||
|
|
||||||
if {[string equal $::tcl_platform(platform) windows]} { |
|
||||||
# Windows. While paths are stored with letter-case preserved al |
|
||||||
# comparisons have to be done case-insensitive. For reference see |
|
||||||
# SF Tcllib Bug 2499641. |
|
||||||
|
|
||||||
proc StripPath {prefix path} { |
|
||||||
# [file split] is used to generate a canonical form for both |
|
||||||
# paths, for easy comparison, and also one which is easy to modify |
|
||||||
# using list commands. |
|
||||||
|
|
||||||
set prefix [file split $prefix] |
|
||||||
set npath [file split $path] |
|
||||||
|
|
||||||
if {[string equal -nocase $prefix $npath]} { |
|
||||||
return "." |
|
||||||
} |
|
||||||
|
|
||||||
if {[string match -nocase "${prefix} *" $npath]} { |
|
||||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
|
||||||
} |
|
||||||
return $path |
|
||||||
} |
|
||||||
} else { |
|
||||||
proc StripPath {prefix path} { |
|
||||||
# [file split] is used to generate a canonical form for both |
|
||||||
# paths, for easy comparison, and also one which is easy to modify |
|
||||||
# using list commands. |
|
||||||
|
|
||||||
set prefix [file split $prefix] |
|
||||||
set npath [file split $path] |
|
||||||
|
|
||||||
if {[string equal $prefix $npath]} { |
|
||||||
return "." |
|
||||||
} |
|
||||||
|
|
||||||
if {[string match "${prefix} *" $npath]} { |
|
||||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
|
||||||
} |
|
||||||
return $path |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc Timet_to_dos {time_t} { |
|
||||||
#*** !doctools |
|
||||||
#[call [fun Timet_to_dos] [arg time_t]] |
|
||||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
|
||||||
#[example { |
|
||||||
# DOS timestamps are 32 bits split into bit regions as follows: |
|
||||||
# 24 16 8 0 |
|
||||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
|
||||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
|
||||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
|
||||||
#}] |
|
||||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
|
||||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
|
||||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
|
||||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
|
||||||
} |
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::walk |
|
||||||
@cmd -name punk::zip::walk -help\ |
|
||||||
"Walk the directory structure starting at base/<-subpath> |
|
||||||
and return a list of the files and folders encountered. |
|
||||||
Resulting paths are relative to base unless -resultrelative |
|
||||||
is supplied. |
|
||||||
Folder names will end with a trailing slash. |
|
||||||
" |
|
||||||
-resultrelative -optional 1 -help\ |
|
||||||
"Resulting paths are relative to this value. |
|
||||||
Defaults to the value of base. If empty string |
|
||||||
is given to -resultrelative the paths returned |
|
||||||
are effectively absolute paths." |
|
||||||
-emptydirs -default 0 -type boolean -help\ |
|
||||||
"Whether to include directory trees in the result which had no |
|
||||||
matches for the given fileglobs. |
|
||||||
Intermediate dirs are always returned if there is a match with |
|
||||||
fileglobs further down even if -emptdirs is 0. |
|
||||||
" |
|
||||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
|
||||||
-subpath -default "" -help\ |
|
||||||
"May contain glob chars for folder elements" |
|
||||||
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the -- |
|
||||||
-- -type none -optional 1 |
|
||||||
@values -min 1 -max -1 |
|
||||||
base |
|
||||||
fileglobs -default {*} -multiple 1 |
|
||||||
} |
|
||||||
proc walk {args} { |
|
||||||
#*** !doctools |
|
||||||
#[call [fun walk] [arg ?options?] [arg base]] |
|
||||||
#[para] Walk a directory tree rooted at base |
|
||||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
|
||||||
#[para] e.g |
|
||||||
#[example { |
|
||||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
|
||||||
#}] |
|
||||||
|
|
||||||
#todo: -relative 0|1 flag? |
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::walk] |
|
||||||
set base [dict get $argd values base] |
|
||||||
set fileglobs [dict get $argd values fileglobs] |
|
||||||
set subpath [dict get $argd opts -subpath] |
|
||||||
set excludes [dict get $argd opts -excludes] |
|
||||||
set emptydirs [dict get $argd opts -emptydirs] |
|
||||||
|
|
||||||
set received [dict get $argd received] |
|
||||||
|
|
||||||
set imatch [list] |
|
||||||
foreach fg $fileglobs { |
|
||||||
lappend imatch [file join $subpath $fg] |
|
||||||
} |
|
||||||
|
|
||||||
if {![dict exists $received -resultrelative]} { |
|
||||||
set relto $base |
|
||||||
set prefix "" |
|
||||||
} else { |
|
||||||
set relto [file normalize [dict get $argd opts -resultrelative]] |
|
||||||
if {$relto ne ""} { |
|
||||||
if {![Path_a_atorbelow_b $base $relto]} { |
|
||||||
error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" |
|
||||||
} |
|
||||||
set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] |
|
||||||
} else { |
|
||||||
set prefix $base |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
set result {} |
|
||||||
#set imatch [file join $subpath $match] |
|
||||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
|
||||||
foreach file $files { |
|
||||||
set excluded 0 |
|
||||||
foreach glob $excludes { |
|
||||||
if {[string match $glob $file]} { |
|
||||||
set excluded 1 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {!$excluded} {lappend result [file join $prefix $file]} |
|
||||||
} |
|
||||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
|
||||||
set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] |
|
||||||
set subdir_entries [list] |
|
||||||
set thisdir_match [list] |
|
||||||
set has_file 0 |
|
||||||
foreach sd $submatches { |
|
||||||
set fullpath [file join $prefix $sd] ;#file join destroys trailing slash |
|
||||||
if {[string index $sd end] eq "/"} { |
|
||||||
lappend subdir_entries $fullpath/ |
|
||||||
} else { |
|
||||||
set has_file 1 |
|
||||||
lappend subdir_entries $fullpath |
|
||||||
} |
|
||||||
} |
|
||||||
if {$emptydirs} { |
|
||||||
set thisdir_match [list "[file join $prefix $dir]/"] |
|
||||||
} else { |
|
||||||
if {$has_file} { |
|
||||||
set thisdir_match [list "[file join $prefix $dir]/"] |
|
||||||
} else { |
|
||||||
set subdir_entries [list] |
|
||||||
} |
|
||||||
} |
|
||||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
|
||||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
|
||||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
|
||||||
set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] |
|
||||||
} |
|
||||||
return $result |
|
||||||
} |
|
||||||
|
|
||||||
#if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) |
|
||||||
#Otherwise extract an internal preamble. |
|
||||||
#if neither -? |
|
||||||
#review - reconsider auto-determination of internal vs external preamble |
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::extract_preamble |
|
||||||
@cmd -name punk::zip::extract_preamble -help\ |
|
||||||
"Split a zipfs based executable or library into its constituent |
|
||||||
binary and zip parts. |
|
||||||
|
|
||||||
Note that the binary preamble might be either 'within' the zip offsets, |
|
||||||
or simply catenated prior to an unadjusted zip. |
|
||||||
Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file |
|
||||||
('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip |
|
||||||
('archive based' offset). An archive-based offset is simpler and more reliably points to the proper |
|
||||||
split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. |
|
||||||
|
|
||||||
Either way, extract_preamble can usually separate them, but in the unusual case that there is both an |
|
||||||
external preamble and a preamble within the zip, only the external preamble will be split, with the |
|
||||||
internal one remaining in the zip. |
|
||||||
|
|
||||||
The inverse of this process would be to extract the .zip file created by this split to a folder, |
|
||||||
e.g extracted_zip_folder (adjusting contents as required) and then to run: |
|
||||||
zipfs mkimg newbinaryname.exe extracted_zip_folder <prefix> \"\" <extracted_preamble_or_alternative exe> |
|
||||||
" |
|
||||||
@values -min 2 -max 3 |
|
||||||
infile -type file -optional 0 -help\ |
|
||||||
"Name of existing tcl executable or shared lib with attached zipfs filesystem" |
|
||||||
outfile_preamble -optional 0 -type file -help\ |
|
||||||
"Name of output file for binary preamble to be extracted to. |
|
||||||
If this file already exists, an error will be raised" |
|
||||||
outfile_zip -default "" -type file -help\ |
|
||||||
"Name of output file for zip data to be extracted to. |
|
||||||
If this file already exists, an error will be raised" |
|
||||||
} |
|
||||||
proc extract_preamble {args} { |
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] |
|
||||||
lassign [dict values $argd] leaders opts values received |
|
||||||
|
|
||||||
set infile [dict get $values infile] |
|
||||||
set outfile_preamble [dict get $values outfile_preamble] |
|
||||||
set outfile_zip [dict get $values outfile_zip] |
|
||||||
|
|
||||||
set inzip [open $infile r] |
|
||||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
|
||||||
if {[file exists $outfile_preamble]} { |
|
||||||
error "outfile_preamble $outfile_preamble already exists - please remove first" |
|
||||||
} |
|
||||||
if {$outfile_zip ne ""} { |
|
||||||
if {[file exists $outfile_zip] && [file size $outfile_zip]} { |
|
||||||
error "outfile_zip $outfile_zip already exists - please remove first" |
|
||||||
} |
|
||||||
} |
|
||||||
chan seek $inzip 0 end |
|
||||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
|
||||||
chan seek $inzip 0 start |
|
||||||
#only scan last 64k - cover max signature size?? review |
|
||||||
if {$insize < 65559} { |
|
||||||
set tailsearch_start 0 |
|
||||||
} else { |
|
||||||
set tailsearch_start [expr {$insize - 65559}] |
|
||||||
} |
|
||||||
chan seek $inzip $tailsearch_start start |
|
||||||
set scan [read $inzip] |
|
||||||
#EOCD - End Of Central Directory record |
|
||||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
|
||||||
puts stdout "==>start_of_end: $start_of_end" |
|
||||||
|
|
||||||
if {$start_of_end == -1} { |
|
||||||
#no zip eocdr - consider entire file to be the zip preamble |
|
||||||
set baseoffset $insize |
|
||||||
} else { |
|
||||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
|
||||||
chan seek $inzip $filerelative_eocd_posn |
|
||||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
|
||||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
#rule out a false positive from within a nonzip (e.g plain exe) |
|
||||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
|
||||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
|
||||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
|
||||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
|
||||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
|
||||||
#review - should keep searching? |
|
||||||
#for now we assume not a zip |
|
||||||
set baseoffset $insize |
|
||||||
} else { |
|
||||||
#use the central dir size to jump back tko start of central dir |
|
||||||
#determine if diroffset is file or archive relative |
|
||||||
|
|
||||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
|
||||||
puts stdout "---> [read $inzip 4]" |
|
||||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
|
||||||
#'external preamble' easy case |
|
||||||
# - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
|
||||||
#though we are assuming zip offsets are not corrupted |
|
||||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
|
||||||
} else { |
|
||||||
#'internal preamble' hard case |
|
||||||
# - either no preamble - or offsets have been adjusted to be file relative. |
|
||||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
|
||||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
|
||||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
|
||||||
|
|
||||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
|
||||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
|
||||||
set baseoffset "unknown" |
|
||||||
chan seek $inzip $filerelative_cdir_start start |
|
||||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
|
||||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
|
||||||
#load the whole central dir into cdir |
|
||||||
|
|
||||||
#todo! loop through all cdr file headers - find highest offset? |
|
||||||
#tclZipfs.c just looks at first file header in Central Directory |
|
||||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
|
||||||
|
|
||||||
set cdirdata [read $inzip $eocd(dirsize)] |
|
||||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
|
||||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
|
||||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
|
||||||
|
|
||||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
|
||||||
chan seek $inzip $cdir(relativeoffset) |
|
||||||
#let's at least check that we landed on a local file header.. |
|
||||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
|
||||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
|
||||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
|
||||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
|
||||||
puts stdout "1st local file header sig: $lfh(signature)" |
|
||||||
if {$lfh(signature) == 67324752} { |
|
||||||
#looks like a local file header |
|
||||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
|
||||||
set baseoffset $cdir(relativeoffset) |
|
||||||
} |
|
||||||
} |
|
||||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
|
||||||
} |
|
||||||
} |
|
||||||
puts stdout "baseoffset: $baseoffset" |
|
||||||
#expect CDFH PK\1\2 |
|
||||||
#above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
|
||||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
|
||||||
|
|
||||||
if {![string is integer -strict $baseoffset]} { |
|
||||||
error "unable to determine zip baseoffset of file $infile" |
|
||||||
} |
|
||||||
|
|
||||||
if {$baseoffset < $insize} { |
|
||||||
set pout [open $outfile_preamble w] |
|
||||||
fconfigure $pout -encoding iso8859-1 -translation binary |
|
||||||
chan seek $inzip 0 start |
|
||||||
chan copy $inzip $pout -size $baseoffset |
|
||||||
close $pout |
|
||||||
if {$outfile_zip ne ""} { |
|
||||||
#todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile |
|
||||||
set zout [open $outfile_zip w] |
|
||||||
fconfigure $zout -encoding iso8859-1 -translation binary |
|
||||||
chan copy $inzip $zout |
|
||||||
close $zout |
|
||||||
} |
|
||||||
close $inzip |
|
||||||
} else { |
|
||||||
#no valid (from our perspective) eocdr found - baseoffset has been set to insize |
|
||||||
close $inzip |
|
||||||
file copy $infile $outfile_preamble |
|
||||||
if {$outfile_zip ne ""} { |
|
||||||
#touch equiv? |
|
||||||
set fd [open $outfile_zip w] |
|
||||||
close $fd |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::Addentry |
|
||||||
@cmd -name punk::zip::Addentry\ |
|
||||||
-summary\ |
|
||||||
"Add zip-entry for file at 'path'"\ |
|
||||||
-help\ |
|
||||||
"Add a single file at 'path' to open channel 'zipchan' |
|
||||||
return a central directory file record" |
|
||||||
@opts |
|
||||||
-comment -default "" -help "An optional comment specific to the added file" |
|
||||||
@values -min 3 -max 4 |
|
||||||
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" |
|
||||||
base -help "base path for entries" |
|
||||||
path -type file -help "path of file to add" |
|
||||||
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe |
|
||||||
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" |
|
||||||
} |
|
||||||
|
|
||||||
# Addentry - was Mkzipfile -- |
|
||||||
# |
|
||||||
# FIX ME: should handle the current offset for non-seekable channels |
|
||||||
# |
|
||||||
proc Addentry {args} { |
|
||||||
#*** !doctools |
|
||||||
#[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
|
||||||
#[para] Add a single file to a zip archive |
|
||||||
#[para] The zipchan channel should already be open and binary. |
|
||||||
#[para] You can provide a -comment for the file. |
|
||||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
|
||||||
|
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::Addentry] |
|
||||||
set zipchan [dict get $argd values zipchan] |
|
||||||
set base [dict get $argd values base] |
|
||||||
set path [dict get $argd values path] |
|
||||||
set zipdataoffset [dict get $argd values zipdataoffset] |
|
||||||
|
|
||||||
set comment [dict get $argd opts -comment] |
|
||||||
|
|
||||||
set fullpath [file join $base $path] |
|
||||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
|
||||||
set utfpath [encoding convertto utf-8 $path] |
|
||||||
set utfcomment [encoding convertto utf-8 $comment] |
|
||||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
|
||||||
set method 0 ;# store 0, deflate 8 |
|
||||||
set attr 0 ;# text or binary (default binary) |
|
||||||
set version 20 ;# minumum version req'd to extract |
|
||||||
set extra "" |
|
||||||
set crc 0 |
|
||||||
set size 0 |
|
||||||
set csize 0 |
|
||||||
set data "" |
|
||||||
set seekable [expr {[tell $zipchan] != -1}] |
|
||||||
if {[file isdirectory $fullpath]} { |
|
||||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
|
||||||
#set attrex 0x40000010 |
|
||||||
} elseif {[file executable $fullpath]} { |
|
||||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
|
||||||
} else { |
|
||||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
|
||||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
|
||||||
set attr 1 ;# text |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
if {[file isfile $fullpath]} { |
|
||||||
set size [file size $fullpath] |
|
||||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip |
|
||||||
set local [binary format a4sssiiiiss PK\03\04 \ |
|
||||||
$version $flags $method $mtime $crc $csize $size \ |
|
||||||
[string length $utfpath] [string length $extra]] |
|
||||||
append local $utfpath $extra |
|
||||||
puts -nonewline $zipchan $local |
|
||||||
|
|
||||||
if {[file isfile $fullpath]} { |
|
||||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
|
||||||
# streaming to avoid requiring excess memory. This helps to prevent |
|
||||||
# storing re-compressed data that may be larger than the source when |
|
||||||
# handling PNG or JPEG or nested ZIP files. |
|
||||||
if {$size < 0x00200000} { |
|
||||||
set fin [open $fullpath rb] |
|
||||||
set data [read $fin] |
|
||||||
set crc [zlib crc32 $data] |
|
||||||
set cdata [zlib deflate $data] |
|
||||||
if {[string length $cdata] < $size} { |
|
||||||
set method 8 |
|
||||||
set data $cdata |
|
||||||
} |
|
||||||
close $fin |
|
||||||
set csize [string length $data] |
|
||||||
puts -nonewline $zipchan $data |
|
||||||
} else { |
|
||||||
set method 8 |
|
||||||
set fin [open $fullpath rb] |
|
||||||
set zlib [zlib stream deflate] |
|
||||||
while {![eof $fin]} { |
|
||||||
set data [read $fin 4096] |
|
||||||
set crc [zlib crc32 $data $crc] |
|
||||||
$zlib put $data |
|
||||||
if {[string length [set zdata [$zlib get]]]} { |
|
||||||
incr csize [string length $zdata] |
|
||||||
puts -nonewline $zipchan $zdata |
|
||||||
} |
|
||||||
} |
|
||||||
close $fin |
|
||||||
$zlib finalize |
|
||||||
set zdata [$zlib get] |
|
||||||
incr csize [string length $zdata] |
|
||||||
puts -nonewline $zipchan $zdata |
|
||||||
$zlib close |
|
||||||
} |
|
||||||
|
|
||||||
if {$seekable} { |
|
||||||
# update the header if the output is seekable |
|
||||||
set local [binary format a4sssiiii PK\03\04 \ |
|
||||||
$version $flags $method $mtime $crc $csize $size] |
|
||||||
set current [tell $zipchan] |
|
||||||
seek $zipchan $channeloffset |
|
||||||
puts -nonewline $zipchan $local |
|
||||||
seek $zipchan $current |
|
||||||
} else { |
|
||||||
# Write a data descriptor record |
|
||||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
|
||||||
puts -nonewline $zipchan $ddesc |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#PK\x01\x02 Cdentral directory file header |
|
||||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
|
||||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
|
||||||
|
|
||||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
|
||||||
$version $flags $method $mtime $crc $csize $size \ |
|
||||||
[string length $utfpath] [string length $extra]\ |
|
||||||
[string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. |
|
||||||
append hdr $utfpath $extra $utfcomment |
|
||||||
return $hdr |
|
||||||
} |
|
||||||
|
|
||||||
#### REVIEW!!! |
|
||||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
|
||||||
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
|
||||||
#### |
|
||||||
|
|
||||||
|
|
||||||
punk::args::define { |
|
||||||
@id -id ::punk::zip::mkzip |
|
||||||
@cmd -name punk::zip::mkzip\ |
|
||||||
-summary\ |
|
||||||
"Create a zip archive in 'filename'."\ |
|
||||||
-help\ |
|
||||||
"Create a zip archive in 'filename'" |
|
||||||
@opts |
|
||||||
-offsettype -default "archive" -choices {archive file}\ |
|
||||||
-help\ |
|
||||||
"zip offsets stored relative to start of entire file or relative to start of zip-archive |
|
||||||
Only relevant if the created file has a script/runtime prefix." |
|
||||||
-return -default "pretty" -choices {pretty list none}\ |
|
||||||
-help\ |
|
||||||
"mkzip can return a list of the files and folders added to the archive |
|
||||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
|
||||||
to return a formatted list for the terminal |
|
||||||
" |
|
||||||
-zipkit -default 0 -type none\ |
|
||||||
-help\ |
|
||||||
"whether to add mounting script |
|
||||||
mutually exclusive with -runtime option |
|
||||||
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" |
|
||||||
-runtime -default ""\ |
|
||||||
-help\ |
|
||||||
"specify a prefix file |
|
||||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip |
|
||||||
will create a self-extracting zip archive from the subdir/ folder. |
|
||||||
Expects runtime with no existing vfs attached (review)" |
|
||||||
-comment -default ""\ |
|
||||||
-help "An optional comment for the archive" |
|
||||||
-directory -default ""\ |
|
||||||
-help "Scan for contents within this folder or current directory if not provided." |
|
||||||
-base -default ""\ |
|
||||||
-help\ |
|
||||||
"The new zip archive will be rooted in this directory if provided |
|
||||||
it must be a parent of -directory or the same path as -directory" |
|
||||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
|
||||||
-- -type none -help\ |
|
||||||
"End of options marker" |
|
||||||
|
|
||||||
@values -min 1 -max -1 |
|
||||||
filename -type file -default ""\ |
|
||||||
-help "name of zipfile to create" |
|
||||||
globs -default {*} -multiple 1\ |
|
||||||
-help\ |
|
||||||
"list of glob patterns to match. |
|
||||||
Only directories with matching files will be included in the archive." |
|
||||||
} |
|
||||||
|
|
||||||
# zip::mkzip -- |
|
||||||
# |
|
||||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
|
||||||
# |
|
||||||
proc mkzip {args} { |
|
||||||
#todo - doctools - [arg ?globs...?] syntax? |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[call [fun mkzip]\ |
|
||||||
# [opt "[option -offsettype] [arg offsettype]"]\ |
|
||||||
# [opt "[option -return] [arg returntype]"]\ |
|
||||||
# [opt "[option -zipkit] [arg 0|1]"]\ |
|
||||||
# [opt "[option -runtime] [arg preamble_filename]"]\ |
|
||||||
# [opt "[option -comment] [arg zipfilecomment]"]\ |
|
||||||
# [opt "[option -directory] [arg dir_to_zip]"]\ |
|
||||||
# [opt "[option -base] [arg archive_root]"]\ |
|
||||||
# [opt "[option -exclude] [arg globlist]"]\ |
|
||||||
# [arg zipfilename]\ |
|
||||||
# [arg ?glob...?]] |
|
||||||
#[para] Create a zip archive in 'zipfilename' |
|
||||||
#[para] If a file already exists, an error will be raised. |
|
||||||
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. |
|
||||||
|
|
||||||
set argd [punk::args::parse $args withid ::punk::zip::mkzip] |
|
||||||
set filename [dict get $argd values filename] |
|
||||||
if {$filename eq ""} { |
|
||||||
error "mkzip filename cannot be empty string" |
|
||||||
} |
|
||||||
if {[regexp {[?*]} $filename]} { |
|
||||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
|
||||||
error "mkzip filename should not contain glob characters ? *" |
|
||||||
} |
|
||||||
if {[file exists $filename]} { |
|
||||||
error "mkzip filename:$filename already exists" |
|
||||||
} |
|
||||||
dict for {k v} [dict get $argd opts] { |
|
||||||
switch -- $k { |
|
||||||
-comment { |
|
||||||
dict set argd opts $k [encoding convertto utf-8 $v] |
|
||||||
} |
|
||||||
-directory - -base { |
|
||||||
dict set argd opts $k [file normalize $v] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
array set opts [dict get $argd opts] |
|
||||||
|
|
||||||
|
|
||||||
if {$opts(-directory) ne ""} { |
|
||||||
if {$opts(-base) ne ""} { |
|
||||||
#-base and -directory have been normalized already |
|
||||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
|
||||||
error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" |
|
||||||
} |
|
||||||
set base $opts(-base) |
|
||||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
|
||||||
} else { |
|
||||||
set base $opts(-directory) |
|
||||||
set relpath "" |
|
||||||
} |
|
||||||
#will pick up intermediary folders as paths (ending with trailing slash) |
|
||||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
|
||||||
|
|
||||||
set norm_filename [file normalize $filename] |
|
||||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
|
||||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
|
||||||
#check that we aren't adding the zipfile to itself |
|
||||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
|
||||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
|
||||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
|
||||||
|
|
||||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
|
||||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
|
||||||
set self_globs_match 0 |
|
||||||
foreach g [dict get $argd values globs] { |
|
||||||
if {[string match $g [file tail $filename]]} { |
|
||||||
set self_globs_match 1 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {$self_globs_match} { |
|
||||||
#still dangerous |
|
||||||
set self_excluded 0 |
|
||||||
foreach e $opts(-exclude) { |
|
||||||
if {[string match $e [file tail $filename]]} { |
|
||||||
set self_excluded 1 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {!$self_excluded} { |
|
||||||
#still dangerous - likely to be in resultset - check each path |
|
||||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
|
||||||
set self_is_matched 0 |
|
||||||
set i 0 |
|
||||||
foreach p $paths { |
|
||||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
|
||||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
|
||||||
set self_is_matched 1 |
|
||||||
break |
|
||||||
} |
|
||||||
incr i |
|
||||||
} |
|
||||||
if {$self_is_matched} { |
|
||||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
|
||||||
set paths [lremove $paths $i] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} else { |
|
||||||
#NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! |
|
||||||
#ie - only the exact *files* matching the glob are stored. |
|
||||||
set paths [list] |
|
||||||
set dir [pwd] |
|
||||||
if {$opts(-base) ne ""} { |
|
||||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
|
||||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
|
||||||
} |
|
||||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
|
||||||
} else { |
|
||||||
set relpath "" |
|
||||||
} |
|
||||||
set base $opts(-base) |
|
||||||
|
|
||||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
|
||||||
foreach m $matches { |
|
||||||
if {$m eq $filename} { |
|
||||||
#puts stderr "--> excluding $filename" |
|
||||||
continue |
|
||||||
} |
|
||||||
set isok 1 |
|
||||||
foreach e [concat $opts(-exclude) $filename] { |
|
||||||
if {[string match $e $m]} { |
|
||||||
set isok 0 |
|
||||||
break |
|
||||||
} |
|
||||||
} |
|
||||||
if {$isok} { |
|
||||||
lappend paths [file join $relpath $m] |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
if {![llength $paths]} { |
|
||||||
return "" |
|
||||||
} |
|
||||||
|
|
||||||
set zf [open $filename wb] |
|
||||||
if {$opts(-runtime) ne ""} { |
|
||||||
#todo - strip any existing vfs - option to merge contents.. only if zip attached? |
|
||||||
set rt [open $opts(-runtime) rb] |
|
||||||
fcopy $rt $zf |
|
||||||
close $rt |
|
||||||
} elseif {$opts(-zipkit)} { |
|
||||||
#TODO - update to zipfs ? |
|
||||||
#see modpod |
|
||||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
|
||||||
append zkd "package require vfs::zip\n" |
|
||||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
|
||||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
|
||||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
|
||||||
append zkd "}\n" |
|
||||||
append zkd \x1A |
|
||||||
puts -nonewline $zf $zkd |
|
||||||
} |
|
||||||
|
|
||||||
#todo - subtract this from the endrec offset |
|
||||||
if {$opts(-offsettype) eq "archive"} { |
|
||||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 |
|
||||||
} else { |
|
||||||
set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ |
|
||||||
} |
|
||||||
|
|
||||||
set count 0 |
|
||||||
set cd "" |
|
||||||
|
|
||||||
set members [list] |
|
||||||
foreach path $paths { |
|
||||||
#puts $path |
|
||||||
lappend members $path |
|
||||||
append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath |
|
||||||
incr count |
|
||||||
} |
|
||||||
set cdoffset [tell $zf] |
|
||||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
|
||||||
$count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ |
|
||||||
[string length $opts(-comment)]] |
|
||||||
append endrec $opts(-comment) |
|
||||||
puts -nonewline $zf $cd |
|
||||||
puts -nonewline $zf $endrec |
|
||||||
close $zf |
|
||||||
|
|
||||||
set result "" |
|
||||||
switch -exact -- $opts(-return) { |
|
||||||
list { |
|
||||||
set result $members |
|
||||||
} |
|
||||||
pretty { |
|
||||||
if {[info commands showlist] ne ""} { |
|
||||||
set result [plist -channel none members] |
|
||||||
} else { |
|
||||||
set result $members |
|
||||||
} |
|
||||||
} |
|
||||||
none { |
|
||||||
set result "" |
|
||||||
} |
|
||||||
} |
|
||||||
return $result |
|
||||||
} |
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# Secondary API namespace |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
tcl::namespace::eval punk::zip::lib { |
|
||||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
||||||
tcl::namespace::path [tcl::namespace::parent] |
|
||||||
#*** !doctools |
|
||||||
#[subsection {Namespace punk::zip::lib}] |
|
||||||
#[para] Secondary functions that are part of the API |
|
||||||
#[list_begin definitions] |
|
||||||
|
|
||||||
#proc utility1 {p1 args} { |
|
||||||
# #*** !doctools |
|
||||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
||||||
# #[para]Description of utility1 |
|
||||||
# return 1 |
|
||||||
#} |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] |
|
||||||
} |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
## Ready |
|
||||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
|
||||||
variable pkg punk::zip |
|
||||||
variable version |
|
||||||
set version 0.1.1 |
|
||||||
}] |
|
||||||
return |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[manpage_end] |
|
||||||
|
|
||||||
Loading…
Reference in new issue