@ -9,7 +9,7 @@
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net>
#
# @@ Meta Begin
# Application punk::zip 0.2 .0
# Application punk::zip 0.3 .0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
@ -19,7 +19,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::zip 0 0.2 .0]
#[manpage_begin punkshell_module_punk::zip 0 0.3 .0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -66,7 +66,15 @@ package require punk::args
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::zip {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#G-126 accelerator state - see punk::zip::accelerator and punk::zip::unzip.
#The pure-Tcl reader is the always-available floor; the vendored punkzip
#binary is an optional per-call extraction accelerator.
variable accelerator_config auto ;#auto | none | <path to punkzip executable>
variable accelerator_resolved ""
variable accelerator_resolved_for "\uFFFF" ;#config value the cached resolution was computed for
variable last_unzip_engine "" ;#tcl | accelerated - which engine the last unzip used
variable last_accelerator_note "" ;#why the last unzip skipped the accelerator or fell back
#*** !doctools
#[subsection {Namespace punk::zip}]
@ -1104,6 +1112,79 @@ tcl::namespace::eval punk::zip {
return [Select_members [dict get $arc members] $globs $excludes]
}
punk::args::define {
@id -id ::punk::zip::accelerator
@cmd -name punk::zip::accelerator\
-summary\
"Query or configure the optional punkzip extraction accelerator"\
-help\
"punk::zip can hand whole-archive extraction to the vendored punkzip
tool (goal G-126; built to bin/ by 'make.tcl tool build punkzip')
when a usable binary is present - materially faster for large member
counts - while the pure-Tcl reader remains the always-available
floor and the authority on preflight refusals, member selection and
returned names.
With no argument, returns the currently resolved accelerator path,
or an empty string when none is usable. With an argument, sets the
configuration and returns the new resolution:
auto - (default) probe: env(PUNKZIP_EXE) if set, else a punkzip
executable beside [info nameofexecutable]
none - disable the accelerator (pure-Tcl always)
<path> - use the punkzip binary at an explicit path
Resolution is cached until the configuration changes. See
punk::zip::unzip for when the accelerator is actually used: calls it
cannot serve identically run pure-Tcl, and an accelerator failure
falls back to pure-Tcl silently. For diagnostics and tests,
punk::zip::last_unzip_engine records which engine the last unzip
used (tcl|accelerated) and punk::zip::last_accelerator_note records
why the accelerator was skipped or abandoned."
@values -min 0 -max 1
config -optional 1 -default "" -help\
"auto | none | path of a punkzip executable.
Empty (or omitted) queries without changing the configuration."
}
proc accelerator {args} {
set argd [punk::args::parse $args withid ::punk::zip::accelerator]
variable accelerator_config
variable accelerator_resolved
variable accelerator_resolved_for
set config [dict get $argd values config]
if {$config ne ""} {
set accelerator_config $config
}
if {$accelerator_resolved_for eq $accelerator_config} {
return $accelerator_resolved
}
set resolved ""
set candidates [list]
switch -exact -- $accelerator_config {
none {}
auto {
if {[info exists ::env(PUNKZIP_EXE)] && $::env(PUNKZIP_EXE) ne ""} {
lappend candidates $::env(PUNKZIP_EXE)
} else {
set exedir [file dirname [info nameofexecutable]]
lappend candidates [file join $exedir punkzip.exe] [file join $exedir punkzip]
}
}
default {
lappend candidates $accelerator_config
}
}
foreach c $candidates {
#file executable is unreliable for some windows setups - existence suffices there
if {[file isfile $c] && ([file executable $c] || $::tcl_platform(platform) eq "windows")} {
set resolved [file normalize $c]
break
}
}
set accelerator_resolved $resolved
set accelerator_resolved_for $accelerator_config
return $resolved
}
punk::args::define {
@id -id ::punk::zip::unzip
@cmd -name punk::zip::unzip\
@ -1124,6 +1205,15 @@ tcl::namespace::eval punk::zip {
naming the reason instead of leaving a half-populated directory. A
member whose path would escape targetdir is refused the same way.
When the punkzip accelerator is available (see punk::zip::accelerator)
and the call is one it serves identically - whole archive, default
-overwrite/-mtime/-verify, ascii member names - the member data is
written by the accelerator instead of the pure-Tcl loop, with mtimes
re-stamped to this module's convention afterwards; preflight, member
selection and the returned names always come from punk::zip's own
reader, and any accelerator failure falls back to pure Tcl silently.
punk::zip::last_unzip_engine records which engine ran.
Returns the list of member names extracted (see -return).
Examples:
@ -1178,6 +1268,11 @@ tcl::namespace::eval punk::zip {
set restoremtime [dict get $argd opts -mtime]
set verify [dict get $argd opts -verify]
variable last_unzip_engine
variable last_accelerator_note
set last_unzip_engine tcl
set last_accelerator_note ""
set arc [Open_archive $zipfile 1]
set chan [dict get $arc chan]
set extracted [list]
@ -1186,6 +1281,7 @@ tcl::namespace::eval punk::zip {
set selected [Select_members [dict get $arc members] $globs $excludes]
#preflight - nothing is written until every selected member is known good
set targets [list]
set names_ascii 1
foreach m $selected {
set reason [Member_unsupported_reason $m]
if {$reason ne ""} {
@ -1195,24 +1291,71 @@ tcl::namespace::eval punk::zip {
if {!$overwrite && !([dict get $m isdirectory]) && [file exists $target]} {
error "punk::zip::unzip: '$target' already exists and -overwrite is 0"
}
if {![string is ascii [dict get $m name]]} {
set names_ascii 0
}
lappend targets $target
}
file mkdir $targetdir
foreach m $selected target $targets {
set name [dict get $m name]
if {[dict get $m isdirectory]} {
file mkdir $target
if {$restoremtime && [dict get $m mtime]} {
lappend dirtimes $target [dict get $m mtime]
}
#G-126 accelerator: hand whole-archive member WRITING to the vendored
#punkzip binary when this call is one it serves identically. punk::zip's
#own parse above stays authoritative for preflight refusals, member
#selection and the returned names; the pure-Tcl loop below is the
#always-available floor and any accelerator failure falls back to it
#silently. Eligibility: whole archive (globs {*}, no excludes), the
#default -overwrite/-mtime/-verify semantics punkzip matches (it always
#overwrites, restores times and crc-verifies), and ascii member names
#(punkzip's name handling is wtf-8; punk::zip decodes cp437/utf-8 flags).
#punkzip stamps mtimes with its tz-free utc convention, so after a
#successful run the members are re-stamped below with this module's
#local-time convention - the two engines produce identical trees.
set accelerated 0
if {$verify && $overwrite && $restoremtime && $names_ascii
&& [llength $excludes] == 0 && [llength $globs] == 1 && [lindex $globs 0] eq "*"} {
set acc [accelerator]
if {$acc eq ""} {
set last_accelerator_note "no accelerator binary resolved (see punk::zip::accelerator)"
} elseif {[catch {exec $acc extract -d $targetdir $zipfile 2>@1} accout]} {
set last_accelerator_note "accelerator '$acc' failed - fell back to pure tcl: [string range $accout 0 300]"
} else {
file mkdir [file dirname $target]
Extract_member $chan $m $target $verify
if {$restoremtime && [dict get $m mtime]} {
catch {file mtime $target [dict get $m mtime]}
set accelerated 1
}
} else {
set last_accelerator_note "call not accelerator-eligible (selective, non-default options, or non-ascii names) - pure tcl"
}
if {$accelerated} {
set last_unzip_engine accelerated
foreach m $selected target $targets {
if {[dict get $m isdirectory]} {
if {[dict get $m mtime]} {
lappend dirtimes $target [dict get $m mtime]
}
} else {
if {[dict get $m mtime]} {
catch {file mtime $target [dict get $m mtime]}
}
}
lappend extracted [dict get $m name]
}
} else {
foreach m $selected target $targets {
set name [dict get $m name]
if {[dict get $m isdirectory]} {
file mkdir $target
if {$restoremtime && [dict get $m mtime]} {
lappend dirtimes $target [dict get $m mtime]
}
} else {
file mkdir [file dirname $target]
Extract_member $chan $m $target $verify
if {$restoremtime && [dict get $m mtime]} {
catch {file mtime $target [dict get $m mtime]}
}
}
lappend extracted $name
}
lappend extracted $name
}
} finally {
close $chan
@ -1689,7 +1832,7 @@ tcl::namespace::eval punk::zip::lib {
package provide punk::zip [tcl::namespace::eval punk::zip {
variable pkg punk::zip
variable version
set version 0.2 .0
set version 0.3 .0
}]
return
