TclVFS

2011-04-28  Steve Huntley  <[email protected]>

	* zipvfs.tcl: Added contributed patch to speed up zipvfs directory 
	listing.  See patch 3279418.

2011-03-30  Steve Huntley  <[email protected]>

	* vfslib.tcl, zipvfs.tcl: Added contributed patches to fix bugs 3160686
	& 3224057.

2011-03-30  Steve Huntley  <[email protected]>

	set cb(base) [expr {wide($cb(base)) - 4294967296}]
	set cb(coff) [expr {wide($cb(coff)) + 4294967296}]
    }
}

proc zip::TOC {fd arr} {
    upvar #0 zip::$fd cb
    upvar #0 zip::$fd.dir cbdir
    upvar 1 $arr sb

    set buf [read $fd 46]

    binary scan $buf A4ssssssiiisssssii hdr \
      sb(vem) sb(ver) sb(flags) sb(method) time date \
      sb(crc) sb(csize) sb(size) \

	set sb(ino) [expr {wide($sb(ino)) + 4294967296}]
    }
    if {$sb(flags) & (1 << 11)} {
        set sb(name) [encoding convertfrom utf-8 $sb(name)]
        set sb(comment) [encoding convertfrom utf-8 $sb(comment)]
    }
    set sb(name) [string trimleft $sb(name) "./"]
    set parent [file dirname $sb(name)]
    if {$parent == "."} {set parent ""}
    lappend cbdir([string tolower $parent]) [file tail [string trimright $sb(name) /]]
}

proc zip::open {path} {
    #vfs::log [list open $path]
    set fd [::open $path]
    
    if {[catch {
	upvar #0 zip::$fd cb
	upvar #0 zip::$fd.toc toc
	upvar #0 zip::$fd.dir cbdir

	fconfigure $fd -translation binary ;#-buffering none
	
	zip::EndOfArchive $fd cb

	seek $fd [expr {$cb(base) + $cb(coff)}] start

	set toc(_) 0; unset toc(_); #MakeArray
	
	for {set i 0} {$i < $cb(nitems)} {incr i} {
	    zip::TOC $fd sb
	    
	    set sb(depth) [llength [file split $sb(name)]]
	    
	    set name [string trimright [string tolower $sb(name)] /]
	    set sba [array get sb]
	    set toc($name) $sba
	    FAKEDIR toc cbdir [file dirname $name]
	}
	foreach {n v} [array get cbdir] {
	    set cbdir($n) [lsort -unique $v]
	}
    } err]} {
	close $fd
	return -code error $err
    }

    return $fd
}

proc zip::FAKEDIR {tocarr cbdirarr path} {
    upvar 1 $tocarr toc $cbdirarr cbdir

    if { $path == "."} { return }


    if { ![info exists toc($path)] } {
	# Implicit directory
	lappend toc($path) \
		name $path \
		type directory mtime 0 size 0 mode 0777 \
		ino -1 depth [llength [file split $path]]
	
	set parent [file dirname $path]
	if {$parent == "."} {set parent ""}
	lappend cbdir($parent) [file tail $path]
    }
    FAKEDIR toc cbdir [file dirname $path]
}

proc zip::exists {fd path} {
    #::vfs::log "$fd $path"
    if {$path == ""} {
	return 1
    } else {

    return ""
}

# Treats empty pattern as asking for a particular file only
proc zip::getdir {fd path {pat *}} {
    #::vfs::log [list getdir $fd $path $pat]
    upvar #0 zip::$fd.toc toc
    upvar #0 zip::$fd.dir cbdir

    if { $path == "." || $path == "" } {
	set path ""
    }  else  {

	set path [string tolower $path]
    }

    if {$pat == ""} {
	if {[info exists cbdir($path)]} {
	    return [list $path]
	}  else  {
	    return [list]
	}
    }



    set rc [list]
    if {[info exists cbdir($path)]} {
	if {$pat == "*"} {
	    set rc $cbdir($path)
	}  else  {
	    foreach f $cbdir($path) {
		if {[string match -nocase $pat $f]} {




		    lappend rc $f
		}



	    }



	}

    }
    return $rc





}

proc zip::_close {fd} {
    variable $fd
    variable $fd.toc
    variable $fd.dir
    unset $fd
    unset $fd.toc
    unset $fd.dir
    ::close $fd
}

# Implementation of stream based decompression for zip
if {([info commands ::rechan] != "") || ([info commands ::chan] != "")} {
    if {![catch {package require Tcl 8.6}]} {
	# implementation using [zlib stream inflate] and [rechan]/[chan create]