Tcl Library Source Code: decode.tcl at tip

File modules/zip/decode.tcl from the latest check-in

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Copyright (c) 2008-2012 ActiveState Software Inc., Andreas Kupries
##               2016-2022 Andreas Kupries
## BSD License
##
# Package providing commands for the decoding of basic zip-file
# structures.

package require Tcl 8.5 9
package require fileutil::decode 0.2.1    ; # Framework for easy decoding of files.
namespace eval ::zipfile::decode {}
if {[package vcompare $tcl_patchLevel "8.6"] < 0} {
  # Only needed pre-8.6
  package require Trf                       ; # Wrapper to zlib
  package require zlibtcl                   ; # Zlib usage. No commands, access through Trf
  set ::zipfile::decode::native_zip_functs 0
} else {
  set ::zipfile::decode::native_zip_functs 1
}
namespace eval ::zipfile::decode {
    namespace import ::fileutil::decode::*
}

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

proc ::zipfile::decode::unzipfile {in out} {
    zipfile::decode::open  $in
    set                     zd [zipfile::decode::archive]
    zipfile::decode::unzip $zd $out
    zipfile::decode::close
    return
}

## Convenience command, decode and return list of contained paths.
proc ::zipfile::decode::content {in} {
    zipfile::decode::open $in
    set zd [zipfile::decode::archive]
    set f [files $zd]
    zipfile::decode::close
    return $f
}

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

proc ::zipfile::decode::iszip {fname} {
    if {[catch {
	LocateEnd $fname
    } msg]} {
	return 0
    }
    return 1
}

proc ::zipfile::decode::open {fname} {
    variable eoa
    if {[catch {
	set eoa [LocateEnd $fname]
    } msg]} {
	Error "\"$fname\" is not a zip file" BAD ARCHIVE
    }
    fileutil::decode::open $fname
    return
}

proc ::zipfile::decode::close {} {
    variable eoa
    unset eoa
    fileutil::decode::close
    return
}

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

proc ::zipfile::decode::comment {zdict} {
    array set _ $zdict
    return $_(comment)
}

proc ::zipfile::decode::files {zdict} {
    array set _ $zdict
    array set f $_(files)
    return [array names f]
}


proc ::zipfile::decode::filelocations zdict {
    set res {}
    foreach {fname finfo} [dict get $zdict files] {
	set start [dict get $finfo fileloc]
	set size [dict get $finfo csize]
	lappend res $start $size $fname
    }
    set res [lsort -stride 3 -index 0 -integer $res[set res {}]]
    return $res
}

proc ::zipfile::decode::hasfile {zdict fname} {
    array set _ $zdict
    array set f $_(files)
    return [info exists f($fname)]
}

proc ::zipfile::decode::copyfile {zdict src dst} {
    array set _ $zdict
    array set f $_(files)

    if {![info exists f($src)]} {
	Error "File \"$src\" not known" BAD PATH
    }

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

proc ::zipfile::decode::getfile {zdict src} {
    array set _ $zdict
    array set f $_(files)

    if {![info exists f($src)]} {
	Error "File \"$src\" not known" BAD PATH
    }

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

proc ::zipfile::decode::filesize {zdict src} {
    array set _ $zdict
    array set f $_(files)

    if {![info exists f($src)]} {
	Error "File \"$src\" not known" BAD PATH
    }

    array set fd $f($src)
    return $fd(ucsize)
}

proc ::zipfile::decode::filecomment {zdict src} {
    array set _ $zdict
    array set f $_(files)

    if {![info exists f($src)]} {
	Error "File \"$src\" not known" BAD PATH
    }

    array set fd $f($src)
    return $fd(comment)
}

proc ::zipfile::decode::unzip {zdict dst} {
    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} {
    upvar 1 $fdv fd

    file mkdir [file dirname $dst]

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

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

    if {$fd(ucsize) == 0} {
	::close [::open $dst w] ; # touch
	return
    }

    # non-empty files, work depends on type of compression.

    switch -exact -- $fd(cm) {
	uncompressed {
	    go     $fd(fileloc)
	    nbytes $fd(csize)

	    set out [::open $dst wb]
	    puts -nonewline $out [getval]
	    ::close $out
	}
	deflate {
	    go     $fd(fileloc)
	    nbytes $fd(csize)

	    set out [::open $dst wb]
            if {$::zipfile::decode::native_zip_functs} {
              puts -nonewline $out \
		[zlib inflate [getval]]
            } else {
              puts -nonewline $out \
		[zip -mode decompress -nowrap 1 -- \
		     [getval]]
            }
	    ::close $out
	}
	default {
	    Error "Unable to handle file \"$src\" compressed with method \"$fd(cm)\"" \
		BAD COMPRESSION
	}
    }

    if {
	($::tcl_platform(platform) ne "windows") &&
	($fd(efattr) != 0)
    } {
	# On unix take the permissions encoded in the external
	# attributes and apply them to the new file. If there are
	# permission. A value of 0 indicates an older teabag where
	# the encoder did not yet support permissions. These we do not
	# change from the sustem defaults. Permissions are in the
	# lower 9 bits of the MSW.

	file attributes $dst -permissions \
	    [string map {0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx} \
		 [format %03o [expr {($fd(efattr) >> 16) & 0x1ff}]]]
    }

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

    return
}

proc ::zipfile::decode::GetFile {src fdv} {
    # See also CopyFile for similar code.
    # TODO: Check with CopyFile for refactoring opportunity

    upvar 1 $fdv fd

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

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

    if {$fd(ucsize) == 0} {return {}}

    # non-empty files, work depends on type of compression.

    switch -exact -- $fd(cm) {
	uncompressed {
	    go     $fd(fileloc)
	    nbytes $fd(csize)
	    return [getval]
	}
	deflate {
	    go     $fd(fileloc)
	    nbytes $fd(csize)
	    if {$::zipfile::decode::native_zip_functs} {
		return [zlib inflate [getval]]
	    } else {
		return [zip -mode decompress -nowrap 1 -- [getval]]
	    }
	}
	default {
	    Error "Unable to handle file \"$src\" compressed with method \"$fd(cm)\"" \
		BAD COMPRESSION
	}
    }

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

    return {}
}

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

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

proc ::zipfile::decode::localfileheader {} {
    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
    short-le ; unsigned ;              put lmft      ; # last mod file time
    short-le ; unsigned ;              put lmfd      ; # last mod file date
    long-le  ; unsigned ;              put crc       ; # crc32                  | zero's here imply non-seekable,
    long-le  ; unsigned ;              put csize     ; # compressed file size   | data is in a DDS behind the stored
    long-le  ; unsigned ;              put ucsize    ; # uncompressed file size | file.
    short-le ; unsigned ;              put fnamelen  ; # file name length
    short-le ; unsigned ;              put efieldlen ; # extra field length

    array set hdr [get]
    clear

    nbytes $hdr(fnamelen) ; put fname
    putloc                      efieldloc
    skip $hdr(efieldlen)
    putloc                      fileloc

    array set hdr [get]
    clear

    set hdr(gpbf) [GPBF $hdr(gpbf) $hdr(cm)]
    setbuf [array get hdr]
    return 1
}

proc ::zipfile::decode::centralfileheader {} {
    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.

    clear
    short-le ; unsigned ; recode VER ; put vmb         ; # ++ version made by
    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
    short-le ; unsigned ;              put lmft        ; #    last mod file time
    short-le ; unsigned ;              put lmfd        ; #    last mod file date
    long-le  ; unsigned ;              put crc         ; #    crc32                  | zero's here imply non-seekable,
    long-le  ; unsigned ;              put csize       ; #    compressed file size   | data is in a DDS behind the stored
    long-le  ; unsigned ;              put ucsize      ; #    uncompressed file size | file.
    short-le ; unsigned ;              put fnamelen    ; #    file name length
    short-le ; unsigned ;              put efieldlen2  ; #    extra field length
    short-le ; unsigned ;              put fcommentlen ; # ++ file comment length
    short-le ; unsigned ;              put dns         ; # ++ disk number start
    short-le ; unsigned ; recode IFA ; put ifattr      ; # ++ internal file attributes
    long-le  ; unsigned ;              put efattr      ; # ++ external file attributes
    long-le  ; unsigned ;              put localloc    ; # ++ relative offset of local file header

    array set hdr [get]
    clear

    nbytes $hdr(fnamelen)    ; put fname
    putloc                         efieldloc2
    skip $hdr(efieldlen2)
    nbytes $hdr(fcommentlen) ; put comment

    array set hdr [get]
    clear

    set hdr(gpbf) [GPBF $hdr(gpbf) $hdr(cm)]
    setbuf [array get hdr]
    return 1
}

## NOT USED
proc ::zipfile::decode::datadescriptor {} {
    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 {} {
    clear
    putloc ecdloc
    if {![tag 0605]} {clear ; return 0}

    short-le ; unsigned ; put nd         ; #
    short-le ; unsigned ; put ndscd      ; #
    short-le ; unsigned ; put tnecdd     ; #
    short-le ; unsigned ; put tnecd      ; #
    long-le  ; unsigned ; put sizecd     ; #
    long-le  ; unsigned ; put ocd        ; #
    short-le ; unsigned ; put commentlen ; # archive comment length

    array set hdr [get] ; clear

    nbytes $hdr(commentlen) ; put comment

    array set hdr [get] ; clear

    setbuf [array get hdr]
    return 1
}

## NOT USED
proc ::zipfile::decode::afile {} {
    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).
	# In both cases we can skip the file contents directly.
	# In both cases there should be no data descriptor behind
	# we contents, but we check nevertheless. If there is its
	# data overrides the current size and crc info.

	skip $hdr(csize)

	if {[datadescriptor]} {
	    array set hdr [get]
	    set hdr(ddpresent) 1
	    setbuf [array get hdr]
	}
    } else {
	Error "Search data descriptor. Not Yet Implemented" INCOMPLETE
    }
    return 1
}

proc ::zipfile::decode::archive {} {
    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)}]

    array set fn {}

    set nentries 0
    while {[centralfileheader]} {
	array set _ [set data [get]] ; clear

	#parray _

	# Use the information found in the CFH entry to locate and
	# read the associated LFH. We explicitly remember where we are
	# in the file because mark/rewind is only one level and the
	# LFH command already used that up.

	set here [at]
	go [expr {$cb(base) + $_(localloc)}]
	if {![localfileheader]} {
	    ArchiveError "Directory entry without file." DIR WITHOUT FILE
	}

	array set lh [get] ; clear
	go $here

	# Compare the information in the CFH entry and associated
	# LFH. Should match.

	if {![hdrmatch lh _]} {
	    ArchiveError "File/Dir Header mismatch." HEADER MISMATCH FILE/DIR
	}

	# Merge local and central data.
	array set lh $data

	set fn($_(fname)) [array get lh]
	unset lh _
	incr nentries
    }

    if {![endcentralfiledir]} {
	ArchiveError "Bad closure." BAD CLOSURE
    }

    array set _ [get] ; clear

    #parray _
    #puts \#$nentries

    if {$nentries != $_(tnecd)} {
	ArchiveError "\#Files ($_(tnecd)) does not match \#Actual files ($nentries)" \
	    MISMATCH COUNTS
    }

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

proc ::zipfile::decode::hdrmatch {lhv chv} {
    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 {[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)} {return 0}
	}
    }

    return 1
}


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

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

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

namespace eval ::zipfile::decode {
    variable  vhost
    array set vhost {
	0  FAT		1  Amiga
	2  VMS		3  Unix
	4  VM/CMS	5  Atari
	6  HPFS		7  Macintosh
	8  Z-System	9  CP/M
	10 TOPS-20	11 NTFS
	12 SMS/QDOS	13 {Acorn RISC OS}
	14 VFAT		15 MVS
	16 BeOS		17 Tandem
    }
}

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

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

    return [list $vhost($u) ${major}.$minor]
}

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

namespace eval ::zipfile::decode {
    variable  cm
    array set cm {
	0  uncompressed	1  shrink
	2  {reduce 1}	3  {reduce 2}
	4  {reduce 3}	5  {reduce 4}
	6  implode	7  reserved
	8  deflate	9  reserved
	10 implode-pkware-dcl
    }
}

proc ::zipfile::decode::CM {v} {
    variable cm
    return $cm($v)
}

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

namespace eval ::zipfile::decode {
    variable  gbits
    array set gbits {
	0,1         encrypted
	1,0,implode 4k-window
	1,1,implode 8k-window
	2,0,implode 2fano
	2,1,implode 3fano
	3,1         dd
	5,1         patched

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

proc ::zipfile::decode::GPBF {v cm} {
    variable gbits
    set res {}

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

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

    set bit 0
    while {$v > 0} {
	set odd [expr {$v % 2 == 1}]
	if {[info exists gbits($bit,$odd,$cm)]} {
	    lappend res $gbits($bit,$odd,$cm)
	} elseif {[info exists gbits($bit,$odd)]} {
	    lappend res $gbits($bit,$odd)
	}
	set v [expr {$v >> 1}]
	incr bit
    }

    return $res
}

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

proc ::zipfile::decode::ArchiveError {msg args} {
    # Inlined "Error" -- Avoided eval/linsert dance
    set code [linsert $args 0 ZIP DECODE BAD ARCHIVE]
    return -code error -errorcode $code  "Bad zip file. $msg"
}

proc ::zipfile::decode::Error {msg args} {
    set code [linsert $args 0 ZIP DECODE]
    return -code error -errorcode $code $msg
}

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

## 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} {
    if {[set code [catch {
	LocateEndCore $path fd
    } result]]} {
	::close $fd
	return -code $code $result
    }
    return $result
}

proc ::zipfile::decode::LocateEndCore {path fdv} {
    upvar 1 $fdv fd
    set fd [::open $path r]
    fconfigure $fd -translation binary ;#-buffering none

    array set cb {}

    # [SF Tclvfs Bug 1003574]. Do not seek over beginning of file.
    seek $fd 0 end

    # 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.

    set sz  [tell $fd]
    set len 512
    set at  512
    while {1} {
	if {$sz < $at} {set n -$sz} else {set n -$at}

	seek $fd $n end
	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]
	if {$pos == -1} {
	    if {$at >= $sz} {
		ArchiveError "No header found" HEADER MISSING
	    }

	    # 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
	}
    }

    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]
}

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