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