Browse Source
punk::zip could write a zip and split an executable-prefixed one, but nothing in the tree
could READ a zip without zipfs, vfs::zip or tcllib's zipfile::decode - a system package
punkshell does not vendor, with exactly one consumer: make.tcl's zipfs-less kit
extraction. Measured at drafting: msys2's /usr/bin/tclsh8.6 has no tcllib, so a bake
driven from that host could not lift the runtime's own zip (its tcl_library) into the kit
and the artifact did not boot.
punk::zip 0.1.1 -> 0.2.0 adds three commands, stock Tcl only. archive_info reports where
the archive begins inside its host file and which offset convention it uses; members
walks the central directory and returns one dict per entry without decompressing
anything; unzip extracts all or part of it with every member's crc32 verified,
directories materialized, and the writer's 2MB whole-member-vs-streaming threshold
mirrored. All three accept a plain .zip or a zip attached to an executable or script
prefix, so "what is inside this kit / runtime / modpod" is now answerable on a runtime
without zipfs.
The offset derivation is stated once and shared: offsetbase = cdiroffset - diroffset.
Positive means an external preamble with archive-relative offsets, zero means the offsets
are file-relative (or there is no preamble); dataoffset is the split point either way.
Because every surface reads the ORIGINAL file at that base, the file-relative shape stops
being a special case - the broken split-off intermediate is never produced.
tclsh90b4_piperepl.exe is the store's one file-relative artifact: the old
split-then-tcllib path still fails on it with exactly "Bad zip file. Bad closure.", and
it now extracts all 841 members crc-verified in 735ms.
extract_preamble consumes that machinery instead of carrying its own scan, and two
defects went with the refactor: it read 28 bytes of a 30-byte local file header, and it
derived the file-relative base from the FIRST central directory record only (its own
'#todo! loop through all cdr file headers'). The shared walk takes the minimum over ALL
records and then validates that a PK\3\4 really sits there. Its five puts stdout debug
lines are gone.
Refusals are decided for every selected member before any file is opened, so an
unsupported archive cannot leave a half-populated directory: encrypted entries, zip64
size/offset fields, unknown compression methods, crc mismatch (partial file removed) and
member paths that would escape the target are each named. Store and deflate only,
mirroring the writer's own primitives.
make.tcl's zipfs-less extraction now calls punk::zip::unzip on the original runtime and no
longer creates the extracted_<runtime>.zip intermediate. No punkshell code requires
zipfile::decode any more. Two categories of hit remain and are deliberate: tcllib's own
zip/decode.tcl shipped as a LIBRARY inside some .vfs payloads, and one guarded optional
probe inside the vendored third-party ooxml1.10/ooxml.tcl.
First tests punk::zip has ever had (src/tests/modules/punk/zip/), covering the three
archive shapes from one source tree, the introspection output, the named refusals, and
the mkzip -> read round trip - the first coverage that what punkshell WRITES is readable.
Verification, all 2026-07-26. Reference host for the dependency-free claim: msys2
tclsh8.6 8.6.12, probed as zipfs / vfs::zip / zipfile::decode all ABSENT - suite driven
there harness-free, 28 passed, 2 skipped (the zipfs-gated cross-checks only), 0 failed.
30/30 under Tcl 9.0.3, 28 + 2 skipped under native 8.6. Full source-tree suite after the
change: 1142 tests, 1 failure - core/tcl exec-14.3, the documented baseline. Independent
cross-check: 868 members of tclsh905.exe extracted byte-identical against the same
archive mounted with tcl zipfs. Bake demonstration: 'bake -confirm 0 punk905' driven by
the msys2 tclsh8.6 (host=msys-x86_64, target=win32-x86_64) produced
extracted_tclsh905.exe/{tcl_library,lib} with no intermediate .zip, and the deployed kit
boots with tcl_library at //zipfs:/app/tcl_library, 95 encodings, msgcat 1.7.1, http
2.10.2 - and reads itself with the new reader.
Trap worth keeping: zlib stream inflate's 'get' returns only what the stream has already
produced, so one get per put silently truncates a large member to the first few chunks
(measured 327680 of 5048890 bytes on both 8.6.12 and 9.0.3). The inner drain loop is
load-bearing, and the >2MB streaming test exists to catch its removal.
Standing question answered and pinned: zipfs does NOT misidentify punk::zip::mkzip
directories. It keys on the trailing slash (which punk::zip::walk always emits), not the
stored permission bits, exactly as the current cli-999999.0a1.0.tm wording says - the
older, less precise wording survives only in frozen module snapshots under
src/vfs/mkzipfix.vfs and src/vfs/project.vfs. The real difference from zipfs mkzip is
that zipfs writes no directory entries at all.
The achieved flip archives the entry and the detail file, and sweeps the live tier: G-034
(the reader is its extract-rather-than-mount alternative, plus the measured finding that
make.tcl on 8.6 cannot mount its own templates modpod), G-101 (the read half of a
zipfs-less 8.6 container is solved), G-125 (the gate now has a named failure reason to
report), G-126 (the member-dict keys and fixture set its parity suite must reproduce, and
a back-pointer to G-128 whose only recorded bridge was this goal), G-128 (archive_info
answers "is this artifact safe to move the overlay of?" in one call).
One acceptance clause is reported for review rather than claimed silently: "NO
zipfile::decode requirement remains anywhere in the shipped tree" is satisfied for
punkshell's own code, with the vendored-third-party residue named above.
The archived detail file's diff is a rename plus the flip's evidence write-up.
Assisted-by: harness=claude; primary-model=claude-opus-5[1m]; api-location=anthropic.com
master
17 changed files with 1639 additions and 126 deletions
@ -1,4 +1,4 @@
|
||||
[project] |
||||
name = "punkshell" |
||||
version = "0.25.0" |
||||
version = "0.26.0" |
||||
license = "BSD-2-Clause" |
||||
|
||||
@ -1,3 +1,8 @@
|
||||
0.1.1 |
||||
0.2.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.2.0 - dependency-free reading (G-124): archive_info/members/unzip read a plain zip or an |
||||
# executable-prefixed archive under either offset convention using stock Tcl only - no |
||||
# zipfs, no vfs::zip, no tcllib. Base-offset derivation factored out of extract_preamble |
||||
# into shared Archive_read machinery which walks ALL central directory records instead |
||||
# of only the first; extract_preamble's debug output to stdout removed. |
||||
|
||||
@ -0,0 +1,562 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::zip |
||||
|
||||
#added 2026-07-26 (agent, G-124) - first tests punk::zip has ever had. Covers the |
||||
#dependency-free reader (archive_info / members / unzip) over the three archive shapes, |
||||
#the mkzip->read round trip that verifies what punk::zip WRITES is readable, and the |
||||
#named refusals for inputs the reader does not support. The whole file runs on stock Tcl |
||||
#with no zipfs, no vfs::zip and no tcllib; the zipfs-gated tests are cross-checks only. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
variable BASE [makeDirectory g124_zipreader] |
||||
|
||||
testConstraint zipfsavailable [expr {[info commands ::tcl::zipfs::mount] ne ""}] |
||||
|
||||
#the recorded file-relative runtime named in G-124's Acceptance. Not in the repo |
||||
#(bin/ build outputs are untracked) so the pin self-gates on its presence. |
||||
variable PIPEREPL [file normalize [file join [file dirname [info script]] .. .. .. .. .. .. .. bin runtime win32-x86_64 tclsh90b4_piperepl.exe]] |
||||
testConstraint piperepl_runtime [file exists $PIPEREPL] |
||||
|
||||
proc fwrite {path content} { |
||||
file mkdir [file dirname $path] |
||||
set fd [open $path wb] |
||||
puts -nonewline $fd $content |
||||
close $fd |
||||
} |
||||
proc fread {path} { |
||||
set fd [open $path rb] |
||||
set data [read $fd] |
||||
close $fd |
||||
return $data |
||||
} |
||||
|
||||
#Hand-built zip writer for fixtures punk::zip::mkzip deliberately cannot produce - |
||||
#member names that escape the target, encryption flags, unknown compression methods. |
||||
#Store method only; every field is caller-controllable. |
||||
proc rawzip {path entries {prefix ""}} { |
||||
set fd [open $path wb] |
||||
puts -nonewline $fd $prefix |
||||
set base [tell $fd] |
||||
set cd "" |
||||
set count 0 |
||||
foreach e $entries { |
||||
set name [dict get $e name] |
||||
set data [dict get $e content] |
||||
set method [expr {[dict exists $e method] ? [dict get $e method] : 0}] |
||||
set flags [expr {[dict exists $e flags] ? [dict get $e flags] : 0x800}] |
||||
set madeby [expr {[dict exists $e madeby] ? [dict get $e madeby] : 0x0017}] |
||||
set eattr [expr {[dict exists $e eattr] ? [dict get $e eattr] : 0}] |
||||
set crc [zlib crc32 $data] |
||||
set size [string length $data] |
||||
set at [expr {[tell $fd] - $base}] |
||||
puts -nonewline $fd [binary format a4sssiiiiss PK\03\04 20 $flags $method 0 $crc $size $size [string length $name] 0] |
||||
puts -nonewline $fd $name |
||||
puts -nonewline $fd $data |
||||
append cd [binary format a4ssssiiiisssssii PK\01\02 $madeby 20 $flags $method 0 $crc $size $size [string length $name] 0 0 0 0 $eattr $at] |
||||
append cd $name |
||||
incr count |
||||
} |
||||
set cdat [expr {[tell $fd] - $base}] |
||||
puts -nonewline $fd $cd |
||||
puts -nonewline $fd [binary format a4ssssiis PK\05\06 0 0 $count $count [string length $cd] $cdat 0] |
||||
close $fd |
||||
} |
||||
|
||||
#member dicts keyed by name, for assertions that name what they look at |
||||
proc bynames {members} { |
||||
set d [dict create] |
||||
foreach m $members { |
||||
dict set d [dict get $m name] $m |
||||
} |
||||
return $d |
||||
} |
||||
proc membernames {members} { |
||||
set names [list] |
||||
foreach m $members { |
||||
lappend names [dict get $m name] |
||||
} |
||||
return [lsort $names] |
||||
} |
||||
|
||||
# -- --- --- fixtures --- --- -- |
||||
# One source tree, packed three ways: a plain zip, and the same archive attached to a |
||||
# binary prefix under each of the two offset conventions. The prefix deliberately |
||||
# contains a PK\5\6 byte sequence - a plain executable can, and the EOCD scan must |
||||
# not be fooled by it. |
||||
variable SRC [file join $BASE srctree] |
||||
variable PREAMBLE [file join $BASE preamble.bin] |
||||
variable PLAIN [file join $BASE plain.zip] |
||||
variable ARCREL [file join $BASE arcrel.bin] |
||||
variable FILEREL [file join $BASE filerel.bin] |
||||
variable BIGTEXT "" |
||||
|
||||
file delete -force $SRC |
||||
file mkdir $SRC/sub/deeper |
||||
fwrite $SRC/hello.txt "hello world\n" |
||||
fwrite $SRC/sub/nested.tcl "puts nested\n" |
||||
#binary member - every byte value, so a translation bug cannot pass unnoticed |
||||
set fixturebytes "" |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
append fixturebytes [binary format c $i] |
||||
} |
||||
fwrite $SRC/binary.dat $fixturebytes |
||||
#over the 2MB threshold Addentry/Extract_member switch to streaming |
||||
for {set i 0} {$i < 40000} {incr i} { |
||||
append BIGTEXT "line $i of a member large enough to force the streaming path\n" |
||||
} |
||||
fwrite $SRC/sub/deeper/big.txt $BIGTEXT |
||||
fwrite $PREAMBLE [string repeat "PREAMBLE-BYTES-\x00\x01\x02\x50\x4b\x05\x06" 4096] |
||||
punk::zip::mkzip -return none -directory $SRC -- $PLAIN * |
||||
punk::zip::mkzip -return none -offsettype archive -runtime $PREAMBLE -directory $SRC -- $ARCREL * |
||||
punk::zip::mkzip -return none -offsettype file -runtime $PREAMBLE -directory $SRC -- $FILEREL * |
||||
|
||||
variable common { |
||||
set result [list] |
||||
} |
||||
|
||||
# -- --- --- archive_info: the three shapes --- --- -- |
||||
|
||||
test zipreader_info_plain {a bare zip reports the plain offset style and no prefix}\ |
||||
-setup $common -body { |
||||
variable PLAIN |
||||
set info [punk::zip::archive_info $PLAIN] |
||||
lappend result [dict get $info status] [dict get $info offsetstyle]\ |
||||
[dict get $info dataoffset] [dict get $info offsetbase] [dict get $info count] |
||||
}\ |
||||
-result {ok plain 0 0 6} |
||||
|
||||
test zipreader_info_archiverelative {an executable-prefixed archive with archive-relative offsets reports the prefix length}\ |
||||
-setup $common -body { |
||||
variable ARCREL ; variable PREAMBLE |
||||
set info [punk::zip::archive_info $ARCREL] |
||||
lappend result [dict get $info status] [dict get $info offsetstyle]\ |
||||
[expr {[dict get $info dataoffset] == [file size $PREAMBLE]}]\ |
||||
[expr {[dict get $info offsetbase] == [file size $PREAMBLE]}] |
||||
}\ |
||||
-result {ok archive 1 1} |
||||
|
||||
test zipreader_info_filerelative {an executable-prefixed archive with file-relative offsets reports the prefix length with a zero offset base}\ |
||||
-setup $common -body { |
||||
variable FILEREL ; variable PREAMBLE |
||||
set info [punk::zip::archive_info $FILEREL] |
||||
lappend result [dict get $info status] [dict get $info offsetstyle]\ |
||||
[expr {[dict get $info dataoffset] == [file size $PREAMBLE]}]\ |
||||
[dict get $info offsetbase] |
||||
}\ |
||||
-result {ok file 1 0} |
||||
|
||||
test zipreader_info_notanarchive {a file with no archive - including a stray PK\5\6 in its data - reports nozip rather than erroring}\ |
||||
-setup $common -body { |
||||
variable PREAMBLE |
||||
set info [punk::zip::archive_info $PREAMBLE] |
||||
lappend result [dict get $info status] [dict get $info offsetstyle]\ |
||||
[expr {[dict get $info dataoffset] == [file size $PREAMBLE]}] |
||||
}\ |
||||
-result {nozip none 1} |
||||
|
||||
# -- --- --- members: introspection without extraction --- --- -- |
||||
|
||||
test zipreader_members_names {every member of the archive is listed, directories keeping their trailing slash}\ |
||||
-setup $common -body { |
||||
variable PLAIN |
||||
membernames [punk::zip::members $PLAIN] |
||||
}\ |
||||
-result {binary.dat hello.txt sub/ sub/deeper/ sub/deeper/big.txt sub/nested.tcl} |
||||
|
||||
test zipreader_members_all_shapes_agree {the same archive listed through all three shapes yields identical member names}\ |
||||
-setup $common -body { |
||||
variable PLAIN ; variable ARCREL ; variable FILEREL |
||||
set a [membernames [punk::zip::members $PLAIN]] |
||||
set b [membernames [punk::zip::members $ARCREL]] |
||||
set c [membernames [punk::zip::members $FILEREL]] |
||||
lappend result [expr {$a eq $b}] [expr {$a eq $c}] |
||||
}\ |
||||
-result {1 1} |
||||
|
||||
test zipreader_members_directory_classification {directory entries are classified as directories and file entries as files}\ |
||||
-setup $common -body { |
||||
variable PLAIN |
||||
foreach m [punk::zip::members $PLAIN] { |
||||
lappend result [dict get $m name] [dict get $m isdirectory] |
||||
} |
||||
lsort -stride 2 $result |
||||
}\ |
||||
-result {binary.dat 0 hello.txt 0 sub/ 1 sub/deeper/ 1 sub/deeper/big.txt 0 sub/nested.tcl 0} |
||||
|
||||
test zipreader_members_stored_attributes {stored size, method, crc and mtime are reported per member}\ |
||||
-setup $common -body { |
||||
variable PLAIN ; variable SRC |
||||
set m [dict get [bynames [punk::zip::members $PLAIN]] hello.txt] |
||||
lappend result [dict get $m size] [dict get $m method] [dict get $m methodname]\ |
||||
[expr {[dict get $m crc] == [zlib crc32 [fread $SRC/hello.txt]]}]\ |
||||
[expr {abs([dict get $m mtime] - [file mtime $SRC/hello.txt]) <= 2}]\ |
||||
[dict get $m encrypted] [dict get $m hostsystem] |
||||
}\ |
||||
-result {12 0 store 1 1 0 0} |
||||
|
||||
test zipreader_members_deflated_entry {a member large enough to compress is stored deflated with a smaller compressed size}\ |
||||
-setup $common -body { |
||||
variable PLAIN ; variable BIGTEXT |
||||
set m [dict get [bynames [punk::zip::members $PLAIN]] sub/deeper/big.txt] |
||||
lappend result [dict get $m method] [dict get $m methodname]\ |
||||
[expr {[dict get $m size] == [string length $BIGTEXT]}]\ |
||||
[expr {[dict get $m csize] < [dict get $m size]}] |
||||
}\ |
||||
-result {8 deflate 1 1} |
||||
|
||||
test zipreader_members_globs {trailing globs select members by string match against the whole name - * spans path separators - and match directory entries with or without their trailing slash}\ |
||||
-setup $common -body { |
||||
variable PLAIN |
||||
lappend result [membernames [punk::zip::members $PLAIN *.txt]] |
||||
lappend result [membernames [punk::zip::members $PLAIN sub/*]] |
||||
lappend result [membernames [punk::zip::members $PLAIN sub/deeper/]] |
||||
}\ |
||||
-result {{hello.txt sub/deeper/big.txt} {sub/ sub/deeper/ sub/deeper/big.txt sub/nested.tcl} sub/deeper/} |
||||
|
||||
test zipreader_members_exclude {-exclude removes matching members from the listing}\ |
||||
-setup $common -body { |
||||
variable PLAIN |
||||
membernames [punk::zip::members -exclude {sub/*} -- $PLAIN] |
||||
}\ |
||||
-result {binary.dat hello.txt} |
||||
|
||||
test zipreader_members_does_not_extract {listing an archive decompresses nothing and writes nothing}\ |
||||
-setup $common -body { |
||||
variable PLAIN ; variable BASE |
||||
set before [lsort [glob -nocomplain -directory $BASE -tails *]] |
||||
set members [punk::zip::members $PLAIN] |
||||
set after [lsort [glob -nocomplain -directory $BASE -tails *]] |
||||
lappend result [expr {$before eq $after}] [llength $members] |
||||
}\ |
||||
-result {1 6} |
||||
|
||||
# -- --- --- unzip: extraction over the three shapes --- --- -- |
||||
|
||||
proc extract_and_compare {label archive} { |
||||
variable BASE ; variable SRC |
||||
set out [file join $BASE out_$label] |
||||
file delete -force $out |
||||
set extracted [punk::zip::unzip $archive $out] |
||||
set problems [list] |
||||
foreach m [punk::zip::members $archive] { |
||||
set name [dict get $m name] |
||||
if {[dict get $m isdirectory]} { |
||||
if {![file isdirectory [file join $out [string trimright $name /]]]} { |
||||
lappend problems "directory-entry-not-materialized:$name" |
||||
} |
||||
continue |
||||
} |
||||
if {[fread [file join $SRC $name]] ne [fread [file join $out $name]]} { |
||||
lappend problems "content-differs:$name" |
||||
} |
||||
} |
||||
return [list [llength $extracted] $problems] |
||||
} |
||||
|
||||
test zipreader_unzip_plain {a bare zip extracts every member byte-identically with directories materialized}\ |
||||
-setup $common -body { |
||||
variable PLAIN |
||||
extract_and_compare plain $PLAIN |
||||
}\ |
||||
-result {6 {}} |
||||
|
||||
test zipreader_unzip_archiverelative {an archive-relative prefixed archive extracts every member byte-identically}\ |
||||
-setup $common -body { |
||||
variable ARCREL |
||||
extract_and_compare arcrel $ARCREL |
||||
}\ |
||||
-result {6 {}} |
||||
|
||||
test zipreader_unzip_filerelative {a file-relative prefixed archive extracts every member byte-identically - the shape the split-then-decode path cannot read}\ |
||||
-setup $common -body { |
||||
variable FILEREL |
||||
extract_and_compare filerel $FILEREL |
||||
}\ |
||||
-result {6 {}} |
||||
|
||||
test zipreader_unzip_streaming_member {a member over the 2MB streaming threshold extracts complete and byte-identical}\ |
||||
-setup $common -body { |
||||
variable BASE ; variable BIGTEXT ; variable PLAIN |
||||
set out [file join $BASE out_streaming] |
||||
file delete -force $out |
||||
punk::zip::unzip -return none -- $PLAIN $out sub/deeper/big.txt |
||||
set path [file join $out sub deeper big.txt] |
||||
lappend result [expr {[string length $BIGTEXT] >= 0x00200000}]\ |
||||
[expr {[file size $path] == [string length $BIGTEXT]}]\ |
||||
[expr {[fread $path] eq $BIGTEXT}] |
||||
}\ |
||||
-result {1 1 1} |
||||
|
||||
test zipreader_unzip_partial {a glob extracts just the matching members, creating the intermediate directories they need}\ |
||||
-setup $common -body { |
||||
variable BASE ; variable ARCREL |
||||
set out [file join $BASE out_partial] |
||||
file delete -force $out |
||||
lappend result [punk::zip::unzip $ARCREL $out sub/nested.tcl] |
||||
lappend result [file isdirectory [file join $out sub]] |
||||
lappend result [file exists [file join $out hello.txt]] |
||||
}\ |
||||
-result {sub/nested.tcl 1 0} |
||||
|
||||
test zipreader_unzip_return_modes {-return none suppresses the extracted-member list}\ |
||||
-setup $common -body { |
||||
variable BASE ; variable PLAIN |
||||
set out [file join $BASE out_returnmode] |
||||
file delete -force $out |
||||
lappend result [punk::zip::unzip -return none -- $PLAIN $out] |
||||
lappend result [file exists [file join $out hello.txt]] |
||||
}\ |
||||
-result {{} 1} |
||||
|
||||
test zipreader_unzip_overwrite_refusal {-overwrite 0 refuses before writing anything when a target exists}\ |
||||
-setup $common -body { |
||||
variable BASE ; variable PLAIN |
||||
set out [file join $BASE out_overwrite] |
||||
file delete -force $out |
||||
punk::zip::unzip -return none -- $PLAIN $out |
||||
file delete -force [file join $out sub] |
||||
try { |
||||
punk::zip::unzip -overwrite 0 -- $PLAIN $out |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*already exists and -overwrite is 0*" $msg] |
||||
} |
||||
#the refusal happened in preflight, so the deleted subtree was not re-created |
||||
lappend result [file exists [file join $out sub]] |
||||
}\ |
||||
-result {1 0} |
||||
|
||||
test zipreader_unzip_crc_verified {a corrupted member is refused on crc and its partial file removed}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set archive [file join $BASE corrupt.zip] |
||||
rawzip $archive [list [dict create name payload.bin content "0123456789"]] |
||||
#flip a byte of the stored member data, leaving the recorded crc alone |
||||
set data [fread $archive] |
||||
set at [string first "0123456789" $data] |
||||
set data [string replace $data $at $at "X"] |
||||
fwrite $archive $data |
||||
set out [file join $BASE out_corrupt] |
||||
file delete -force $out |
||||
try { |
||||
punk::zip::unzip $archive $out |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*crc mismatch for member 'payload.bin'*" $msg] |
||||
} |
||||
lappend result [file exists [file join $out payload.bin]] |
||||
}\ |
||||
-result {1 0} |
||||
|
||||
# -- --- --- refusals: inputs the reader does not support --- --- -- |
||||
|
||||
test zipreader_refuses_encrypted {an encrypted member is listed but not extracted, naming encryption as the reason}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set archive [file join $BASE encrypted.zip] |
||||
rawzip $archive [list [dict create name secret.txt content ciphertext flags 0x801]] |
||||
lappend result [dict get [lindex [punk::zip::members $archive] 0] encrypted] |
||||
try { |
||||
punk::zip::unzip $archive [file join $BASE out_encrypted] |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*is encrypted*" $msg] |
||||
} |
||||
lappend result [file exists [file join $BASE out_encrypted]] |
||||
}\ |
||||
-result {1 1 0} |
||||
|
||||
test zipreader_refuses_unknown_method {a member compressed with a method punk::zip cannot read is refused by name}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set archive [file join $BASE lzma.zip] |
||||
rawzip $archive [list [dict create name payload.bin content data method 14]] |
||||
lappend result [dict get [lindex [punk::zip::members $archive] 0] methodname] |
||||
try { |
||||
punk::zip::unzip $archive [file join $BASE out_lzma] |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*compression method 14 (lzma)*" $msg] |
||||
} |
||||
lappend result [file exists [file join $BASE out_lzma]] |
||||
}\ |
||||
-result {lzma 1 0} |
||||
|
||||
test zipreader_refuses_zip64 {an archive whose end record defers to zip64 fields is refused by name}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set archive [file join $BASE zip64.zip] |
||||
rawzip $archive [list [dict create name payload.bin content data]] |
||||
#saturate the recorded central-directory offset - the real value would live in |
||||
#a zip64 record punk::zip does not read |
||||
set data [fread $archive] |
||||
set data [string replace $data end-5 end-2 [binary format i 0xFFFFFFFF]] |
||||
fwrite $archive $data |
||||
lappend result [dict get [punk::zip::archive_info $archive] status] |
||||
lappend result [string match "*zip64*" [dict get [punk::zip::archive_info $archive] reason]] |
||||
try { |
||||
punk::zip::members $archive |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*zip64*" $msg] |
||||
} |
||||
}\ |
||||
-result {unsupported 1 1} |
||||
|
||||
test zipreader_refuses_path_escape {a member whose path would escape the target directory is listed but refused on extraction}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set archive [file join $BASE escape.zip] |
||||
rawzip $archive [list [dict create name ../escape.txt content escaped]] |
||||
lappend result [dict get [lindex [punk::zip::members $archive] 0] name] |
||||
try { |
||||
punk::zip::unzip $archive [file join $BASE out_escape] |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*parent-directory segment*" $msg] |
||||
} |
||||
lappend result [file exists [file join $BASE escape.txt]] |
||||
}\ |
||||
-result {../escape.txt 1 0} |
||||
|
||||
test zipreader_refuses_nonarchive {listing a file that is not an archive names the reason}\ |
||||
-setup $common -body { |
||||
variable PREAMBLE |
||||
try { |
||||
punk::zip::members $PREAMBLE |
||||
lappend result no-error |
||||
} on error {msg} { |
||||
lappend result [string match "*is not a zip archive*" $msg] |
||||
} |
||||
}\ |
||||
-result {1} |
||||
|
||||
# -- --- --- mkzip -> read round trip --- --- -- |
||||
|
||||
test zipreader_roundtrip_mkzip {what punk::zip::mkzip writes, punk::zip reads back: names, content, classification and stored attributes}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set src [file join $BASE rtsrc] |
||||
file delete -force $src |
||||
file mkdir $src/branch |
||||
fwrite $src/leaf.txt "leaf content\n" |
||||
fwrite $src/branch/twig.txt "twig content\n" |
||||
set archive [file join $BASE roundtrip.zip] |
||||
file delete -force $archive |
||||
punk::zip::mkzip -return none -directory $src -- $archive * |
||||
set members [bynames [punk::zip::members $archive]] |
||||
lappend result [lsort [dict keys $members]] |
||||
#mkzip stores unix-style permission bits in the high word of the external |
||||
#attributes and the FAT attribute bits in the low byte, with the host system |
||||
#byte of version-made-by left at 0 (MS-DOS/FAT) |
||||
lappend result [format 0x%08x [dict get $members branch/ attributes]] |
||||
lappend result [format 0x%08x [dict get $members leaf.txt attributes]] |
||||
lappend result [dict get $members branch/ hostsystem] |
||||
set out [file join $BASE out_roundtrip] |
||||
file delete -force $out |
||||
punk::zip::unzip -return none -- $archive $out |
||||
lappend result [file isdirectory [file join $out branch]] |
||||
lappend result [fread [file join $out leaf.txt]] |
||||
lappend result [fread [file join $out branch/twig.txt]] |
||||
}\ |
||||
-result [list {branch/ branch/twig.txt leaf.txt} 0x41ff0010 0x81b60020 0 1 "leaf content\n" "twig content\n"] |
||||
|
||||
test zipreader_roundtrip_empty_and_binary_members {zero-length and full-byte-range members round trip byte-identically}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set src [file join $BASE edgesrc] |
||||
file delete -force $src |
||||
file mkdir $src |
||||
fwrite $src/empty.bin "" |
||||
set bytes "" |
||||
for {set i 0} {$i < 256} {incr i} { |
||||
append bytes [binary format c $i] |
||||
} |
||||
fwrite $src/allbytes.bin $bytes |
||||
set archive [file join $BASE edges.zip] |
||||
file delete -force $archive |
||||
punk::zip::mkzip -return none -directory $src -- $archive * |
||||
set out [file join $BASE out_edges] |
||||
file delete -force $out |
||||
punk::zip::unzip -return none -- $archive $out |
||||
lappend result [file size [file join $out empty.bin]] |
||||
lappend result [expr {[fread [file join $out allbytes.bin]] eq $bytes}] |
||||
}\ |
||||
-result {0 1} |
||||
|
||||
# -- --- --- zipfs cross-checks (informational, gated) --- --- -- |
||||
|
||||
#The standing question recorded in punk::mix::cli and src/vfs/mkzipfix.vfs was whether |
||||
#the unix-style permissions punk::zip::mkzip stores make zipfs misidentify directories |
||||
#as files. Measured 2026-07-26 on Tcl 9.0.3: it does not - zipfs reports them as |
||||
#directories. See goals/G-124 for the full finding. |
||||
test zipreader_zipfs_sees_mkzip_directories {zipfs mounts a punk::zip::mkzip archive and sees its directory entries as directories}\ |
||||
-constraints {zipfsavailable} -setup $common -body { |
||||
variable BASE |
||||
set src [file join $BASE zfssrc] |
||||
file delete -force $src |
||||
file mkdir $src/branch |
||||
fwrite $src/branch/twig.txt "twig\n" |
||||
fwrite $src/leaf.txt "leaf\n" |
||||
set archive [file join $BASE zipfsq.zip] |
||||
file delete -force $archive |
||||
punk::zip::mkzip -return none -directory $src -- $archive * |
||||
set mount rtq[clock clicks] |
||||
tcl::zipfs::mount $archive $mount |
||||
try { |
||||
lappend result [file isdirectory //zipfs:/$mount/branch] |
||||
lappend result [file isfile //zipfs:/$mount/branch/twig.txt] |
||||
lappend result [file isfile //zipfs:/$mount/leaf.txt] |
||||
lappend result [lsort [glob -nocomplain -tails -directory //zipfs:/$mount *]] |
||||
} finally { |
||||
catch {tcl::zipfs::unmount $mount} |
||||
} |
||||
}\ |
||||
-result {1 1 1 {branch leaf.txt}} |
||||
|
||||
test zipreader_matches_zipfs_contents {punk::zip and a zipfs mount of the same archive yield identical member content}\ |
||||
-constraints {zipfsavailable} -setup $common -body { |
||||
variable BASE ; variable PLAIN |
||||
set out [file join $BASE out_zipfscompare] |
||||
file delete -force $out |
||||
punk::zip::unzip -return none -- $PLAIN $out |
||||
set mount rtc[clock clicks] |
||||
tcl::zipfs::mount $PLAIN $mount |
||||
try { |
||||
foreach m [punk::zip::members $PLAIN] { |
||||
if {[dict get $m isdirectory]} { |
||||
continue |
||||
} |
||||
set name [dict get $m name] |
||||
if {[fread //zipfs:/$mount/$name] ne [fread [file join $out $name]]} { |
||||
lappend result "differs:$name" |
||||
} |
||||
} |
||||
} finally { |
||||
catch {tcl::zipfs::unmount $mount} |
||||
} |
||||
set result |
||||
}\ |
||||
-result {} |
||||
|
||||
# -- --- --- the recorded real-world file-relative runtime --- --- -- |
||||
|
||||
test zipreader_piperepl_runtime {the recorded file-relative runtime reads and extracts its own tcl_library}\ |
||||
-constraints {piperepl_runtime} -setup $common -body { |
||||
variable BASE ; variable PIPEREPL |
||||
set info [punk::zip::archive_info $PIPEREPL] |
||||
lappend result [dict get $info status] [dict get $info offsetstyle] |
||||
lappend result [expr {[dict get $info count] > 100}] |
||||
set out [file join $BASE out_piperepl] |
||||
file delete -force $out |
||||
punk::zip::unzip -return none -- $PIPEREPL $out tcl_library/* |
||||
lappend result [file exists [file join $out tcl_library init.tcl]] |
||||
lappend result [expr {[file size [file join $out tcl_library init.tcl]] > 1000}] |
||||
}\ |
||||
-result {ok file 1 1 1} |
||||
|
||||
cleanupTests |
||||
} |
||||
Loading…
Reference in new issue