25 changed files with 6333 additions and 1412 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,632 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/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.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::zip 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::zip] |
||||||
|
#[keywords module] |
||||||
|
#[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] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::zip::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip}] |
||||||
|
#[para] Core API functions for punk::zip |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc Path_a_atorbelow_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||||
|
} |
||||||
|
proc Path_a_at_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||||
|
} |
||||||
|
|
||||||
|
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||||
|
if {$prefix eq ""} { |
||||||
|
return $path |
||||||
|
} |
||||||
|
set pathparts [file split $path] |
||||||
|
set prefixparts [file split $prefix] |
||||||
|
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
return [file join \ |
||||||
|
{*}[lrange \ |
||||||
|
$pathparts \ |
||||||
|
[llength $prefixparts] \ |
||||||
|
end]] |
||||||
|
} |
||||||
|
|
||||||
|
#StripPath - borrowed from tcllib fileutil |
||||||
|
# ::fileutil::stripPath -- |
||||||
|
# |
||||||
|
# If the specified path references/is a path in prefix (or prefix itself) it |
||||||
|
# is made relative to prefix. Otherwise it is left unchanged. |
||||||
|
# In the case of it being prefix itself the result is the string '.'. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# prefix prefix to strip from the path. |
||||||
|
# path path to modify |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# path The (possibly) modified path. |
||||||
|
|
||||||
|
if {[string equal $::tcl_platform(platform) windows]} { |
||||||
|
# Windows. While paths are stored with letter-case preserved al |
||||||
|
# comparisons have to be done case-insensitive. For reference see |
||||||
|
# SF Tcllib Bug 2499641. |
||||||
|
|
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal -nocase $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match -nocase "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc Timet_to_dos {time_t} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Timet_to_dos] [arg time_t]] |
||||||
|
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||||
|
#[example { |
||||||
|
# DOS timestamps are 32 bits split into bit regions as follows: |
||||||
|
# 24 16 8 0 |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
#}] |
||||||
|
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||||
|
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||||
|
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||||
|
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||||
|
} |
||||||
|
|
||||||
|
proc walk {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun walk] [arg ?options?] [arg base]] |
||||||
|
#[para] Walk a directory tree rooted at base |
||||||
|
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||||
|
#[para] e.g |
||||||
|
#[example { |
||||||
|
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||||
|
#}] |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::walk |
||||||
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||||
|
-subpath -default "" |
||||||
|
*values -min 1 -max -1 |
||||||
|
base |
||||||
|
fileglobs -default {*} -multiple 1 |
||||||
|
} $args] |
||||||
|
set base [dict get $argd values base] |
||||||
|
set fileglobs [dict get $argd values fileglobs] |
||||||
|
set subpath [dict get $argd opts -subpath] |
||||||
|
set excludes [dict get $argd opts -excludes] |
||||||
|
|
||||||
|
|
||||||
|
set imatch [list] |
||||||
|
foreach fg $fileglobs { |
||||||
|
lappend imatch [file join $subpath $fg] |
||||||
|
} |
||||||
|
|
||||||
|
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} |
||||||
|
} |
||||||
|
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||||
|
set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||||
|
if {[llength $subdir]>0} { |
||||||
|
set result [concat $result $dir $subdir] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# Mkzipfile -- |
||||||
|
# |
||||||
|
# FIX ME: should handle the current offset for non-seekable channels |
||||||
|
# |
||||||
|
proc Mkzipfile {zipchan base path {comment ""}} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Mkzipfile] [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 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 offset [tell $zipchan] |
||||||
|
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 $offset |
||||||
|
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 $offset] |
||||||
|
append hdr $utfpath $extra $utfcomment |
||||||
|
return $hdr |
||||||
|
} |
||||||
|
# zip::mkzip -- |
||||||
|
# |
||||||
|
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||||
|
# |
||||||
|
proc mkzip {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||||
|
#[para] Create a zip archive in 'filename' |
||||||
|
#[para] If a file already exists, an error will be raised. |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||||
|
*opts |
||||||
|
-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 "" |
||||||
|
-runtime -default "" -help "specify a prefix file |
||||||
|
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||||
|
will create a self-extracting zip archive from the subdir/ folder. |
||||||
|
" |
||||||
|
-comment -default "" -help "An optional comment for the archive" |
||||||
|
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||||
|
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||||
|
it must be a parent of -directory" |
||||||
|
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||||
|
*values -min 1 -max -1 |
||||||
|
filename -default "" -help "name of zipfile to create" |
||||||
|
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||||
|
Only directories with matching files will be included in the archive" |
||||||
|
} $args] |
||||||
|
|
||||||
|
set filename [dict get $argd values filename] |
||||||
|
if {$filename eq ""} { |
||||||
|
error "mkzip filename cannot be empty string" |
||||||
|
} |
||||||
|
if {[regexp {[?*]} $filename]} { |
||||||
|
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||||
|
error "mkzip filename should not contain glob characters ? *" |
||||||
|
} |
||||||
|
if {[file exists $filename]} { |
||||||
|
error "mkzip filename:$filename already exists" |
||||||
|
} |
||||||
|
dict for {k v} [dict get $argd opts] { |
||||||
|
switch -- $k { |
||||||
|
-comment { |
||||||
|
dict set argd opts $k [encoding convertto utf-8 $v] |
||||||
|
} |
||||||
|
-directory - -base { |
||||||
|
dict set argd opts $k [file normalize $v] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
array set opts [dict get $argd opts] |
||||||
|
|
||||||
|
|
||||||
|
if {$opts(-directory) ne ""} { |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
#-base and -directory have been normalized already |
||||||
|
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||||
|
} else { |
||||||
|
set base $opts(-directory) |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
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 { |
||||||
|
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 ""} { |
||||||
|
set rt [open $opts(-runtime) rb] |
||||||
|
fcopy $rt $zf |
||||||
|
close $rt |
||||||
|
} elseif {$opts(-zipkit)} { |
||||||
|
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 |
||||||
|
} |
||||||
|
set count 0 |
||||||
|
set cd "" |
||||||
|
|
||||||
|
set members [list] |
||||||
|
foreach path $paths { |
||||||
|
#puts $path |
||||||
|
lappend members $path |
||||||
|
append cd [Mkzipfile $zf $base $path] ;#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] $cdoffset\ |
||||||
|
[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 ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::zip::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||||
|
variable pkg punk::zip |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,632 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/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.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::zip 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::zip] |
||||||
|
#[keywords module] |
||||||
|
#[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] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::zip::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip}] |
||||||
|
#[para] Core API functions for punk::zip |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc Path_a_atorbelow_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||||
|
} |
||||||
|
proc Path_a_at_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||||
|
} |
||||||
|
|
||||||
|
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||||
|
if {$prefix eq ""} { |
||||||
|
return $path |
||||||
|
} |
||||||
|
set pathparts [file split $path] |
||||||
|
set prefixparts [file split $prefix] |
||||||
|
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
return [file join \ |
||||||
|
{*}[lrange \ |
||||||
|
$pathparts \ |
||||||
|
[llength $prefixparts] \ |
||||||
|
end]] |
||||||
|
} |
||||||
|
|
||||||
|
#StripPath - borrowed from tcllib fileutil |
||||||
|
# ::fileutil::stripPath -- |
||||||
|
# |
||||||
|
# If the specified path references/is a path in prefix (or prefix itself) it |
||||||
|
# is made relative to prefix. Otherwise it is left unchanged. |
||||||
|
# In the case of it being prefix itself the result is the string '.'. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# prefix prefix to strip from the path. |
||||||
|
# path path to modify |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# path The (possibly) modified path. |
||||||
|
|
||||||
|
if {[string equal $::tcl_platform(platform) windows]} { |
||||||
|
# Windows. While paths are stored with letter-case preserved al |
||||||
|
# comparisons have to be done case-insensitive. For reference see |
||||||
|
# SF Tcllib Bug 2499641. |
||||||
|
|
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal -nocase $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match -nocase "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc Timet_to_dos {time_t} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Timet_to_dos] [arg time_t]] |
||||||
|
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||||
|
#[example { |
||||||
|
# DOS timestamps are 32 bits split into bit regions as follows: |
||||||
|
# 24 16 8 0 |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
#}] |
||||||
|
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||||
|
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||||
|
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||||
|
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||||
|
} |
||||||
|
|
||||||
|
proc walk {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun walk] [arg ?options?] [arg base]] |
||||||
|
#[para] Walk a directory tree rooted at base |
||||||
|
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||||
|
#[para] e.g |
||||||
|
#[example { |
||||||
|
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||||
|
#}] |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::walk |
||||||
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||||
|
-subpath -default "" |
||||||
|
*values -min 1 -max -1 |
||||||
|
base |
||||||
|
fileglobs -default {*} -multiple 1 |
||||||
|
} $args] |
||||||
|
set base [dict get $argd values base] |
||||||
|
set fileglobs [dict get $argd values fileglobs] |
||||||
|
set subpath [dict get $argd opts -subpath] |
||||||
|
set excludes [dict get $argd opts -excludes] |
||||||
|
|
||||||
|
|
||||||
|
set imatch [list] |
||||||
|
foreach fg $fileglobs { |
||||||
|
lappend imatch [file join $subpath $fg] |
||||||
|
} |
||||||
|
|
||||||
|
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} |
||||||
|
} |
||||||
|
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||||
|
set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||||
|
if {[llength $subdir]>0} { |
||||||
|
set result [concat $result $dir $subdir] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# Mkzipfile -- |
||||||
|
# |
||||||
|
# FIX ME: should handle the current offset for non-seekable channels |
||||||
|
# |
||||||
|
proc Mkzipfile {zipchan base path {comment ""}} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Mkzipfile] [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 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 offset [tell $zipchan] |
||||||
|
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 $offset |
||||||
|
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 $offset] |
||||||
|
append hdr $utfpath $extra $utfcomment |
||||||
|
return $hdr |
||||||
|
} |
||||||
|
# zip::mkzip -- |
||||||
|
# |
||||||
|
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||||
|
# |
||||||
|
proc mkzip {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||||
|
#[para] Create a zip archive in 'filename' |
||||||
|
#[para] If a file already exists, an error will be raised. |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||||
|
*opts |
||||||
|
-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 "" |
||||||
|
-runtime -default "" -help "specify a prefix file |
||||||
|
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||||
|
will create a self-extracting zip archive from the subdir/ folder. |
||||||
|
" |
||||||
|
-comment -default "" -help "An optional comment for the archive" |
||||||
|
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||||
|
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||||
|
it must be a parent of -directory" |
||||||
|
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||||
|
*values -min 1 -max -1 |
||||||
|
filename -default "" -help "name of zipfile to create" |
||||||
|
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||||
|
Only directories with matching files will be included in the archive" |
||||||
|
} $args] |
||||||
|
|
||||||
|
set filename [dict get $argd values filename] |
||||||
|
if {$filename eq ""} { |
||||||
|
error "mkzip filename cannot be empty string" |
||||||
|
} |
||||||
|
if {[regexp {[?*]} $filename]} { |
||||||
|
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||||
|
error "mkzip filename should not contain glob characters ? *" |
||||||
|
} |
||||||
|
if {[file exists $filename]} { |
||||||
|
error "mkzip filename:$filename already exists" |
||||||
|
} |
||||||
|
dict for {k v} [dict get $argd opts] { |
||||||
|
switch -- $k { |
||||||
|
-comment { |
||||||
|
dict set argd opts $k [encoding convertto utf-8 $v] |
||||||
|
} |
||||||
|
-directory - -base { |
||||||
|
dict set argd opts $k [file normalize $v] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
array set opts [dict get $argd opts] |
||||||
|
|
||||||
|
|
||||||
|
if {$opts(-directory) ne ""} { |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
#-base and -directory have been normalized already |
||||||
|
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||||
|
} else { |
||||||
|
set base $opts(-directory) |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
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 { |
||||||
|
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 ""} { |
||||||
|
set rt [open $opts(-runtime) rb] |
||||||
|
fcopy $rt $zf |
||||||
|
close $rt |
||||||
|
} elseif {$opts(-zipkit)} { |
||||||
|
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 |
||||||
|
} |
||||||
|
set count 0 |
||||||
|
set cd "" |
||||||
|
|
||||||
|
set members [list] |
||||||
|
foreach path $paths { |
||||||
|
#puts $path |
||||||
|
lappend members $path |
||||||
|
append cd [Mkzipfile $zf $base $path] ;#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] $cdoffset\ |
||||||
|
[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 ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::zip::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||||
|
variable pkg punk::zip |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,632 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/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.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::zip 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::zip] |
||||||
|
#[keywords module] |
||||||
|
#[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] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::zip::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip}] |
||||||
|
#[para] Core API functions for punk::zip |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc Path_a_atorbelow_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||||
|
} |
||||||
|
proc Path_a_at_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||||
|
} |
||||||
|
|
||||||
|
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||||
|
if {$prefix eq ""} { |
||||||
|
return $path |
||||||
|
} |
||||||
|
set pathparts [file split $path] |
||||||
|
set prefixparts [file split $prefix] |
||||||
|
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
return [file join \ |
||||||
|
{*}[lrange \ |
||||||
|
$pathparts \ |
||||||
|
[llength $prefixparts] \ |
||||||
|
end]] |
||||||
|
} |
||||||
|
|
||||||
|
#StripPath - borrowed from tcllib fileutil |
||||||
|
# ::fileutil::stripPath -- |
||||||
|
# |
||||||
|
# If the specified path references/is a path in prefix (or prefix itself) it |
||||||
|
# is made relative to prefix. Otherwise it is left unchanged. |
||||||
|
# In the case of it being prefix itself the result is the string '.'. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# prefix prefix to strip from the path. |
||||||
|
# path path to modify |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# path The (possibly) modified path. |
||||||
|
|
||||||
|
if {[string equal $::tcl_platform(platform) windows]} { |
||||||
|
# Windows. While paths are stored with letter-case preserved al |
||||||
|
# comparisons have to be done case-insensitive. For reference see |
||||||
|
# SF Tcllib Bug 2499641. |
||||||
|
|
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal -nocase $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match -nocase "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc Timet_to_dos {time_t} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Timet_to_dos] [arg time_t]] |
||||||
|
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||||
|
#[example { |
||||||
|
# DOS timestamps are 32 bits split into bit regions as follows: |
||||||
|
# 24 16 8 0 |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
#}] |
||||||
|
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||||
|
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||||
|
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||||
|
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||||
|
} |
||||||
|
|
||||||
|
proc walk {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun walk] [arg ?options?] [arg base]] |
||||||
|
#[para] Walk a directory tree rooted at base |
||||||
|
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||||
|
#[para] e.g |
||||||
|
#[example { |
||||||
|
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||||
|
#}] |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::walk |
||||||
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||||
|
-subpath -default "" |
||||||
|
*values -min 1 -max -1 |
||||||
|
base |
||||||
|
fileglobs -default {*} -multiple 1 |
||||||
|
} $args] |
||||||
|
set base [dict get $argd values base] |
||||||
|
set fileglobs [dict get $argd values fileglobs] |
||||||
|
set subpath [dict get $argd opts -subpath] |
||||||
|
set excludes [dict get $argd opts -excludes] |
||||||
|
|
||||||
|
|
||||||
|
set imatch [list] |
||||||
|
foreach fg $fileglobs { |
||||||
|
lappend imatch [file join $subpath $fg] |
||||||
|
} |
||||||
|
|
||||||
|
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} |
||||||
|
} |
||||||
|
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||||
|
set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||||
|
if {[llength $subdir]>0} { |
||||||
|
set result [concat $result $dir $subdir] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# Mkzipfile -- |
||||||
|
# |
||||||
|
# FIX ME: should handle the current offset for non-seekable channels |
||||||
|
# |
||||||
|
proc Mkzipfile {zipchan base path {comment ""}} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Mkzipfile] [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 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 offset [tell $zipchan] |
||||||
|
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 $offset |
||||||
|
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 $offset] |
||||||
|
append hdr $utfpath $extra $utfcomment |
||||||
|
return $hdr |
||||||
|
} |
||||||
|
# zip::mkzip -- |
||||||
|
# |
||||||
|
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||||
|
# |
||||||
|
proc mkzip {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||||
|
#[para] Create a zip archive in 'filename' |
||||||
|
#[para] If a file already exists, an error will be raised. |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||||
|
*opts |
||||||
|
-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 "" |
||||||
|
-runtime -default "" -help "specify a prefix file |
||||||
|
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||||
|
will create a self-extracting zip archive from the subdir/ folder. |
||||||
|
" |
||||||
|
-comment -default "" -help "An optional comment for the archive" |
||||||
|
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||||
|
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||||
|
it must be a parent of -directory" |
||||||
|
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||||
|
*values -min 1 -max -1 |
||||||
|
filename -default "" -help "name of zipfile to create" |
||||||
|
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||||
|
Only directories with matching files will be included in the archive" |
||||||
|
} $args] |
||||||
|
|
||||||
|
set filename [dict get $argd values filename] |
||||||
|
if {$filename eq ""} { |
||||||
|
error "mkzip filename cannot be empty string" |
||||||
|
} |
||||||
|
if {[regexp {[?*]} $filename]} { |
||||||
|
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||||
|
error "mkzip filename should not contain glob characters ? *" |
||||||
|
} |
||||||
|
if {[file exists $filename]} { |
||||||
|
error "mkzip filename:$filename already exists" |
||||||
|
} |
||||||
|
dict for {k v} [dict get $argd opts] { |
||||||
|
switch -- $k { |
||||||
|
-comment { |
||||||
|
dict set argd opts $k [encoding convertto utf-8 $v] |
||||||
|
} |
||||||
|
-directory - -base { |
||||||
|
dict set argd opts $k [file normalize $v] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
array set opts [dict get $argd opts] |
||||||
|
|
||||||
|
|
||||||
|
if {$opts(-directory) ne ""} { |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
#-base and -directory have been normalized already |
||||||
|
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||||
|
} else { |
||||||
|
set base $opts(-directory) |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
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 { |
||||||
|
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 ""} { |
||||||
|
set rt [open $opts(-runtime) rb] |
||||||
|
fcopy $rt $zf |
||||||
|
close $rt |
||||||
|
} elseif {$opts(-zipkit)} { |
||||||
|
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 |
||||||
|
} |
||||||
|
set count 0 |
||||||
|
set cd "" |
||||||
|
|
||||||
|
set members [list] |
||||||
|
foreach path $paths { |
||||||
|
#puts $path |
||||||
|
lappend members $path |
||||||
|
append cd [Mkzipfile $zf $base $path] ;#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] $cdoffset\ |
||||||
|
[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 ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::zip::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||||
|
variable pkg punk::zip |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -1,14 +0,0 @@ |
|||||||
Copyright (c) 2023 Robin Stuart |
|
||||||
All rights reserved. |
|
||||||
|
|
||||||
Redistribution and use in source and binary forms are permitted |
|
||||||
provided that the above copyright notice and this paragraph are |
|
||||||
duplicated in all such forms and that any documentation, |
|
||||||
advertising materials, and other materials related to such |
|
||||||
distribution and use acknowledge that the software was developed |
|
||||||
by the <organization>. The name of the |
|
||||||
<organization> may not be used to endorse or promote products derived |
|
||||||
from this software without specific prior written permission. |
|
||||||
THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR |
|
||||||
IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED |
|
||||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. |
|
||||||
@ -1,2 +0,0 @@ |
|||||||
package ifneeded zint 2.13.0\ |
|
||||||
[list load [file join $dir zint[info sharedlibextension]]] |
|
||||||
@ -1,27 +0,0 @@ |
|||||||
zint tcl binding readme |
|
||||||
----------------------- |
|
||||||
2014-06-30 |
|
||||||
(C) Harald Oehlmann |
|
||||||
harald.oehlmann@users.sourceforge.net |
|
||||||
|
|
||||||
What: tcl binding for zint bar code generator library |
|
||||||
|
|
||||||
Build: |
|
||||||
The header files of a TCL and Tk build are required for the build. |
|
||||||
|
|
||||||
- MS-VC6 project file "zint_tcl.dsp" may be opened by the GUI. |
|
||||||
(will need to add your version of tcl/tk libs to LINK32, e.g. |
|
||||||
"tcl85.lib" and "tk85.lib") |
|
||||||
- Linux/Unix build is provided by the configure script. |
|
||||||
Thanks to Christian Werner for that. |
|
||||||
|
|
||||||
Usage: |
|
||||||
|
|
||||||
load zint.dll |
|
||||||
zint help |
|
||||||
|
|
||||||
Most options are identical to the command line tool. |
|
||||||
Details may be found in the zint manual. |
|
||||||
|
|
||||||
Demo: |
|
||||||
The demo folder contains a visual demo program. |
|
||||||
Binary file not shown.
Loading…
Reference in new issue