By Artur Trzewik. vfs vfs::zip supports now only read zip archives. I have not found any Tcl library that can create zip archives so I implemented it by myself. Adding writte support to vfs is quite more complicated so I have written it separatelly in XOTcl. The code can be also simple ported to pure Tcl. 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 leafe 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 %d %H %M %S"] {}
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 8
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