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]
	if {$minute eq ""} {
            set minute 0
        }
       set secound [string trimleft $secound 0]
       if {$secound eq ""} {
           set 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]