From: Vince Darley Date: Thu, 25 Apr 2002 14:38:08 +0000 (+0000) Subject: memchan, zip, etc X-Git-Tag: vfs-1-2~55 X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=b4f067a1962c4ea888d03b4cd3799fc7a456a543;p=tclvfs memchan, zip, etc --- diff --git a/library/ftpvfs.tcl b/library/ftpvfs.tcl index 6a20495..89ac5d2 100644 --- a/library/ftpvfs.tcl +++ b/library/ftpvfs.tcl @@ -115,9 +115,8 @@ proc vfs::ftp::open {fd name mode permissions} { "" - "r" { ftp::Get $fd $name -variable tmp - package require Memchan - set filed [memchan] + set filed [vfs::memchan] fconfigure $filed -translation binary puts -nonewline $filed $tmp @@ -130,8 +129,8 @@ proc vfs::ftp::open {fd name mode permissions} { if {[catch [list ::ftp::Append $fd -data "" $name] err] || !$err} { error "Can't open $name for appending" } - package require Memchan - set filed [memchan] + + set filed [vfs::memchan] return [list $filed [list ::vfs::ftp::_closing $fd $name $filed Append]] } "w*" { @@ -139,8 +138,8 @@ proc vfs::ftp::open {fd name mode permissions} { if {[catch [list ::ftp::Put $fd -data "" $name] err] || !$err} { error "Can't open $name for writing" } - package require Memchan - set filed [memchan] + + set filed [vfs::memchan] return [list $filed [list ::vfs::ftp::_closing $fd $name $filed Put]] } default { diff --git a/library/httpvfs.tcl b/library/httpvfs.tcl index dae654a..048e61d 100644 --- a/library/httpvfs.tcl +++ b/library/httpvfs.tcl @@ -101,9 +101,8 @@ proc vfs::http::open {dirurl name mode permissions} { "" - "r" { set state [::http::geturl [file join $dirurl $name]] - package require Memchan - set filed [memchan] + set filed [vfs::memchan] fconfigure $filed -translation binary puts -nonewline $filed [::http::data $state] diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl index 86efe11..6ce39c8 100644 --- a/library/mk4vfs.tcl +++ b/library/mk4vfs.tcl @@ -162,22 +162,18 @@ proc vfs::mk4::open {db file mode permissions} { ::mk4vfs::stat $db $file sb if { $sb(csize) != $sb(size) } { - package require Trf - package require Memchan - set fd [memchan] + set fd [vfs::memchan] fconfigure $fd -translation binary set s [mk::get $sb(ino) contents] - puts -nonewline $fd [zip -mode decompress $s] + puts -nonewline $fd [vfs::zip -mode decompress $s] fconfigure $fd -translation auto seek $fd 0 return [list $fd [list _memchan_handler close $fd]] } elseif { $::mk4vfs::direct } { - package require Trf - package require Memchan - set fd [memchan] + set fd [vfs::memchan] fconfigure $fd -translation binary puts -nonewline $fd [mk::get $sb(ino) contents] @@ -209,15 +205,13 @@ proc vfs::mk4::open {db file mode permissions} { } if { $sb(csize) != $sb(size) } { - package require Trf - package require Memchan append mode z - set fd [memchan] + set fd [vfs::memchan] fconfigure $fd -translation binary set s [mk::get $sb(ino) contents] - puts -nonewline $fd [zip -mode decompress $s] + puts -nonewline $fd [vfs::zip -mode decompress $s] fconfigure $fd -translation auto } else { set fd [mk::channel $sb(ino) contents a] @@ -238,10 +232,8 @@ proc vfs::mk4::open {db file mode permissions} { } if { [string match *z* $mode] || $mk4vfs::compress } { - package require Trf - package require Memchan append mode z - set fd [memchan] + set fd [vfs::memchan] } else { set fd [mk::channel $sb(ino) contents w] } diff --git a/library/tclprocvfs.tcl b/library/tclprocvfs.tcl index 2cade50..cbb4e4d 100644 --- a/library/tclprocvfs.tcl +++ b/library/tclprocvfs.tcl @@ -81,9 +81,7 @@ proc vfs::ns::open {ns name mode permissions} { switch -- $mode { "" - "r" { - package require Memchan - - set nfd [memchan] + set nfd [vfs::memchan] fconfigure $nfd -translation binary puts -nonewline $nfd [_generate ::${ns}::${name}] fconfigure $nfd -translation auto diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl index 05af286..8f9802a 100644 --- a/library/vfsUtils.tcl +++ b/library/vfsUtils.tcl @@ -9,6 +9,24 @@ namespace eval ::vfs { } } +# This can be overridden to use a different memchan implementation +proc ::vfs::memchan {args} { + ::package require Memchan + uplevel 1 ::memchan $args +} + +# This can be overridden to use a different zlib implementation +proc ::vfs::zlib {args} { + ::package require Trf + uplevel 1 ::zlib $args +} + +# This can be overridden to use a different zlib implementation +proc ::vfs::zip {args} { + ::package require Trf + uplevel 1 ::zip $args +} + proc ::vfs::autoMountExtension {ext cmd {pkg ""}} { variable extMounts set extMounts($ext) [list $cmd $pkg] diff --git a/library/zipvfs.tcl b/library/zipvfs.tcl index b648ad9..49f103b 100644 --- a/library/zipvfs.tcl +++ b/library/zipvfs.tcl @@ -1,6 +1,5 @@ package require vfs -package require pink package provide zipvfs 1.0 # Using the vfs, memchan and Trf extensions, we ought to be able @@ -100,9 +99,7 @@ proc vfs::zip::open {zipfd name mode permissions} { ::zip::stat $zipfd $name sb - package require Memchan - - set nfd [memchan] + set nfd [vfs::memchan] fconfigure $nfd -translation binary seek $zipfd $sb(ino) start @@ -293,7 +290,7 @@ proc zip::Data {fd arr {varPtr ""} {verify 0}} { if { $sb(method) != 0 } { if { [catch { - set data [zlib decompress $data] + set data [vfs::zlib decompress $data] } err] } { ::vfs::log "$sb(name): inflate error: $err" binary scan $data H* x @@ -302,7 +299,7 @@ proc zip::Data {fd arr {varPtr ""} {verify 0}} { } return if { $verify } { - set ncrc [zlib crc32 $data] + set ncrc [vfs::zlib crc32 $data] if { $ncrc != $sb(crc) } { tclLog [format {%s: crc mismatch: expected 0x%x, got 0x%x} \ $sb(name) $sb(crc) $ncrc] diff --git a/tests/vfsUrl.test b/tests/vfsUrl.test index d64d63b..6e04868 100644 --- a/tests/vfsUrl.test +++ b/tests/vfsUrl.test @@ -29,7 +29,8 @@ if {![file writable $vfsTestDir]} { if {[info exists env(TEMP)] && [file writable $env(TEMP)]} { set vfsTestDir $env(TEMP) tcltest::testConstraint vfsWritable 1 - puts stdout "Using temporary directory for some files" + puts stdout "Using temporary directory for some files\ + (since [pwd] is not writable)" } else { tcltest::testConstraint vfsWritable 0 }