Version 7 of creating zip file archives from tcl with zlib

Updated 2008-06-15 09:35:16 by atk

By Artur Trzewik. vfs's vfs::zip currently only supports the ability to read zip archives. I have not found any Tcl library that can create zip archives, so I implemented it by myself. Adding write support to a vfs extension is quite a bit more complicated so I have written it separately in XOTcl. The code can be also simply ported to pure Tcl (MHo: Has this been done by someone meanwhile???) . The zip archive should be the same as generated with WinZip.

    package require XOTcl
    namespace import xotcl::*

    Class ZipArchive
    @ ::ZipArchive idemeta component ZipArchive
    ZipArchive instproc addFile {inputFile fileName} {
        # inputFile - source file to archive
        # fileName - name of file in the archive
        my lappend files $inputFile $fileName
    }
    ZipArchive instproc addToStream {stream fin fout} {
        my instvar written

        set offset $written

        set fdata [open $fin r]
        fconfigure $fdata -encoding binary -translation binary
        set data [read $fdata]
        set datacompresed [string range [::vfs::zip -mode compress $data] 2 end-4]
        close $fdata

        binary scan \x04\x03\x4B\x50 I LFH_SIG
        my writeLong $stream $LFH_SIG

        incr written 4

        my writeShort $stream 20
        # java implementation make 8
        # but tools (WinZip) leave it 0
        my writeShort $stream 0
        incr written 4

        my writeShort $stream 8
        incr written 2

        # last mod. time and date
        set dosTime [my toDosTime $fin]

        my writeLong $stream $dosTime
        incr written 4

        set crc [::vfs::crc $data]
        set csize [string length $datacompresed]
        set size [string length $data]

        my writeLong $stream $crc
        my writeLong $stream $csize
        my writeLong $stream $size
        incr written 12

        # file name length
        my writeShort $stream [string length $fout]
        incr written 2

        # extra field length
        set extra ""
        my writeShort $stream [string length $extra]
        incr written 2

        # file name
        puts -nonewline $stream $fout
        incr written [string length $fout]

        puts -nonewline $stream $extra
        incr written [string length $extra]

        set dataStart written;
        puts -nonewline $stream $datacompresed
        incr written $csize

        list $offset $dosTime $crc $csize $size
    }
    ZipArchive instproc createFile file {
        set fout [open $file w]
        fconfigure $fout -encoding binary -translation binary
        my createToStream $fout
        close $fout
    }
    ZipArchive instproc createToStream ostream {
        my instvar files cdOffset cdLength written
        set descriptionList [list]
        foreach {fin fout} $files {
            lappend descriptionList [my addToStream $ostream $fin $fout]
        }
        set cdOffset $written

        foreach {fin fout} $files desc $descriptionList {
            foreach {offset dosTime crc csize size} $desc {}
            my writeCentralFileHeader $ostream $fin $fout $offset $dosTime $size $csize $crc
        }

        set cdLength [expr {$written - $cdOffset}]
        # wirte header

        # EOCD 0X06054B50L scan 0X06054B50L %x s set s
        binary scan \x06\x05\x4B\x50 I EOCD
        my writeLong $ostream $EOCD

        # disk numbers
        my writeShort $ostream 0
        my writeShort $ostream 0

        # number of entries
        set filenum [expr {[llength $files]>>1}]
        my writeShort $ostream $filenum
        my writeShort $ostream $filenum

        # length and location of CD
        my writeLong $ostream $cdLength
        my writeLong $ostream $cdOffset

        # zip file comment
        set comment ""
        # comment lenght
        my writeShort $ostream [string bytelength $comment]

        puts -nonewline $ostream $comment
    }
    ZipArchive instproc init {} {
        my set files [list]
        package require vfslib
        my instvar cdLength cdOffset written
        set cdLength 0
        set cdOffset 0
        set written 0
    }
    ZipArchive instproc toDosTime file {
        set sec [file mtime $file]

        foreach {year month day hour minute secound} [clock format $sec -format "%Y %m %e %k %M %S"] {}

        set month [string trimleft $month 0]
        set year [string trimleft $year 0]
        set minute [string trimleft $minute 0]
        set secound [string trimleft $secound 0]    

        set value [expr (($year - 1980) << 25) | ($month << 21) | ($day << 16) | ($hour << 11) | ($minute << 5) | ($secound >> 1)]
        return $value
    }
    ZipArchive instproc writeCentralFileHeader {ostream fin fout offset dosTime size csize crc} {
        my instvar written

        # CFH 0X02014B50L
        binary scan \x02\x01\x4B\x50 I CFH_SIG
        my writeLong $ostream $CFH_SIG
        incr written 4

        if {$::tcl_platform(platform) eq "windows"} {
            # unix
            set pid 5
        } else {
            # windows
            set pid 11
        }
        my writeShort $ostream [expr { (($pid << 8) | 20)}]
        incr written 2

        # version needed to extract
        # general purpose bit flag

        my writeShort $ostream 20
        my writeShort $ostream 0
        incr written 4

        # compression method
        my writeShort $ostream 8
        incr written 2

        # last mod. time and date
        my writeLong $ostream $dosTime
        incr written 4

        # CRC
        # compressed length
        # uncompressed length
        my writeLong $ostream $crc
        my writeLong $ostream $csize
        my writeLong $ostream $size
        incr written 12;

        set comment ""
        set extra ""

        # file name length

        my writeShort $ostream [string bytelength $fout]
        incr written 2;

        # extra field length
        my writeShort $ostream [string bytelength $extra]
        incr written 2;

        # file comment length
        my writeShort $ostream [string bytelength $comment]
        incr written 2;

        # disk number start
        my writeShort $ostream 0
        incr written 2

        # internal file attributes
        my writeShort $ostream 0
        incr written 2

        # external file attributes
        my writeLong $ostream 0
        incr written 4

        # relative offset of LFH
        my writeLong $ostream $offset
        incr written 4

        # file name
        puts -nonewline $ostream $fout
        incr written [string bytelength $fout]

        # extra field
        puts -nonewline $ostream $extra
        incr written [string bytelength $extra]

        # file comment
        puts -nonewline $ostream $comment
        incr written [string bytelength $comment]
    }
    ZipArchive instproc writeLong {stream short} {
        puts -nonewline $stream [binary format i $short]
    }
    ZipArchive instproc writeShort {stream short} {
        puts -nonewline $stream [binary format s $short]
    }
    ZipArchive proc createZip {zipFile files} {
        set zipArch [my new]
        foreach f $files {
            $zipArch addFile $f [file tail $f]
        }
        $zipArch createFile $zipFile
        $zipArch destroy
    }
    ZipArchive proc testZip {} {
        my createZip {C:/tmp/my2.zip} {C:/tmp/test.txt C:/tmp/test2.txt C:/tmp/tmp.zip}
        # ZipArchive dumpFile {C:/tmp/my2.zip}
        # ZipArchive dumpFile {C:/tmp/tmp.zip}
    }

requires vfslib Usage as in class method createZip

   set zipArch [ZipArchive new]
   foreach f $files {
      $zipArch addFile $f [file tail $f]
   }
   $zipArch createFile $zipFile
   $zipArch destroy

lasselasse had a problem in instproc toDosTime with a file whose modification date was 2003 01 14 17 23 00

    string trimleft $secound 0 

returns the empty string which results in an error in the expression afterwards. Wouldn't it be easier to use

    expr int($secound)

instead?

atk: think about expr int(09)

Category XOTcl Code | Category Compression