TclVFS

Check-in [1267093049]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:2011-04-28 Steve Huntley <[email protected]> * zipvfs.tcl: Added contributed patch to speed up zipvfs directory listing. See patch 3279418.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1267093049130608c70f608055717370d70e5784
User & Date: blacksqr 2011-04-28 08:01:32
Context
2011-11-28
19:12
2011-11-28 Steve Huntley <[email protected]> * zipvfs.tcl: Reverted bug fix for 3224057. See bug ID 3303287. check-in: fdacfadbd2 user: blacksqr tags: trunk
2011-04-28
08:01
2011-04-28 Steve Huntley <[email protected]> * zipvfs.tcl: Added contributed patch to speed up zipvfs directory listing. See patch 3279418. check-in: 1267093049 user: blacksqr tags: trunk
2011-03-30
06:44
2011-03-30 Steve Huntley <[email protected]> * vfslib.tcl, zipvfs.tcl: Added contributed patches to fix bugs 3160686 & 3224057. check-in: d888143e47 user: blacksqr tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.






1
2
3
4
5
6
7




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

>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
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]>

Changes to library/zipvfs.tcl.

486
487
488
489
490
491
492

493
494
495
496
497
498
499
...
525
526
527
528
529
530
531



532
533
534
535
536
537
538
539
540

541
542
543
544
545
546
547
...
548
549
550
551
552
553
554
555

556
557



558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580




581
582
583
584
585
586
587
...
615
616
617
618
619
620
621

622
623
624

625
626
627
628
629
630
631
632
633




634
635
636
637
638
639
640
641
642
643
644
645
646
647
648

649
650






651
652
653
654
655
656
657
658
659
660
661
662
663

664
665
666
667
668

669
670

671
672
673
674
675
676
677
	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 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) "./"]



}

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


	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 tolower $sb(name)]

	    set toc($name) [array get sb]
	    FAKEDIR toc [file dirname $name]



	}
    } err]} {
	close $fd
	return -code error $err
    }

    return $fd
}

proc zip::FAKEDIR {arr path} {
    upvar 1 $arr toc

    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]]
    }
    FAKEDIR toc [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


    if { $path == "." || $path == "" } {
	set path [set tmp [string tolower $pat]]

    } else {
        set globmap [list "\[" "\\\[" "*" "\\*" "?" "\\?"]
	set tmp [string tolower $path]
        set path [string map $globmap $tmp]
	if {$pat != ""} {
	    append tmp /[string tolower $pat]
	    append path /[string tolower $pat]
	}
    }




    # file split can be confused by the glob quoting so split tmp string
    set depth [llength [file split $tmp]]

    #vfs::log "getdir $fd $path $depth $pat [array names toc $path]"
    if {$depth} {
	set ret {}
	foreach key [array names toc $path] {
	    if {[string index $key end] == "/"} {
		# Directories are listed twice: both with and without
		# the trailing '/', so we ignore the one with
		continue
	    }
	    array set sb $toc($key)

	    if { $sb(depth) == $depth } {

		if {[info exists toc(${key}/)]} {
		    array set sb $toc(${key}/)






		}
		lappend ret [file tail $sb(name)]
	    } else {
		#::vfs::log "$sb(depth) vs $depth for $sb(name)"
	    }
	    unset sb
	}
	return $ret
    } else {
	# just the 'root' of the zip archive.  This obviously exists and
	# is a directory.
	return [list {}]
    }

}

proc zip::_close {fd} {
    variable $fd
    variable $fd.toc

    unset $fd
    unset $fd.toc

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






>







 







>
>
>









>







 







|
>
|
|
>
>
>









|
|










|
|
>
>
>
>







 







>


<
>
|
<
|
<
<
<
<
|
|
>
>
>
>
|
<
|
<
<
<
<
<
<
<
<
|
<

<
>
|
<
>
>
>
>
>
>

<
<
<

<

<
<
<
<
<

>





>


>







486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
...
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
...
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
...
628
629
630
631
632
633
634
635
636
637

638
639

640




641
642
643
644
645
646
647

648








649

650

651
652

653
654
655
656
657
658
659



660

661





662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
	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]