Index: modules/fileutil/decode.tcl ================================================================== --- modules/fileutil/decode.tcl +++ modules/fileutil/decode.tcl @@ -5,100 +5,155 @@ ## BSD License ## # Package to help the writing of file decoders. Provides generic # low-level support commands. -package require Tcl 8.4 +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 } @@ -105,64 +160,78 @@ # ### ### ### ######### ######### ######### ## 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} {return 1} + 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 } @@ -185,7 +254,7 @@ variable buf {} } # ### ### ### ######### ######### ######### ## Ready -package provide fileutil::decode 0.2 +package provide fileutil::decode 0.3 return Index: modules/fileutil/pkgIndex.tcl ================================================================== --- modules/fileutil/pkgIndex.tcl +++ modules/fileutil/pkgIndex.tcl @@ -5,6 +5,6 @@ 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.2 [list source [file join $dir decode.tcl]] +package ifneeded fileutil::decode 0.3 [list source [file join $dir decode.tcl]] Index: modules/zip/decode.tcl ================================================================== --- modules/zip/decode.tcl +++ modules/zip/decode.tcl @@ -5,83 +5,111 @@ ## BSD License ## # Package providing commands for the decoding of basic zip-file # structures. -package require Tcl 8.4 +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" + "\"$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} \ @@ -92,10 +120,12 @@ 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} \ @@ -105,10 +135,12 @@ 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) @@ -118,10 +150,11 @@ } return } proc ::zipfile::decode::CopyFile {src fdv dst} { + debug.zip/decode {} upvar 1 $fdv fd file mkdir [file dirname $dst] if {[string match */ $src]} { @@ -188,10 +221,11 @@ return } proc ::zipfile::decode::GetFile {src fdv} { + debug.zip/decode {} upvar 1 $fdv fd # Entry is a directory. if {[string match */ $src]} {return {}} @@ -227,16 +261,18 @@ # ### ### ### ######### ######### ######### ## 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 @@ -260,15 +296,18 @@ 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 @@ -303,16 +342,19 @@ 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 @@ -320,10 +362,11 @@ return 1 } proc ::zipfile::decode::endcentralfiledir {} { + debug.zip/decode {} clear putloc ecdloc if {![tag 0605]} {clear ; return 0} short-le ; unsigned ; put nd ; # @@ -344,10 +387,11 @@ 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 @@ -371,10 +415,12 @@ } 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'. @@ -436,20 +482,24 @@ 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)} {return 0} + 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. @@ -457,11 +507,14 @@ # known at the time of writing. foreach key { crc csize ucsize } { - if {$lh($key) != $ch($key)} {return 0} + if {$lh($key) != $ch($key)} { + debug.zip/decode {mismatch $key ($lh($key) != $ch($key))} + return 0 + } } } return 1 } @@ -469,10 +522,11 @@ # ### ### ### ######### ######### ######### ## proc ::zipfile::decode::IFA {v} { + debug.zip/decode {} if {$v & 0x1} { return text } else { return binary } @@ -495,10 +549,11 @@ 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}] @@ -521,10 +576,11 @@ 10 implode-pkware-dcl } } proc ::zipfile::decode::CM {v} { + debug.zip/decode {} variable cm return $cm($v) } # ### ### ### ######### ######### ######### @@ -547,10 +603,11 @@ 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 @@ -579,44 +636,147 @@ ## 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 {} - # [SF Tclvfs Bug 1003574]. Do not seek over beginning of file. - seek $fd 0 end + # 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 "PK\05\06" $hdr] + 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 @@ -627,44 +787,23 @@ } else { break } } - set hdrlen [string length $hdr] - set hdr [string range $hdr [expr {$pos + 4}] [expr {$pos + 21}]] - set pos [expr {wide([tell $fd]) + $pos - $hdrlen}] - - if {$pos < 0} { - set pos 0 - } - - binary scan $hdr ssssiis _ _ _ _ cb(csize) cb(coff) _ - - # Compute base for situations where 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. (-> pos) - # (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 { $pos - $cb(csize) - $cb(coff) }] - if {$base < 0} { - set base 0 - } - set cb(base) $base - - if {$cb(coff) < 0} { - set cb(base) [expr {wide($cb(base)) - 4294967296}] - set cb(coff) [expr {wide($cb(coff)) + 4294967296}] - } - - #-------------- - ::close $fd - return [array get cb] + # 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 Index: modules/zip/encode.tcl ================================================================== --- modules/zip/encode.tcl +++ modules/zip/encode.tcl @@ -19,10 +19,13 @@ # ### ### ### ######### ######### ######### ## logger::initNamespace ::zipfile::encode snit::type ::zipfile::encode { + + # ZIP64 modi: always, never, as-required + constructor {} {} destructor {} # ### ### ### ######### ######### ######### @@ -95,14 +98,19 @@ 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} { @@ -151,11 +159,11 @@ # own. if {$owned} { file delete -force $src } - set src $temp ; # Copy the copressed temp file. + 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 @@ -169,15 +177,17 @@ } } # Write the local file header - set fnlen [string bytelength $dst] - set offset [tell $ch] ; # location local header, needed for central 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 20 ; # vnte/lsb/version = 2.0 (deflate needed) + 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 @@ -187,10 +197,13 @@ 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 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 @@ -198,11 +211,14 @@ } # 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 } @@ -223,10 +239,12 @@ 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 @@ -252,13 +270,16 @@ 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 @@ -269,10 +290,104 @@ 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! @@ -279,20 +394,33 @@ 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