From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Thu, 22 Jan 2009 15:10:10 +0000 (+0000)
Subject: Make use of the core zlib and reflected channels to implement memchan and zip file... 
X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=e4cd004653724f6701e69b8e2d320e65ee3802c4;p=tclvfs

Make use of the core zlib and reflected channels to implement memchan and zip file support with Tcl 8.6.
---

diff --git a/ChangeLog b/ChangeLog
index 4a9899f..d3b1b4b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2009-01-22  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
+	* tests/vfslib.test: Make use of the core zlib and refchan features
+	* pkgIndex.tcl.in:   by default for Tcl 8.6.
+
 	* win/makefile.vc:  Updated windows build files
 	* win/rules.vc:
 	* win/nmakehlp.c:
diff --git a/library/vfslib.tcl b/library/vfslib.tcl
index a29a78d..c2cdfbf 100644
--- a/library/vfslib.tcl
+++ b/library/vfslib.tcl
@@ -1,4 +1,6 @@
-# Remnants of what used to be VFS init, this is TclKit-specific
+# Remnants of what used to be VFS init. This uses either the 8.6 core zlib
+# command or the tclkit zlib package with rechan to provide a memory channel
+# and a streaming decompression channel transform.
 
 package require Tcl 8.4; # vfs is all new for 8.4
 package provide vfslib 1.4
@@ -27,11 +29,126 @@ if {[llength [info command zlib]] || ![catch {load "" zlib}]} {
     }
 }
 
-# use rechan to define memchan and zstream if available
-if {[info command rechan] != "" || ![catch {load "" rechan}]} {
+# Use 8.6 reflected channels or the rechan package in earlier versions to
+# provide a memory channel implementation.
+# Also provide an abstract zlib streaming channel transform using the core
+# zlib command (8.6) or the tclkit zlib package.
+#
+if {[package vsatisfies [package provide Tcl] 8.6]} {
+
+    proc vfs::zstream {mode ifd clen ilen} {
+        return [zlib push $mode $ifd]
+    }
+    proc vfs::memchan {{filename {}}} {
+        return [chan create {read write} \
+                    [list [namespace origin _memchan_handler] $filename]]
+    }
+    proc vfs::_memchan_handler {filename cmd chan args} {
+        upvar #0 ::vfs::_memchan(buf,$chan) buf
+        upvar #0 ::vfs::_memchan(pos,$chan) pos
+        upvar #0 ::vfs::_memchan(name,$chan) name
+        upvar #0 ::vfs::_memchan(timer) timer
+        switch -exact -- $cmd {
+            initialize {
+                foreach {mode} $args break
+                set buf ""
+                set pos 0
+                set watch {}
+                set name $filename
+                if {![info exists timer]} { set timer "" }
+                return {initialize finalize watch read write seek cget cgetall}
+            }
+            finalize {
+                unset buf pos name
+            }
+            seek {
+                foreach {offset base} $args break
+                switch -exact -- $base {
+                    current { incr offset $pos }
+                    end     { incr offset [string length $buf] }
+                }
+                if {$offset < 0} {
+                    return -code error "error during seek on \"$chan\":\
+                        invalid argument"
+                } elseif {$offset > [string length $buf]} {
+                    set extend [expr {$offset - [string length $buf]}]
+                    append buf [binary format @$extend]
+                }
+                return [set pos $offset]
+            }
+            read {
+                foreach {count} $args break
+                set r [string range $buf $pos [expr {$pos + $count - 1}]]
+                incr pos [string length $r]
+                return $r
+            }
+            write {
+                foreach {data} $args break
+		set count [string length $data]
+		if { $pos >= [string length $buf] } {
+		    append buf $data
+		} else {
+		    set last [expr { $pos + $count - 1 }]
+		    set buf [string replace $buf $pos $last $data]
+		}
+		incr pos $count
+		return $count
+            }
+            cget {
+                foreach {option} $args break
+                switch -exact -- $option {
+                    -length { return [string length $buf] }
+                    -allocated { return [string length $buf] }
+                    default {
+                        return -code error "bad option \"$option\":\
+                            should be one of -blocking, -buffering,\
+                            -buffersize, -encoding, -eofchar, -translation,\
+                            -length or -allocated" 
+                    }
+                }
+            }
+            cgetall {
+                return [list -length [string length $buf] \
+                            -allocated [string length $buf]]
+            }
+            watch {
+                foreach {eventspec} $args break
+                after cancel $timer
+                foreach event {read write} {
+                    upvar #0 ::vfs::_memchan(watch,$event) watch
+                    if {![info exists watch]} { set watch {} }
+                    set ndx [lsearch -exact $watch $chan]
+                    if {$event in $eventspec} {
+                        if {$ndx == -1} { lappend watch $chan }
+                    } else {
+                        if {$ndx != -1} {
+                            set watch [lreplace $watch $ndx $ndx]
+                        }
+                    }
+                }
+                set timer [after 10 [list ::vfs::_memchan_timer]]
+            }
+        }
+    }
+    # memchan channels are always writable and always readable
+    proc ::vfs::_memchan_timer {} {
+        set continue 0
+        foreach event {read write} {
+            upvar #0 ::vfs::_memchan(watch,$event) watch
+            incr continue [llength $watch]
+            foreach chan $watch { chan postevent $chan $event }
+        }
+        if {$continue > 0} {
+            set ::vfs::_memchan(timer) [after 10 [info level 0]]
+        }
+    }
+
+} elseif {[info command rechan] ne "" || ![catch {load "" rechan}]} {
+
     proc vfs::memchan_handler {cmd fd args} {
 	upvar 1 ::vfs::_memchan_buf($fd) buf
 	upvar 1 ::vfs::_memchan_pos($fd) pos
+        upvar 1 ::vfs::_memchan_nam($fd) nam
 	set arg1 [lindex $args 0]
 
 	switch -- $cmd {
@@ -60,16 +177,17 @@ if {[info command rechan] != "" || ![catch {load "" rechan}]} {
 		return $n
 	    }
 	    close {
-		unset buf pos
+		unset buf pos nam
 	    }
 	    default { error "bad cmd in memchan_handler: $cmd" }
 	}
     }
 
-    proc vfs::memchan {} {
+    proc vfs::memchan {{filename {}}} {
 	set fd [rechan ::vfs::memchan_handler 6]
 	set ::vfs::_memchan_buf($fd) ""
 	set ::vfs::_memchan_pos($fd) 0
+        set ::vfs::_memchan_nam($fd) $filename
 	return $fd
     }
 
diff --git a/pkgIndex.tcl.in b/pkgIndex.tcl.in
index 39f6a87..88e5a35 100644
--- a/pkgIndex.tcl.in
+++ b/pkgIndex.tcl.in
@@ -22,6 +22,9 @@ proc ::vfs::loadvfs {libdir dll} {
     }
     uplevel #0 [list load $dll]
     uplevel #0 [list source [file join $libdir vfsUtils.tcl]]
+    if {[package vsatisfies [package provide Tcl] 8.6]} {
+        uplevel #0 [list source [file join $libdir vfslib.tcl]]
+    }
 }
 
 # Allow optional redirect of VFS_LIBRARY components.  Only necessary