Tcl Library Source Code

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Copyright (c) 2008-2009 ActiveState Software Inc.
##                         Andreas Kupries
## BSD License
##
# Package to help the writing of file decoders. Provides generic
# low-level support commands.

package require Tcl 8.5
package require debug
package require debug::caller

namespace eval ::fileutil::decode {
    namespace export mark go rewind at
    namespace export byte short-le long-le nbytes skip
    namespace export unsigned match recode getval
    namespace export clear get put putloc setbuf
}

debug level  fileutil/decode 
debug prefix fileutil/decode {[debug caller] | }

# ### ### ### ######### ######### #########
##

proc ::fileutil::decode::open {fname} {
    debug.fileutil/decode {}
    variable chan
    set chan [::open $fname r]
    fconfigure $chan \
	-translation binary \
	-encoding    binary \
	-eofchar     {}

    debug.fileutil/decode {/done = $chan}
    return
}

proc ::fileutil::decode::close {} {
    variable chan
    debug.fileutil/decode { closing $chan }
    ::close $chan
    return
}

# ### ### ### ######### ######### #########
##

proc ::fileutil::decode::mark {} {
    variable chan
    variable mark
    set mark [tell $chan]
    debug.fileutil/decode { @ $mark }
    return
}

proc ::fileutil::decode::go {to} {
    debug.fileutil/decode {}
    variable chan
    seek $chan $to start
    return
}

proc ::fileutil::decode::rewind {} {
    variable chan
    variable mark
    if {$mark == {}} {
	debug.fileutil/decode {}
	return -code error "No mark to rewind to"
    }
    seek $chan $mark start
    debug.fileutil/decode { @ $mark}

    set mark {}
    return
}

proc ::fileutil::decode::at {} {
    debug.fileutil/decode {}
    variable chan
    return [tell $chan]
}

# ### ### ### ######### ######### #########
##

proc ::fileutil::decode::byte {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 1]
    binary scan $val c val
    return
}

proc ::fileutil::decode::short-le {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 2]
    binary scan $val s val
    return
}

proc ::fileutil::decode::short-be {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 2]
    binary scan $val S val
    return
}

proc ::fileutil::decode::long-le {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 4]
    binary scan $val i val
    return
}

proc ::fileutil::decode::long-be {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 4]
    binary scan $val I val
    return
}

proc ::fileutil::decode::longlong-le {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 8]
    binary scan $val ii lo hi
    set val [expr {($hi << 32) | $lo}]
    return
}

proc ::fileutil::decode::longlong-be {} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan 8]
    binary scan $val II hi lo
    set val [expr {($hi << 32) | $lo}]
    return
}

proc ::fileutil::decode::nbytes {n} {
    debug.fileutil/decode {}
    variable chan
    variable val [read $chan $n]
    return
}

proc ::fileutil::decode::skip {n} {
    debug.fileutil/decode {}
    variable chan
    #read $chan $n
    seek $chan $n current
    return
}

# ### ### ### ######### ######### #########
##

proc ::fileutil::decode::unsigned {} {
    debug.fileutil/decode {}
    variable val
    if {$val >= 0} return
    set val [format %u [expr {$val & 0xffffffff}]]
    return
}

proc ::fileutil::decode::match {eval} {
    debug.fileutil/decode {}
    variable val

    #puts "Match: Expected $eval, Got: [format 0x%08x $val]"

    if {$val == $eval} {
	debug.fileutil/decode {OK}
	return 1
    }
    rewind

    debug.fileutil/decode {FAIL $val}
    return 0
}

proc ::fileutil::decode::recode {cmdpfx} {
    debug.fileutil/decode {}
    variable val
    lappend cmdpfx $val
    set val [uplevel 1 $cmdpfx]
    return
}

proc ::fileutil::decode::getval {} {
    debug.fileutil/decode {}
    variable val
    return $val
}

# ### ### ### ######### ######### #########
##

proc ::fileutil::decode::clear {} {
    debug.fileutil/decode {}
    variable buf {}
    return
}

proc ::fileutil::decode::get {} {
    debug.fileutil/decode {}
    variable buf
    return $buf
}

proc ::fileutil::decode::setbuf {list} {
    debug.fileutil/decode {}
    variable buf $list
    return
}

proc ::fileutil::decode::put {name} {
    debug.fileutil/decode {}
    variable buf
    variable val
    lappend buf $name $val
    return
}

proc ::fileutil::decode::putloc {name} {
    debug.fileutil/decode {}
    variable buf
    variable chan
    lappend buf $name [tell $chan]
    return
}

# ### ### ### ######### ######### #########

    # Buffer for accumulating structured results
    variable buf  {}
}

# ### ### ### ######### ######### #########
## Ready
package provide fileutil::decode 0.3
return

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded fileutil 1.14.6 [list source [file join $dir fileutil.tcl]]

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded fileutil::traverse 0.4.3 [list source [file join $dir traverse.tcl]]

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded fileutil::multi     0.1   [list source [file join $dir multi.tcl]]
package ifneeded fileutil::multi::op 0.5.3 [list source [file join $dir multiop.tcl]]
package ifneeded fileutil::decode    0.3   [list source [file join $dir decode.tcl]]

# -*- 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.5
package require fileutil::magic::mimetype ; # Tcllib. File type determination via magic constants
package require fileutil::decode 0.2      ; # Framework for easy decoding of files.
package require Trf                       ; # Wrapper to zlib
package require zlibtcl                   ; # Zlib usage. No commands, access through Trf
package require debug
package require debug::caller

debug level  zip/decode 
debug prefix zip/decode {[debug caller] | }

namespace eval ::zipfile::decode {
    namespace import ::fileutil::decode::*
}

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

proc ::zipfile::decode::unzipfile {in out} {
    debug.zip/decode {}

    zipfile::decode::open  $in
    set                     zd [zipfile::decode::archive]
    zipfile::decode::unzip $zd $out
    zipfile::decode::close

    debug.zip/decode {/done}
    return
}

## Convenience command, decode and return list of contained paths.
proc ::zipfile::decode::content {in} {
    debug.zip/decode {}

    zipfile::decode::open $in
    set zd [zipfile::decode::archive]
    set f [files $zd]
    zipfile::decode::close

    debug.zip/decode {==> $f}
    return $f
}

# ### ### ### ######### ######### #########
##

proc ::zipfile::decode::open {fname} {
    debug.zip/decode {}

    variable eoa
    if {[catch {
	set eoa [LocateEnd $fname]
    } msg]} {
	return -code error -errorcode {ZIP DECODE BAD ARCHIVE} \
	    "\"$fname\" is not a zip file: $msg"
    }
    fileutil::decode::open $fname

    debug.zip/decode {/done}
    return
}

proc ::zipfile::decode::close {} {
    debug.zip/decode {}

    variable eoa
    unset eoa
    fileutil::decode::close

    debug.zip/decode {/done}
    return
}

# ### ### ### ######### ######### #########
##

proc ::zipfile::decode::comment {zdict} {
    debug.zip/decode {}
    array set _ $zdict
    return $_(comment)
}

proc ::zipfile::decode::files {zdict} {
    debug.zip/decode {}

    array set _ $zdict
    array set f $_(files)
    return [array names f]
}

proc ::zipfile::decode::hasfile {zdict fname} {
    debug.zip/decode {}

    array set _ $zdict
    array set f $_(files)
    return [info exists f($fname)]
}

proc ::zipfile::decode::copyfile {zdict src dst} {
    debug.zip/decode {}

    array set _ $zdict
    array set f $_(files)

    if {![info exists f($src)]} {
	return -code error -errorcode {ZIP DECODE BAD PATH} \
	    "File \"$src\" not known"
    }

    array set     fd $f($src)
    CopyFile $src fd $dst
    return
}

proc ::zipfile::decode::getfile {zdict src} {
    debug.zip/decode {}

    array set _ $zdict
    array set f $_(files)

    if {![info exists f($src)]} {
	return -code error -errorcode {ZIP DECODE BAD PATH} \
	    "File \"$src\" not known"
    }

    array set fd $f($src)
    return [GetFile $src fd]
}

proc ::zipfile::decode::unzip {zdict dst} {
    debug.zip/decode {}

    array set _ $zdict
    array set f $_(files)

    foreach src [array names f] {
	array set     fd $f($src)
	CopyFile $src fd [file join $dst $src]

	unset fd
    }
    return
}

proc ::zipfile::decode::CopyFile {src fdv dst} {
    debug.zip/decode {}
    upvar 1 $fdv fd

    file mkdir [file dirname $dst]

    if {[string match */ $src]} {
	# Entry is a directory. Just create.
	file mkdir $dst

    # FUTURE: Run crc checksum on created file and compare to the
    # ......: stored information.

    return
}

proc ::zipfile::decode::GetFile {src fdv} {
    debug.zip/decode {}
    upvar 1 $fdv fd

    # Entry is a directory.
    if {[string match */ $src]} {return {}}

    # Empty files are a special case, we have
    # nothing to decompress.

    return {}
}

# ### ### ### ######### ######### #########
##

proc ::zipfile::decode::tag {etag} {
    debug.zip/decode {}
    mark
    long-le
    return [match 0x${etag}4b50] ; # 'PK x y', little-endian integer.
}

proc ::zipfile::decode::localfileheader {} {
    debug.zip/decode {}
    clear
    putloc @
    if {![tag 0403]} {clear ; return 0}

    short-le ; unsigned ; recode VER ; put vnte      ; # version needed to extract				       
    short-le ; unsigned ;              put gpbf      ; # general purpose bitflag				       
    short-le ; unsigned ; recode CM  ; put cm        ; # compression method					       

    skip $hdr(efieldlen)
    putloc                      fileloc

    array set hdr [get]
    clear

    set hdr(gpbf) [GPBF $hdr(gpbf) $hdr(cm)]

    debug.zip/decode {[debug nl][debug parray hdr]}
    setbuf [array get hdr]
    return 1
}

proc ::zipfile::decode::centralfileheader {} {
    debug.zip/decode {}
    clear
    putloc @
    if {![tag 0201]} {clear ; return 0}

    # The items marked with ++ do not exist in the local file
    # header. Everything else exists in the local file header as well,
    # and has to match that information.

    skip $hdr(efieldlen2)
    nbytes $hdr(fcommentlen) ; put comment

    array set hdr [get]
    clear

    set hdr(gpbf) [GPBF $hdr(gpbf) $hdr(cm)]

    debug.zip/decode {[debug nl][debug parray hdr]}
    setbuf [array get hdr]
    return 1
}

## NOT USED
proc ::zipfile::decode::datadescriptor {} {
    debug.zip/decode {}
    if {![tag 0807]} {return 0}

    clear
    long-le  ; unsigned ; put crc    ; # crc32                 
    long-le  ; unsigned ; put csize  ; # compressed file size  
    long-le  ; unsigned ; put ucsize ; # uncompressed file size   

    return 1
}

proc ::zipfile::decode::endcentralfiledir {} {
    debug.zip/decode {}
    clear
    putloc ecdloc
    if {![tag 0605]} {clear ; return 0}

    short-le ; unsigned ; put nd         ; #
    short-le ; unsigned ; put ndscd      ; #
    short-le ; unsigned ; put tnecdd     ; #

    setbuf [array get hdr]
    return 1
}

## NOT USED
proc ::zipfile::decode::afile {} {
    debug.zip/decode {}
    if {![localfileheader]} {return 0}

    array set hdr [get]
    if {($hdr(ucsize) == 0) || ($hdr(csize) > 0)} {
	# The header entry specifies either
	# 1. A zero-length file (possibly a directory entry), or
	# 2. a non-empty file (compressed size > 0).

	return -code error -errorcode {ZIP DECODE INCOMPLETE} \
	    "Search data descriptor. Not Yet Implementyed"
    }
    return 1
}

proc ::zipfile::decode::archive {} {
    debug.zip/decode {}

    variable eoa
    array set cb $eoa

    # Position us at the beginning of CFH, using the data provided to
    # us by 'LocateEnd', called during 'open'.

    go [expr {$cb(base) + $cb(coff)}]

    }

    set _(files) [array get fn]
    return [array get _]
}

proc ::zipfile::decode::hdrmatch {lhv chv} {
    debug.zip/decode {}
    upvar 1 $lhv lh $chv ch

    #puts ______________________________________________
    #parray lh
    #parray ch

    foreach key {
	vnte gpbf cm lmft lmfd fnamelen fname
    } {
	if {$lh($key) != $ch($key)} {
	    debug.zip/decode {mismatch $key ($lh($key) != $ch($key))}
	    return 0
	}
    }

    if {[lsearch -exact $lh(gpbf) dd] < 0} {
	# Compare the central and local size information only if the
	# latter is not provided by a DDS. Which we haven't read.
	# Because in that case the LFH information is uniformly 0, not
	# known at the time of writing.

	foreach key {
	    crc csize ucsize
	} {
	    if {$lh($key) != $ch($key)} {
		debug.zip/decode {mismatch $key ($lh($key) != $ch($key))}
		return 0
	    }
	}
    }

    return 1
}


# ### ### ### ######### ######### #########
##

proc ::zipfile::decode::IFA {v} {
    debug.zip/decode {}
    if {$v & 0x1} {
	return text
    } else {
	return binary
    }
}

	12 SMS/QDOS	13 {Acorn RISC OS}
	14 VFAT		15 MVS
	16 BeOS		17 Tandem
    }
}

proc ::zipfile::decode::VER {v} {
    debug.zip/decode {}
    variable vhost
    set u [expr {($v & 0xff00) >> 16}]
    set l [expr {($v & 0x00ff)}]

    set major [expr {$l / 10}]
    set minor [expr {$l % 10}]

	6  implode	7  reserved
	8  deflate	9  reserved
	10 implode-pkware-dcl
    }
}

proc ::zipfile::decode::CM {v} {
    debug.zip/decode {}
    variable cm
    return $cm($v)
}

# ### ### ### ######### ######### #########
##

	deflate,1 maximum
	deflate,2 fast
	deflate,3 superfast
   }
}

proc ::zipfile::decode::GPBF {v cm} {
    debug.zip/decode {}
    variable gbits
    set res {}

    if {$cm eq "deflate"} {
	# bit 1, 2 are treated together for deflate

	lappend res $gbits($cm,[expr {($v >> 1) & 0x3}])

## Decode the zip file by locating its end (of the central file
## header). The higher levels will then use the information
## inside to locate and read the CFH. No scanning from the beginning
## This piece of code lifted from tclvs/library/zipvfs (v 1.0.3).

proc ::zipfile::decode::LocateEnd {path} {
    debug.zip/decode {}

    set fd [::open $path r]
    fconfigure $fd -translation binary ;#-buffering none

    debug.zip/decode {= $fd}

    array set cb {}

    # First locate the regular end of central directory structure.
    set hdr [LocateMarker $fd "PK\05\06" pos at]

    set is64 off
    # Two ZIP64 structures may sit before it, the
    #      zip64 end of central file directory
    # and  zip64 end of central file directory locator
    # We look for them in reverse order.
    if {![catch {
	set hdra [LocateMarker $fd "PK\06\07" posa ata]
	set hdrb [LocateMarker $fd "PK\06\06" posb atb]
    }]} {
	debug.zip/decode {ZIP64 detected}
	set is64 on

	# ecfd locator
	set hdra [string range $hdra [expr {$posa + 4}] [expr {$posa + 19}]]
	set lena [string length $hdra]
	debug.zip/decode {ecfdlo len = $lena}
	#                 48_4 = 16
	binary scan $hdra iiii cb(_64.l.disk.cfd) lo hi cb(_64.l.disk.num)
	set cb(_64.l.coff) [expr {($hi << 32)|$lo}]
	# This is the location of the zip64 ecfd relative to start of archive.

	# ecfd64
	set hdrb [string range $hdrb [expr {$posb + 4}] [expr {$posb + 47}]]
	set lenb [string length $hdrb]
	debug.zip/decode {ecfd64 len = $lenb}
	#                 8_22448_8_8_ = 44
	binary scan $hdrb iissiiiiiiii \
	    lo hi cb(_64.vmade) cb(_64.vneed) cb(_64.disk.now) cb(_64.disk.cfd2) \
	    loa hia lob hib loc hic
	set cb(_64.ecfd.size) [expr {($hi  << 32)|$lo}]
	set cb(_64.files.now) [expr {($hia << 32)|$loa}]
	set cb(_64.files.num) [expr {($hib << 32)|$lob}]
	set cb(_64.coff2)     [expr {($hic << 32)|$loc}]
    }

    # restrict read data to the structure's payload
    set hdr [string range  $hdr [expr {$pos + 4}] [expr {$pos + 21}]]
    #                2222442 = 18
    binary scan $hdr ssssiis cb(_disk.now) cb(_disk.cfd) \
	cb(_nfiles.now) cb(_nfiles.all) cb(csize) cb(coff) \
	cb(_commentlen)

    if {$is64} {
	# In the presence of zip64 we have to compute the actual
	# location of the CFD differently. It is not just before the
	# ECFD structure, but before the ECFD64 structure.

	set at $atb
	debug.zip/decode {new at $at}
    }

    debug.zip/decode {CFH Expected @ $cb(coff)}
    debug.zip/decode {    Actual   @ $at}
    debug.zip/decode {    Size       $cb(csize)}

    # Compute base (start of archive) for situations where the ZIP
    # file has been appended to another media (e.g. EXE). We can do
    # this because
    # (a) The expected location is stored in ECFH.   (-> cb(coff))
    # (b) We know the actual location of EFCH.       (-> at)
    # (c) We know the size of CFH                    (-> cb(csize))
    # (d) The CFH comes directly before the EFCH.
    # (e) Items b...d provide us with the actual location of CFH, as (b)-(c).
    # Thus the difference between (e) and (d) is the base in question.

    set base [expr { $at - $cb(csize) - $cb(coff) }]
    debug.zip/decode {Archive Base : $base}

    if {$base < 0} {
        set base 0
    }
    set cb(base) $base

    if {$cb(coff) < 0} {
	debug.zip/decode {Correction}
	set cb(base) [expr {wide($cb(base)) - 4294967296}]
	set cb(coff) [expr {wide($cb(coff)) + 4294967296}]
    }

    #--------------
    ::close $fd

    debug.zip/decode {/done = [debug nl][debug parray cb]}
    return [array get cb]
}

proc ::zipfile::decode::LocateMarker {fd marker pv av} {
    upvar 1 $pv relpos $av abspos

    # Just looking in the last 512 bytes may be enough to handle zip
    # archives without comments, however for archives which have
    # comments the chunk may start at an arbitrary distance from the
    # end of the file. So if we do not find the header immediately we
    # have to extend the range of our search, possibly until we have a
    # large part of the archive in memory. We can fail only after the
    # whole file has been searched.

    seek $fd 0 end
    set sz  [tell $fd]
    set len 512
    set at  512

    debug.zip/decode {size = [tell $fd]}

    while {1} {
	# [SF Tclvfs Bug 1003574]. Do not seek over beginning of file.
	if {$sz < $at} {set n -$sz} else {set n -$at}

	seek $fd $n end
	debug.zip/decode {checking @[tell $fd] ($len)}

	set hdr [read $fd $len]

	# We are using 'string last' as we are searching the first
	# from the end, which is the last from the beginning. See [SF
	# Bug 2256740]. A zip archive stored in a zip archive can
	# confuse the unmodified code, triggering on the magic
	# sequence for the inner, uncompressed archive.

	set pos [string last $marker $hdr]
	debug.zip/decode {marker $pos}

	if {$pos == -1} {
	    if {$at >= $sz} {
		debug.zip/decode {fail}
		return -code error "no header found"
	    }

	    # after the 1st iteration we force an overlap with last
	    # buffer to ensure that the pattern we look for is not
	    # split at a buffer boundary, nor the header itself

	    set len 540
	    incr at 512
	} else {
	    break
	}
    }

    # position just behind the just checked block -- compensate by the
    # length of the block to find its start.

    set at     [expr {wide([tell $fd])}]
    set hdrsz  [string length $hdr]



    set relpos $pos

    set abspos [expr {$at-$hdrsz+$pos}]








    if {$abspos < 0} {


	set abspos 0
    }

    debug.zip/decode {match @ $abspos = ($at - $hdrsz) + $pos}







    return $hdr
}

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

package require fileutil ; # zipdir convenience method

# ### ### ### ######### ######### #########
##

logger::initNamespace ::zipfile::encode
snit::type            ::zipfile::encode {

    # ZIP64 modi: always, never, as-required


    constructor {} {}
    destructor {}

    # ### ### ### ######### ######### #########
    ##

	$self writeEndOfCentralDir $ch $cfh $cfhsize
	close $ch
	return
    }

    # ### ### ### ######### ######### #########
    ## Comment text and map of files.
    #
    # files: dst-path -> (owned, origin-path, origin-size, creation-time, permissions)
    #   Note: Directory paths are encoded using a trailing "/" on the
    #   destination path, and an empty origin path, of size 0.

    variable comment      {}
    variable files -array {}
    variable zip64        0

    # ### ### ### ######### ######### #########
    ##

    method writeAFile {ch dst} {
	# AFile = <
	#  localfileheader

		# should we own it, then switch the upcoming copy
		# operation over to the compressed file. Which we do
		# own.

		if {$owned} {
		    file delete -force $src
		}
		set src   $temp ; # Copy the compressed temp file.
		set owned 1     ; # We own the source file now.
		set cm    8     ; # deflated
		set gpbf  2     ; # flags - deflated maximum
	    } else {
		# No space savings through compression. Throw away the
		# temp file and keep working with the original.

		file delete -force $temp

		set cm   0       ; # uncompressed
		set gpbf 0       ; # No flags
		set csize $size
	    }
	}

	# Write the local file header

	set fnlen   [string bytelength $dst]
	set offset  [tell $ch] ; # location local header, needed for central header
	set vneeded 20 ; # vnte/lsb/version = 2.0 (deflate needed)
	# ZIP64: vneeded 45

	tag      $ch 4 3
	byte     $ch $vneeded
	byte     $ch 3      ; # vnte/msb/host    = UNIX (file attributes = mode).
	short-le $ch $gpbf  ; # gpbf /deflate info
	short-le $ch $cm    ; # cm
	short-le $ch [Time $ctime] ; # lmft
	short-le $ch [Date $ctime] ; # lmfd
	long-le  $ch $crc   ; # crc32 of uncompressed file
	long-le  $ch $csize ; # compressed file size
	long-le  $ch $size  ; # uncompressed file size
	short-le $ch $fnlen ; # file name length
	short-le $ch 0      ; # extra field length, none
	str      $ch $dst   ; # file name
	# No extra field.

	# ZIP64: If activated an extra field with the correct sizes.
	# ZIP64: writeZip64FileExtension $ch <dict> osize, csize, disk, offset

	if {$csize > 0} {
	    # Copy file data over. Maybe a compressed temp. file.

	    set    in [setbinary [open $src r]]
	    fcopy $in $ch
	    close $in
	}

	# Write a data descriptor repeating crc & size info, if
	# necessary.

	## XXX BUG ? condition bogus - gpbf bit 3 must be set / never for us, see above
	if {$crc == 0} {
	    ## ZIP64 stores 8-byte file sizes, i.e long-long.

	    tag     $ch 8 7
	    long-le $ch $crc   ; # crc32
	    long-le $ch $csize ; # compressed file size
	    long-le $ch $size  ; # uncompressed file size
	}

	# Done ... We are left with admin work ...

	return
    }

    method writeCentralFileHeader {ch dst} {
	foreach {owned src size ctime attr cm gpbf csize offset crc} $files($dst) break

	set fnlen [string bytelength $dst]

	# zip64 - version needed = 4.5

	tag      $ch 2 1
	byte     $ch 20      ; # vmb/lsb/version  = 2.0
	byte     $ch 3       ; # vmb/msb/host     = UNIX (file attributes = mode).
	byte     $ch 20      ; # vnte/lsb/version = 2.0
	byte     $ch 3       ; # vnte/msb/host    = UNIX (file attributes = mode).
	short-le $ch $gpbf   ; # gpbf /deflate info

	str      $ch $dst    ; # file name
	# no extra field

	return
    }

    method writeEndOfCentralDir {ch cfhoffset cfhsize} {

	set clen   [string bytelength $comment]
	set nfiles [array size files]

	# if needed for fields in the ECD, or zip64 generally activated..
	#   ZIP64: writeZip64EndOfCentralDir $ch
	#   ZIP64: writeZip64ECDLocator $ch ?offset?

	tag      $ch 6 5
	short-le $ch 0          ; # number of this disk
	short-le $ch 0          ; # number of disk with central directory
	short-le $ch $nfiles    ; # number of files in archive
	short-le $ch $nfiles    ; # number of files in archive
	long-le  $ch $cfhsize   ; # size central directory
	long-le  $ch $cfhoffset ; # offset central dir
	short-le $ch $clen      ; # archive comment length
	if {$clen} {
	    str  $ch $comment
	}
	return
    }

    method writeZip64FileExtension {ch dict} {
	dict with $dict {}
	# osize, csize offset disk

	# Determine extension size based on elements to write
	set block 0
	if {[info exists osize]}  { incr block 8 }
	if {[info exists csize]}  { incr block 8 }
	if {[info exists offset]} { incr block 8 }
	if {[info exists disk]}   { incr block 4 }

	# Write extension header
	short-le $ch 1
	short-le $ch $block

	# Write the elements
	if {[info exists osize]}  { quad-le $ch $osize }
	if {[info exists csize]}  { quad-le $ch $csize }
	if {[info exists offset]} { quad-le $ch $offset }
	if {[info exists disk]}   { long-le $ch $disk   }
	return
    }

    method writeZip64EndOfCentralDir {ch offset} {

	#  0 long              signature 0x06 06 4b 50 == "PK" 6 6
	#  4 long-long         size of the "end of central directory record" = this.
	# 12 short             version made by
	# 14 short             version needed
	# 16 long              number of disk
	# 20 long              number of disk with start of central directory
	# 24 long-long         number of files in this disk
	# 32 long-long         number of files in whole archive
	# 40 long-long         offset of central dir with respect to starting disk
	# 48

	# (v2 fields: 28822222 -) appnote 7.3.4


	# 48 variable          zip64 extensible data sector

	# size = size without the leading 12 bytes (i.e. signature and size fields).
	# above structure is version 1

	set nfiles [array size files]

	tag      $ch 6 6
	quad-le  $ch 36 ;# 48-12 (size counted without lead fields (tag+size))
	short-le $ch 1
	short-le $ch 1
	long-le  $ch 1
	long-le  $ch 0
	quad-le  $ch $nfiles
	quad-le  $ch $nfiles
	quad-le  $ch $offset

	# extensible block =
	# short      ID
	# long       size
	# char[size] data

	# multiple extension blocks allowed, all of the format.

	# -----------------------------------------------
	# ID 0x001 zip64 extended information extra field

	# DATA
	# long-long : original size
	# long-long : compressed size
	# long-long : header offset
	# long      : disk start number
	#
	# each field appears only when signaled (*) to be required by
	# the corresponding field of the regular L/C directory entry.
	# the order is fixed as shown.
	#
	# (*) (long) -1, or (short) -1, depending on field size,
	#     i.e 0xFFFFFFFF and 0xFFFF
    }

    method writeZip64ECDLocator {ch offset} {
	# 0  long      signature 0x 07 06 4b 50 == "PK" 7 6
	# 4  long      number of disk holding the start of the ECD
	# 8  long-long relative offset of the ECD
	# 16 long      total number of disks
	# 20

	tag     $ch 7 6
	long-le $ch 0
	quad-le $ch $offset
	long-le $ch 1
	return
    }

    proc tag {ch x y} {
	byte $ch 80 ; # 'P'
	byte $ch 75 ; # 'K'
	byte $ch $y ; # \ swapped! intentional!
	byte $ch $x ; # / little-endian number.
	return
    }

    proc byte {ch x} {
	# x = 1 byte uchar
	puts -nonewline $ch [binary format c $x]
    }

    proc short-le {ch x} {
	# x = 2 byte short
	puts -nonewline $ch [binary format s $x]
    }

    proc long-le {ch x} {
	# x = 4 byte long
	puts -nonewline $ch [binary format i $x]
    }

    proc quad-le {ch x} {
	# x = 8 byte long (wideint)
	set hi [expr {($x >> 32) & 0xFFFFFFFF}]
	set lo [expr {($x      ) & 0xFFFFFFFF}]
	# lo             >>  0

	long-le $ch $lo
	long-le $ch $hi
    }

    proc str {ch text} {
	fconfigure $ch -encoding utf-8
	# write the string as utf-8 to keep its bytes, exactly.
	puts -nonewline $ch $text
	fconfigure $ch -encoding binary
	return