Check-in [91c236fce7]
Overview
Comment:Added unmodified zipvfs from tclvfs 20080503
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:91c236fce7db0f464b7c9a384a894a81be315f48
User & Date: rkeene on 2010-09-26 04:43:36
Other Links: manifest | tags
Context
2010-09-26
04:43
Added patch required to build with MingW64 check-in: 26410a9c32 user: rkeene tags: trunk
04:43
Added unmodified zipvfs from tclvfs 20080503 check-in: 91c236fce7 user: rkeene tags: trunk
04:43
Added support for using an icon and file information resource under Windows

Allow the user to place a kit.ico and kit.rc in root dir to replace one built into tclkit

Copied tclsh RC and icon as default check-in: 587e28b4b3 user: rkeene tags: trunk

Changes

Added kitsh/buildsrc/kitsh-0.0/zipvfs.tcl version [4a9165155e].

            1  +# Removed provision of the backward compatible name. Moved to separate
            2  +# file/package.
            3  +package provide vfs::zip 1.0.1
            4  +
            5  +package require vfs
            6  +
            7  +# Using the vfs, memchan and Trf extensions, we ought to be able
            8  +# to write a Tcl-only zip virtual filesystem.  What we have below
            9  +# is basically that.
           10  +
           11  +namespace eval vfs::zip {}
           12  +
           13  +# Used to execute a zip archive.  This is rather like a jar file
           14  +# but simpler.  We simply mount it and then source a toplevel
           15  +# file called 'main.tcl'.
           16  +proc vfs::zip::Execute {zipfile} {
           17  +    Mount $zipfile $zipfile
           18  +    source [file join $zipfile main.tcl]
           19  +}
           20  +
           21  +proc vfs::zip::Mount {zipfile local} {
           22  +    set fd [::zip::open [::file normalize $zipfile]]
           23  +    vfs::filesystem mount $local [list ::vfs::zip::handler $fd]
           24  +    # Register command to unmount
           25  +    vfs::RegisterMount $local [list ::vfs::zip::Unmount $fd]
           26  +    return $fd
           27  +}
           28  +
           29  +proc vfs::zip::Unmount {fd local} {
           30  +    vfs::filesystem unmount $local
           31  +    ::zip::_close $fd
           32  +}
           33  +
           34  +proc vfs::zip::handler {zipfd cmd root relative actualpath args} {
           35  +    #::vfs::log [list $zipfd $cmd $root $relative $actualpath $args]
           36  +    if {$cmd == "matchindirectory"} {
           37  +	eval [list $cmd $zipfd $relative $actualpath] $args
           38  +    } else {
           39  +	eval [list $cmd $zipfd $relative] $args
           40  +    }
           41  +}
           42  +
           43  +proc vfs::zip::attributes {zipfd} { return [list "state"] }
           44  +proc vfs::zip::state {zipfd args} {
           45  +    vfs::attributeCantConfigure "state" "readonly" $args
           46  +}
           47  +
           48  +# If we implement the commands below, we will have a perfect
           49  +# virtual file system for zip files.
           50  +
           51  +proc vfs::zip::matchindirectory {zipfd path actualpath pattern type} {
           52  +    #::vfs::log [list matchindirectory $path $actualpath $pattern $type]
           53  +
           54  +    # This call to zip::getdir handles empty patterns properly as asking
           55  +    # for the existence of a single file $path only
           56  +    set res [::zip::getdir $zipfd $path $pattern]
           57  +    #::vfs::log "got $res"
           58  +    if {![string length $pattern]} {
           59  +	if {![::zip::exists $zipfd $path]} { return {} }
           60  +	set res [list $actualpath]
           61  +	set actualpath ""
           62  +    }
           63  +
           64  +    set newres [list]
           65  +    foreach p [::vfs::matchCorrectTypes $type $res $actualpath] {
           66  +	lappend newres [file join $actualpath $p]
           67  +    }
           68  +    #::vfs::log "got $newres"
           69  +    return $newres
           70  +}
           71  +
           72  +proc vfs::zip::stat {zipfd name} {
           73  +    #::vfs::log "stat $name"
           74  +    ::zip::stat $zipfd $name sb
           75  +    #::vfs::log [array get sb]
           76  +    array get sb
           77  +}
           78  +
           79  +proc vfs::zip::access {zipfd name mode} {
           80  +    #::vfs::log "zip-access $name $mode"
           81  +    if {$mode & 2} {
           82  +	vfs::filesystem posixerror $::vfs::posix(EROFS)
           83  +    }
           84  +    # Readable, Exists and Executable are treated as 'exists'
           85  +    # Could we get more information from the archive?
           86  +    if {[::zip::exists $zipfd $name]} {
           87  +	return 1
           88  +    } else {
           89  +	error "No such file"
           90  +    }
           91  +    
           92  +}
           93  +
           94  +proc vfs::zip::open {zipfd name mode permissions} {
           95  +    #::vfs::log "open $name $mode $permissions"
           96  +    # return a list of two elements:
           97  +    # 1. first element is the Tcl channel name which has been opened
           98  +    # 2. second element (optional) is a command to evaluate when
           99  +    #    the channel is closed.
          100  +
          101  +    switch -- $mode {
          102  +	"" -
          103  +	"r" {
          104  +	    if {![::zip::exists $zipfd $name]} {
          105  +		vfs::filesystem posixerror $::vfs::posix(ENOENT)
          106  +	    }
          107  +	    
          108  +	    ::zip::stat $zipfd $name sb
          109  +
          110  +	    set nfd [vfs::memchan]
          111  +	    fconfigure $nfd -translation binary
          112  +
          113  +	    seek $zipfd $sb(ino) start
          114  +	    zip::Data $zipfd sb data
          115  +
          116  +	    puts -nonewline $nfd $data
          117  +
          118  +	    fconfigure $nfd -translation auto
          119  +	    seek $nfd 0
          120  +	    return [list $nfd]
          121  +	}
          122  +	default {
          123  +	    vfs::filesystem posixerror $::vfs::posix(EROFS)
          124  +	}
          125  +    }
          126  +}
          127  +
          128  +proc vfs::zip::createdirectory {zipfd name} {
          129  +    #::vfs::log "createdirectory $name"
          130  +    vfs::filesystem posixerror $::vfs::posix(EROFS)
          131  +}
          132  +
          133  +proc vfs::zip::removedirectory {zipfd name recursive} {
          134  +    #::vfs::log "removedirectory $name"
          135  +    vfs::filesystem posixerror $::vfs::posix(EROFS)
          136  +}
          137  +
          138  +proc vfs::zip::deletefile {zipfd name} {
          139  +    #::vfs::log "deletefile $name"
          140  +    vfs::filesystem posixerror $::vfs::posix(EROFS)
          141  +}
          142  +
          143  +proc vfs::zip::fileattributes {zipfd name args} {
          144  +    #::vfs::log "fileattributes $args"
          145  +    switch -- [llength $args] {
          146  +	0 {
          147  +	    # list strings
          148  +	    return [list]
          149  +	}
          150  +	1 {
          151  +	    # get value
          152  +	    set index [lindex $args 0]
          153  +	    return ""
          154  +	}
          155  +	2 {
          156  +	    # set value
          157  +	    set index [lindex $args 0]
          158  +	    set val [lindex $args 1]
          159  +	    vfs::filesystem posixerror $::vfs::posix(EROFS)
          160  +	}
          161  +    }
          162  +}
          163  +
          164  +proc vfs::zip::utime {fd path actime mtime} {
          165  +    vfs::filesystem posixerror $::vfs::posix(EROFS)
          166  +}
          167  +
          168  +# Below copied from TclKit distribution
          169  +
          170  +#
          171  +# ZIP decoder:
          172  +#
          173  +# Format of zip file:
          174  +# [ Data ]* [ TOC ]* EndOfArchive
          175  +#
          176  +# Note: TOC is refered to in ZIP doc as "Central Archive"
          177  +#
          178  +# This means there are two ways of accessing:
          179  +#
          180  +# 1) from the begining as a stream - until the header
          181  +#	is not "PK\03\04" - ideal for unzipping.
          182  +#
          183  +# 2) for table of contents without reading entire
          184  +#	archive by first fetching EndOfArchive, then
          185  +#	just loading the TOC
          186  +#
          187  +
          188  +namespace eval zip {
          189  +    array set methods {
          190  +	0	{stored - The file is stored (no compression)}
          191  +	1	{shrunk - The file is Shrunk}
          192  +	2	{reduce1 - The file is Reduced with compression factor 1}
          193  +	3	{reduce2 - The file is Reduced with compression factor 2}
          194  +	4	{reduce3 - The file is Reduced with compression factor 3}
          195  +	5	{reduce4 - The file is Reduced with compression factor 4}
          196  +	6	{implode - The file is Imploded}
          197  +	7	{reserved - Reserved for Tokenizing compression algorithm}
          198  +	8	{deflate - The file is Deflated}
          199  +	9	{reserved - Reserved for enhanced Deflating}
          200  +	10	{pkimplode - PKWARE Date Compression Library Imploding}
          201  +    }
          202  +    # Version types (high-order byte)
          203  +    array set systems {
          204  +	0	{dos}
          205  +	1	{amiga}
          206  +	2	{vms}
          207  +	3	{unix}
          208  +	4	{vm cms}
          209  +	5	{atari}
          210  +	6	{os/2}
          211  +	7	{macos}
          212  +	8	{z system 8}
          213  +	9	{cp/m}
          214  +	10	{tops20}
          215  +	11	{windows}
          216  +	12	{qdos}
          217  +	13	{riscos}
          218  +	14	{vfat}
          219  +	15	{mvs}
          220  +	16	{beos}
          221  +	17	{tandem}
          222  +	18	{theos}
          223  +    }
          224  +    # DOS File Attrs
          225  +    array set dosattrs {
          226  +	1	{readonly}
          227  +	2	{hidden}
          228  +	4	{system}
          229  +	8	{unknown8}
          230  +	16	{directory}
          231  +	32	{archive}
          232  +	64	{unknown64}
          233  +	128	{normal}
          234  +    }
          235  +
          236  +    proc u_short {n}  { return [expr { ($n+0x10000)%0x10000 }] }
          237  +}
          238  +
          239  +proc zip::DosTime {date time} {
          240  +    set time [u_short $time]
          241  +    set date [u_short $date]
          242  +
          243  +    # time = fedcba9876543210
          244  +    #        HHHHHmmmmmmSSSSS (sec/2 actually)
          245  +
          246  +    # data = fedcba9876543210
          247  +    #        yyyyyyyMMMMddddd
          248  +
          249  +    set sec  [expr { ($time & 0x1F) * 2 }]
          250  +    set min  [expr { ($time >> 5) & 0x3F }]
          251  +    set hour [expr { ($time >> 11) & 0x1F }]
          252  +
          253  +    set mday [expr { $date & 0x1F }]
          254  +    set mon  [expr { (($date >> 5) & 0xF) }]
          255  +    set year [expr { (($date >> 9) & 0xFF) + 1980 }]
          256  +
          257  +    # Fix up bad date/time data, no need to fail
          258  +    while {$sec  > 59} {incr sec  -60}
          259  +    while {$min  > 59} {incr sec  -60}
          260  +    while {$hour > 23} {incr hour -24}
          261  +    if {$mday < 1}  {incr mday}
          262  +    if {$mon  < 1}  {incr mon}
          263  +    while {$mon > 12} {incr hour -12}
          264  +
          265  +    while {[catch {
          266  +	set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \
          267  +		    $year $mon $mday $hour $min $sec]
          268  +	set res [clock scan $dt -gmt 1]
          269  +    }]} {
          270  +	# Only mday can be wrong, at end of month
          271  +	incr mday -1
          272  +    }
          273  +    return $res
          274  +}
          275  +
          276  +
          277  +proc zip::Data {fd arr {varPtr ""} {verify 0}} {
          278  +    upvar 1 $arr sb
          279  +
          280  +    if { $varPtr != "" } {
          281  +	upvar 1 $varPtr data
          282  +    }
          283  +
          284  +    set buf [read $fd 30]
          285  +    set n [binary scan $buf A4sssssiiiss \
          286  +		hdr sb(ver) sb(flags) sb(method) \
          287  +		time date \
          288  +		sb(crc) sb(csize) sb(size) flen elen]
          289  +
          290  +    if { ![string equal "PK\03\04" $hdr] } {
          291  +	binary scan $hdr H* x
          292  +	error "bad header: $x"
          293  +    }
          294  +    set sb(ver)		[u_short $sb(ver)]
          295  +    set sb(flags)	[u_short $sb(flags)]
          296  +    set sb(method)	[u_short $sb(method)]
          297  +    set sb(mtime)	[DosTime $date $time]
          298  +
          299  +    set sb(name) [read $fd [u_short $flen]]
          300  +    set sb(extra) [read $fd [u_short $elen]]
          301  +
          302  +    if { $varPtr == "" } {
          303  +	seek $fd $sb(csize) current
          304  +    } else {
          305  +	# Added by Chuck Ferril 10-26-03 to fix reading of OpenOffice
          306  +	#  .sxw files. Any files in the zip that had a method of 8
          307  +	#  (deflate) failed here because size and csize were zero.
          308  +	#  I'm not sure why the above computes the size and csize
          309  +	#  wrong, but stat appears works properly. I originally
          310  +	#  checked for csize of zero, but adding this change didn't
          311  +	#  appear to break the none deflated file access and seemed
          312  +	#  more natural.
          313  + 	zip::stat $fd $sb(name) sb
          314  +
          315  +	set data [read $fd $sb(csize)]
          316  +    }
          317  +
          318  +    if { $sb(flags) & 0x4 } {
          319  +	# Data Descriptor used
          320  +	set buf [read $fd 12]
          321  +	binary scan $buf iii sb(crc) sb(csize) sb(size)
          322  +    }
          323  +
          324  +
          325  +    if { $varPtr == "" } {
          326  +	return ""
          327  +    }
          328  +
          329  +    if { $sb(method) != 0 } {
          330  +	if { [catch {
          331  +	    set data [vfs::zip -mode decompress -nowrap 1 $data]
          332  +	} err] } {
          333  +	    ::vfs::log "$sb(name): inflate error: $err"
          334  +	    binary scan $data H* x
          335  +	    ::vfs::log $x
          336  +	}
          337  +    }
          338  +    return
          339  +    if { $verify } {
          340  +	set ncrc [vfs::crc $data]
          341  +	if { $ncrc != $sb(crc) } {
          342  +	    tclLog [format {%s: crc mismatch: expected 0x%x, got 0x%x} \
          343  +		    $sb(name) $sb(crc) $ncrc]
          344  +	}
          345  +    }
          346  +}
          347  +
          348  +proc zip::EndOfArchive {fd arr} {
          349  +    upvar 1 $arr cb
          350  +
          351  +    # [SF Tclvfs Bug 1003574]. Do not seek over beginning of file.
          352  +    seek $fd 0 end
          353  +
          354  +    # Just looking in the last 512 bytes may be enough to handle zip
          355  +    # archives without comments, however for archives which have
          356  +    # comments the chunk may start at an arbitrary distance from the
          357  +    # end of the file. So if we do not find the header immediately
          358  +    # we have to extend the range of our search, possibly until we
          359  +    # have a large part of the archive in memory. We can fail only
          360  +    # after the whole file has been searched.
          361  +
          362  +    set sz  [tell $fd]
          363  +    set len 512
          364  +    set at  512
          365  +    while {1} {
          366  +	if {$sz < $at} {set n -$sz} else {set n -$at}
          367  +
          368  +	seek $fd $n end
          369  +	set hdr [read $fd $len]
          370  +	set pos [string first "PK\05\06" $hdr]
          371  +	if {$pos == -1} {
          372  +	    if {$at >= $sz} {
          373  +		return -code error "no header found"
          374  +	    }
          375  +	    set len 540 ; # after 1st iteration we force overlap with last buffer
          376  +	    incr at 512 ; # to ensure that the pattern we look for is not split at
          377  +	    #           ; # a buffer boundary, nor the header itself
          378  +	} else {
          379  +	    break
          380  +	}
          381  +    }
          382  +
          383  +    set hdr [string range $hdr [expr $pos + 4] [expr $pos + 21]]
          384  +    set pos [expr [tell $fd] + $pos - 512]
          385  +
          386  +    binary scan $hdr ssssiis \
          387  +	cb(ndisk) cb(cdisk) \
          388  +	cb(nitems) cb(ntotal) \
          389  +	cb(csize) cb(coff) \
          390  +	cb(comment)
          391  +
          392  +    set cb(ndisk)	[u_short $cb(ndisk)]
          393  +    set cb(nitems)	[u_short $cb(nitems)]
          394  +    set cb(ntotal)	[u_short $cb(ntotal)]
          395  +    set cb(comment)	[u_short $cb(comment)]
          396  +
          397  +    # Compute base for situations where ZIP file
          398  +    # has been appended to another media (e.g. EXE)
          399  +    set cb(base)	[expr { $pos - $cb(csize) - $cb(coff) }]
          400  +}
          401  +
          402  +proc zip::TOC {fd arr} {
          403  +    upvar 1 $arr sb
          404  +
          405  +    set buf [read $fd 46]
          406  +
          407  +    binary scan $buf A4ssssssiiisssssii hdr \
          408  +      sb(vem) sb(ver) sb(flags) sb(method) time date \
          409  +      sb(crc) sb(csize) sb(size) \
          410  +      flen elen clen sb(disk) sb(attr) \
          411  +      sb(atx) sb(ino)
          412  +
          413  +    if { ![string equal "PK\01\02" $hdr] } {
          414  +	binary scan $hdr H* x
          415  +	error "bad central header: $x"
          416  +    }
          417  +
          418  +    foreach v {vem ver flags method disk attr} {
          419  +	set cb($v) [u_short [set sb($v)]]
          420  +    }
          421  +
          422  +    set sb(mtime) [DosTime $date $time]
          423  +    set sb(mode) [expr { ($sb(atx) >> 16) & 0xffff }]
          424  +    if { ( $sb(atx) & 0xff ) & 16 } {
          425  +	set sb(type) directory
          426  +    } else {
          427  +	set sb(type) file
          428  +    }
          429  +    set sb(name) [read $fd [u_short $flen]]
          430  +    set sb(extra) [read $fd [u_short $elen]]
          431  +    set sb(comment) [read $fd [u_short $clen]]
          432  +}
          433  +
          434  +proc zip::open {path} {
          435  +    set fd [::open $path]
          436  +    
          437  +    if {[catch {
          438  +	upvar #0 zip::$fd cb
          439  +	upvar #0 zip::$fd.toc toc
          440  +
          441  +	fconfigure $fd -translation binary ;#-buffering none
          442  +	
          443  +	zip::EndOfArchive $fd cb
          444  +
          445  +	seek $fd $cb(coff) start
          446  +
          447  +	set toc(_) 0; unset toc(_); #MakeArray
          448  +	
          449  +	for { set i 0 } { $i < $cb(nitems) } { incr i } {
          450  +	    zip::TOC $fd sb
          451  +	    
          452  +	    set sb(depth) [llength [file split $sb(name)]]
          453  +	    
          454  +	    set name [string tolower $sb(name)]
          455  +	    set toc($name) [array get sb]
          456  +	    FAKEDIR toc [file dirname $name]
          457  +	}
          458  +    } err]} {
          459  +	close $fd
          460  +	return -code error $err
          461  +    }
          462  +
          463  +    return $fd
          464  +}
          465  +
          466  +proc zip::FAKEDIR {arr path} {
          467  +    upvar 1 $arr toc
          468  +
          469  +    if { $path == "."} { return }
          470  +
          471  +
          472  +    if { ![info exists toc($path)] } {
          473  +	# Implicit directory
          474  +	lappend toc($path) \
          475  +		name $path \
          476  +		type directory mtime 0 size 0 mode 0777 \
          477  +		ino -1 depth [llength [file split $path]]
          478  +    }
          479  +    FAKEDIR toc [file dirname $path]
          480  +}
          481  +
          482  +proc zip::exists {fd path} {
          483  +    #::vfs::log "$fd $path"
          484  +    if {$path == ""} {
          485  +	return 1
          486  +    } else {
          487  +	upvar #0 zip::$fd.toc toc
          488  +	info exists toc([string tolower $path])
          489  +    }
          490  +}
          491  +
          492  +proc zip::stat {fd path arr} {
          493  +    upvar #0 zip::$fd.toc toc
          494  +    upvar 1 $arr sb
          495  +
          496  +    set name [string tolower $path]
          497  +    if { $name == "" || $name == "." } {
          498  +	array set sb {
          499  +	    type directory mtime 0 size 0 mode 0777 
          500  +	    ino -1 depth 0 name ""
          501  +	}
          502  +    } elseif {![info exists toc($name)] } {
          503  +	return -code error "could not read \"$path\": no such file or directory"
          504  +    } else {
          505  +	array set sb $toc($name)
          506  +    }
          507  +    set sb(dev) -1
          508  +    set sb(uid)	-1
          509  +    set sb(gid)	-1
          510  +    set sb(nlink) 1
          511  +    set sb(atime) $sb(mtime)
          512  +    set sb(ctime) $sb(mtime)
          513  +    return ""
          514  +}
          515  +
          516  +# Treats empty pattern as asking for a particular file only
          517  +proc zip::getdir {fd path {pat *}} {
          518  +    #::vfs::log [list getdir $fd $path $pat]
          519  +    upvar #0 zip::$fd.toc toc
          520  +
          521  +    if { $path == "." || $path == "" } {
          522  +	set path [string tolower $pat]
          523  +    } else {
          524  +	set path [string tolower $path]
          525  +	if {$pat != ""} {
          526  +	    append path /[string tolower $pat]
          527  +	}
          528  +    }
          529  +    set depth [llength [file split $path]]
          530  +
          531  +    #puts stderr "getdir $fd $path $depth $pat [array names toc $path]"
          532  +    if {$depth} {
          533  +	set ret {}
          534  +	foreach key [array names toc $path] {
          535  +	    if {[string index $key end] == "/"} {
          536  +		# Directories are listed twice: both with and without
          537  +		# the trailing '/', so we ignore the one with
          538  +		continue
          539  +	    }
          540  +	    array set sb $toc($key)
          541  +
          542  +	    if { $sb(depth) == $depth } {
          543  +		if {[info exists toc(${key}/)]} {
          544  +		    array set sb $toc(${key}/)
          545  +		}
          546  +		lappend ret [file tail $sb(name)]
          547  +	    } else {
          548  +		#::vfs::log "$sb(depth) vs $depth for $sb(name)"
          549  +	    }
          550  +	    unset sb
          551  +	}
          552  +	return $ret
          553  +    } else {
          554  +	# just the 'root' of the zip archive.  This obviously exists and
          555  +	# is a directory.
          556  +	return [list {}]
          557  +    }
          558  +}
          559  +
          560  +proc zip::_close {fd} {
          561  +    variable $fd
          562  +    variable $fd.toc
          563  +    unset $fd
          564  +    unset $fd.toc
          565  +    ::close $fd
          566  +}