Tcl Library Source Code

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Copyright (c) 2008-2012 ActiveState Software Inc.
##                         Andreas Kupries
## BSD License
##
# Package providing commands for the decoding of basic zip-file
# 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.
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::*
}

# ### ### ### ######### ######### #########
## Convenience command, decode and copy to dir

	}
	deflate {
	    go     $fd(fileloc)
	    nbytes $fd(csize)

	    set out [::open $dst w]
	    fconfigure $out -translation binary -encoding binary -eofchar {}
            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)\""
	}
    }

    #--------------
    ::close $fd
    return [array get cb]
}

# ### ### ### ######### ######### #########
## Ready
package provide zipfile::decode 0.7
return

[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]

# -*- tcl -*-
# mkzip.tcl -- Copyright (C) 2009 Pat Thoyts <[email protected]>
#
#        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

# 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::mkzip 1.2 [list source [file join $dir mkzip.tcl]]