Index: modules/zip/decode.tcl ================================================================== --- modules/zip/decode.tcl +++ modules/zip/decode.tcl @@ -8,13 +8,19 @@ # structures. package require Tcl 8.4 package require fileutil::magic::mimetype ; # Tcllib. File type determination via magic constants package require fileutil::decode 0.2 ; # Framework for easy decoding of files. -package require Trf ; # Wrapper to zlib -package require zlibtcl ; # Zlib usage. No commands, access through Trf - +namespace eval ::zipfile::decode {} +if {[package vcompare $tcl_patchLevel "8.6"] < 0} { + # Only needed pre-8.6 + package require Trf ; # Wrapper to zlib + package require zlibtcl ; # Zlib usage. No commands, access through Trf + set ::zipfile::decode::native_zip_functs 0 +} else { + set ::zipfile::decode::native_zip_functs 1 +} namespace eval ::zipfile::decode { namespace import ::fileutil::decode::* } # ### ### ### ######### ######### ######### @@ -163,13 +169,18 @@ go $fd(fileloc) nbytes $fd(csize) set out [::open $dst w] fconfigure $out -translation binary -encoding binary -eofchar {} - puts -nonewline $out \ + if {$::zipfile::decode::native_zip_functs} { + puts -nonewline $out \ + [zlib inflate [getval]] + } else { + puts -nonewline $out \ [zip -mode decompress -nowrap 1 -- \ [getval]] + } ::close $out } default { return -code error -errorcode {ZIP DECODE BAD COMPRESSION} \ "Unable to handle file \"$src\" compressed with method \"$fd(cm)\"" @@ -673,7 +684,7 @@ return [array get cb] } # ### ### ### ######### ######### ######### ## Ready -package provide zipfile::decode 0.6.1 +package provide zipfile::decode 0.7 return ADDED modules/zip/mkzip.man Index: modules/zip/mkzip.man ================================================================== --- /dev/null +++ modules/zip/mkzip.man @@ -0,0 +1,45 @@ +[vset ZIP_mkzip_VERSION 1.2] +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin zipfile::mkzip n [vset ZIP_mkzip_VERSION]] +[keywords decompression zip] +[copyright {2009 Pat Thoyts}] +[moddesc {Zip archive creation}] +[titledesc {Build a zip archive}] +[category File] +[require Tcl 8.6] +[require zipfile::mkzip [opt [vset ZIP_mkzip_VERSION]]] +[description] +[para] + +This package utilizes the zlib functions in Tcl8.6 to build zip archives. + +[section API] + +[list_begin definitions] +[comment ---------------------------------------------------------------------] +[call [cmd ::mkzip::mkzip] [opt -zipkit 1|0] [opt -runtime] [opt -comment] [opt -directory] [opt exclude]] +[para] +From http://wiki.tcl.tk/15158 +[para] +The following code is a tcl program to construct a zip archive from a directory tree using +nothing but Tcl 8.6 core features. The resulting zip file should be compatible with other +zip programs - with the possible exception of unicode support. The Tcl generated files use +utf-8 encoding for all filenames and comments but I notice particularly on Windows info-zip +and the Windows built-in zip view have rather poor support for this part of the ZIP file +specification. The 7-Zip program does correctly display utf8 filenames however and the +vfs::zip package will use these of course. +[para] +If you use [cmd ::mkzip::mkzip] mystuff.tm -zipkit -directory mystuff.vfs it will pack +your mystuff.vfs/ virtual filesystem tree into a zip +archive with a suitable header such that on unix you may mark it executable and it should +run with tclkit. Or you can run it with tclsh or wish 8.6 if you like. +To change the executable header, specify -runtime preface where preface is a file +containing code you want prefixed. For instance, on windows you can create a self-extracting +zip archive using mkzip mystuff.exe -directory mystuff.vfs -runtime unzipsfx.exe +(unzipsfx is the Info-Zip self-extracting stub). + +[list_end] + +[vset CATEGORY zipfile] +[include ../doctools2base/include/feedback.inc] +[manpage_end] ADDED modules/zip/mkzip.tcl Index: modules/zip/mkzip.tcl ================================================================== --- /dev/null +++ modules/zip/mkzip.tcl @@ -0,0 +1,278 @@ +# -*- tcl -*- +# mkzip.tcl -- Copyright (C) 2009 Pat Thoyts +# +# Create ZIP archives in Tcl. +# +# Create a zipkit using mkzip filename.zkit -zipkit -directory xyz.vfs +# or a zipfile using mkzip filename.zip -directory dirname -exclude "*~" +# +## BSD License +## +# Package providing commands for the generation of a zip archive. +# version 1.2 + +package require Tcl 8.6 + +namespace eval ::zipfile {} +namespace eval ::zipfile::decode {} +namespace eval ::zipfile::encode {} +namespace eval zip {} + +proc ::mkzip::setbinary chan { + fconfigure $chan \ + -encoding binary \ + -translation binary \ + -eofchar {} + +} + +# zip::timet_to_dos +# +# Convert a unix timestamp into a DOS timestamp for ZIP times. +# +# 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| +# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +# +proc ::mkzip::timet_to_dos {time_t} { + 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)} +} + +# zip::pop -- +# +# Pop an element from a list +# +proc ::mkzip::pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# zip::walk -- +# +# Walk a directory tree rooted at 'path'. The excludes list can be +# a set of glob expressions to match against files and to avoid. +# The match arg is internal. +# eg: walk library {CVS/* *~ .#*} to exclude CVS and emacs cruft. +# +proc ::mkzip::walk {base {excludes ""} {match *} {path {}}} { + set result {} + set imatch [file join $path $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 $imatch] { + set subdir [walk $base $excludes $match $dir] + if {[llength $subdir]>0} { + set result [concat $result [list $dir] $subdir] + } + } + return $result +} + +# zipfile::encode::add_file_to_archive -- +# +# Add a single file to a zip archive. The zipchan channel should +# already be open and binary. You may provide a comment for the +# file The return value is the central directory record that +# will need to be used when finalizing the zip archive. +# +# FIX ME: should handle the current offset for non-seekable channels +# +proc ::mkzip::add_file_to_archive {zipchan base path {comment ""}} { + set fullpath [file join $base $path] + set mtime [timet_to_dos [file mtime $fullpath]] + if {[file isdirectory $fullpath]} { + append path / + } + 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) + } 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] + setbinary $fin + 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] + setbinary $fin + 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 + } + } + + set hdr [binary format a4ssssiiiisssssii PK\01\02 0x0317 \ + $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 +} + +# zipfile::encode::mkzip -- +# +# Create a zip archive in 'filename'. If a file already exists it will be +# overwritten by a new file. If '-directory' is used, the new zip archive +# will be rooted in the provided directory. +# -runtime can be used to specify a prefix file. For instance, +# zip myzip -runtime unzipsfx.exe -directory subdir +# will create a self-extracting zip archive from the subdir/ folder. +# The -comment parameter specifies an optional comment for the archive. +# +# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt +# +proc ::mkzip::mkzip {filename args} { + array set opts { + -zipkit 0 -runtime "" -comment "" -directory "" + -exclude {CVS/* */CVS/* *~ ".#*" "*/.#*"} + } + + while {[string match -* [set option [lindex $args 0]]]} { + switch -exact -- $option { + -zipkit { set opts(-zipkit) 1 } + -comment { set opts(-comment) [encoding convertto utf-8 [pop args 1]] } + -runtime { set opts(-runtime) [pop args 1] } + -directory {set opts(-directory) [file normalize [pop args 1]] } + -exclude {set opts(-exclude) [pop args 1] } + -- { pop args ; break } + default { + break + } + } + pop args + } + + set zf [::open $filename wb] + setbinary $zf + if {$opts(-runtime) ne ""} { + set rt [::open $opts(-runtime) rb] + setbinary $rt + 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 "" + + if {$opts(-directory) ne ""} { + set paths [walk $opts(-directory) $opts(-exclude)] + } else { + set paths [glob -nocomplain {*}$args] + } + foreach path $paths { + puts $path + append cd [add_file_to_archive $zf $opts(-directory) $path] + 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 + + return +} + +# ### ### ### ######### ######### ######### +## Ready +package provide zipfile::mkzip 1.2 Index: modules/zip/pkgIndex.tcl ================================================================== --- modules/zip/pkgIndex.tcl +++ modules/zip/pkgIndex.tcl @@ -1,3 +1,13 @@ -if {![package vsatisfies [package provide Tcl] 8.4]} {return} +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded zipfile::decode 0.7 [list source [file join $dir decode.tcl]] package ifneeded zipfile::encode 0.3 [list source [file join $dir encode.tcl]] -package ifneeded zipfile::decode 0.6.1 [list source [file join $dir decode.tcl]] +package ifneeded zipfile::mkzip 1.2 [list source [file join $dir mkzip.tcl]]