[tjk] This code provides 4 commands for working with zip archive files. The code assumes vfs::zip is available so tcl8.5 or better is assumed.

   * list2zip - create a zip archive

   * unzip - unzip a zip archive

   * zcopy - copy a file out of a zip archive

   * zstat - return a dict of stat information on the contents of a zip archive

NEEDS WORK: This version doesn't preserve file and directory mode values (i.e. access rights).

======
# This code is a rewrite and extension of the zipper
# code found at http://equi4.com/critlib/ and the
# unzip code found at http://wiki.tcl.tk/17433

package provide zipper 0.2
package require vfs::zip

namespace eval zipper {

    namespace ensemble create
    namespace export list2zip unzip zcopy zstat
    
    # -- list2zip
    #
    # zip a list of files into a single zip archive.
    #
    # ARGUMENTS
    #  from  - path to source directory
    #  flist - a list of file and/or directory paths to be zipped
    #  to    - name of zip file that will be created; including
    #          '.zip' is up to the user; 'to' can be a full or
    #          relative path; if 'to' exists it will be overwritten
    #
    # RETURNS
    #  null
    #
    proc list2zip { dir flist to } {
        initialize [open ${to} w]
        foreach f ${flist} {
            regsub {^\./} ${f} {} to
            set from [file join [file normalize ${dir}] ${to}]
            if { [file isfile ${from}] } {
                set fd [open ${from}]
                fconfigure ${fd} -translation binary -encoding binary
                addentry ${to} [read ${fd}] [file mtime ${from}]
                close ${fd}
            } elseif { [file isdir ${from}] } {
                adddir ${to} [file mtime ${from}]
                lappend dirs ${f}
            }
        }
        close [finalize]
    }
    
    # -- unzip
    #
    # unzip a zip archive created with list2zip into a directory.
    #
    # ARGUMENTS
    #  zname - path to zip archive file
    #  to    - directory where archived file will be placed; if
    #          directory doesn't exist it will be created
    #
    # RETURNS
    #  0 if success, otherwise 1
    #
    proc unzip { zname to } {
        
        set zfile [file normalize ${zname}]
        if { ![file readable ${zfile}] } {
            return 1
        }
        
        if { ![file isdirectory ${to}] } {
            file mkdir ${to}
        }
        
        set items [zstat ${zname}]
        
        foreach item [dict keys ${items}] {
            set target [file join ${to} ${item}]
            set type [dict get ${items} ${item} type]
            if { ${type} eq "directory" } {
                file mkdir ${target}
            } else {
                zcopy ${zname} ${item} ${to}
            }
        }
        return 0
    }
    
    # -- zcopy
    #
    # copy a file from a zip archive file to an external directory
    #
    # ARGUMENTS
    #  zname - path to zip archive file (include the '.zip')
    #  path  - file path within a zip archive (no leading './')
    #  to    - directory where archived file will be placed
    #          (directory must already exist)
    #
    # RETURNS
    #  null
    #
    proc zcopy { zname path to } {
        set zmount [file normalize ${zname}]
        set from [file join ${zmount} ${path}]
        set to [file normalize [file join ${to} ${path}]]
        file mkdir [file dirname ${to}]
        set zid [vfs::zip::Mount ${zmount} ${zmount}]
        file copy ${from} ${to}
        set sdict [::vfs::zip::stat ${zid} ${path}]
        set mode [dict get ${sdict} mode]
        set mtime [dict get ${sdict} mtime]
        set atime [dict get ${sdict} atime]
        file attributes ${to} -permissions ${mode}
        file mtime ${to} ${mtime}
        file atime ${to} ${atime}
        ::vfs::zip::Unmount ${zid} ${zmount}
    }
    
    # -- zstat
    #
    # return status information on all the items int a zip archive.
    #
    # ARGUMENTS
    #  zname - path to zip archive file (include the '.zip')
    #
    # RETURNS
    #  dict  - keys are paths and their values are dicts of stat info
    #
    proc zstat { zname } {
        set zfile [file normalize ${zname}]
        set fd [::zip::open ${zfile}]
        set items [dict create]
        foreach item [lsort [array names ::zip::$fd.toc]] {
            ::zip::stat ${fd} ${item} stat
            if { $stat(name) ne "" && $stat(ctime) > 0 } {
                set vdict [dict create {*}[array get stat]]
                set name $stat(name)
                dict unset vdict name
                if { [string index ${name} end] eq "/" } {
                    dict set vdict type directory
                    set name [string trimright ${name} "/"]
                }
                dict set items ${name} ${vdict}
            }
        }
        ::zip::_close ${fd}
        return ${items}
    }
    
    namespace eval v {
        variable fd
        variable base
        variable toc
    }

    proc initialize {fd} {
        set v::fd $fd
        set v::base [tell $fd]
        set v::toc {}
        fconfigure $fd -translation binary -encoding binary
    }

    proc emit {s} {
        puts -nonewline $v::fd $s
    }

    proc dostime {sec} {
        set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1]
        regsub -all { 0(\d)} $f { \1} f
        foreach {Y M D h m s} $f break
        set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}]
        set time [expr {($h<<11) | ($m<<5) | ($s>>1)}]
        return [list $date $time]
    }

    proc addentry {name contents {date ""} {force 0}} {
        if {$date == ""} { set date [clock seconds] }
        lassign [dostime $date] date time
        set flag 0
        set type 0 ;# stored
        set fsize [string length $contents]
        set csize $fsize
        set fnlen [string length $name]
        
        if {$force > 0 && $force != [string length $contents]} {
            set csize $fsize
            set fsize $force
            set type 8 ;# if we're passing in compressed data, it's deflated
        }
        
        if {[catch { zlib crc32 $contents } crc]} {
            set crc 0
        } elseif {$type == 0} {
            set cdata [zlib deflate $contents]
            if {[string length $cdata] < [string length $contents]} {
                set contents $cdata
                set csize [string length $cdata]
                set type 8 ;# deflate
            }
        }
        
        lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \
        $flag $type $time $date $crc $csize $fsize $fnlen \
        {0 0 0 0} 128 [tell $v::fd]]$name"
        
        emit [binary format a2c4ssssiiiss PK {3 4 20 0} \
        $flag $type $time $date $crc $csize $fsize $fnlen 0]
        emit $name
        emit $contents
    }

    proc adddir {name {date ""} {force 0}} {
        set name "${name}/"
        if {$date == ""} { set date [clock seconds] }
        lassign [dostime $date] date time
        set flag 0
        set type 0 ;# stored
        set fsize 0
        set csize 0
        set fnlen [string length $name]
        
        set crc 0
        
        lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \
        $flag $type $time $date $crc $csize $fsize $fnlen \
        {0 0 0 0} 128 [tell $v::fd]]$name"
        
        emit [binary format a2c4ssssiiiss PK {3 4 20 0} \
        $flag $type $time $date $crc $csize $fsize $fnlen 0]
        emit $name
    }

    proc finalize {} {
        set pos [tell $v::fd]
        
        set ntoc [llength $v::toc]
        foreach x $v::toc { emit $x }
        set v::toc {}
        
        set len [expr {[tell $v::fd] - $pos}]
        incr pos -$v::base
        
        emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0]
        
        return $v::fd
    }
}

======
----
'''[TRL] - 2015-01-05 15:52:02'''

**For Windows platform.**

I use this code for a little project but I need this TCL code running on Windows platform. (''I actually use active TCL 8.5'')
The problem is that I don't have zlib library.

So I just give a little modification for those who want to use it for Windows:

Just replace the lines:

======tcl
...
        if {[catch { zlib crc32 $contents } crc]} {
...
======
with 
======tcl
...
        if {[catch { ::vfs::crc $contents } crc]} {
...
======

and 

======tcl
...
            set cdata [zlib deflate $contents]
...
======
with 
======tcl
...
            set cdata [::vfs::zip -nowrap 1 -mode compress $contents]
...
======

Thank you for this greeat code!!

<<categories>> Compression | Vfs