# mk4vfs.tcl -- Mk4tcl Virtual File System driver
-# Copyright (C) 1997-2002 Sensus Consulting Ltd. All Rights Reserved.
+# Copyright (C) 1997-2003 Sensus Consulting Ltd. All Rights Reserved.
# Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com>
#
# $Id$
# 28apr02 jcw 1.4 reorged memchan and pkg dependencies
# 22jun02 jcw 1.5 fixed recursive dir deletion
# 16oct02 jcw 1.6 fixed periodic commit once a change is made
+# 20jan03 jcw 1.7 streamed zlib decompress mode, reduces memory usage
+# 01feb03 jcw 1.8 fix mounting a symlink, cleanup mount/unmount procs
-package provide mk4vfs 1.6
-package provide vfs::mk4 1.6
+package provide mk4vfs 1.8
+package provide vfs::mk4 1.8
package require Mk4tcl
package require vfs
namespace eval vfs::mk4 {
proc Mount {mkfile local args} {
- set db [eval [list ::mk4vfs::_mount $local $mkfile] $args]
+ if {$mkfile != ""} {
+ # dereference a symlink, otherwise mounting on it fails (why?)
+ catch {
+ set mkfile [file join [file dirname $mkfile] \
+ [file readlink $mkfile]]
+ }
+ set mkfile [file normalize $mkfile]
+ }
+ set db [eval [list ::mk4vfs::_mount $mkfile] $args]
::vfs::filesystem mount $local [list ::vfs::mk4::handler $db]
- ::vfs::RegisterMount $local [list ::vfs::mk4::Unmount $db]
+ ::vfs::RegisterMount $local [list ::mk4vfs::_umount $db]
return $db
}
- proc Unmount {db local} {
- vfs::filesystem unmount $local
- ::mk4vfs::_umount $db
- }
-
proc handler {db cmd root relative actualpath args} {
- #puts stderr "handler: $db - $cmd - $root - $relative\
- #- $actualpath - $args"
+ #puts stderr "handler: $db - $cmd - $root - $relative - $actualpath - $args"
if {$cmd == "matchindirectory"} {
eval [list $cmd $db $relative $actualpath] $args
} elseif {$cmd == "fileattributes"} {
proc access {db name mode} {
# This needs implementing better.
- if {$mode & 2} {
- ::mk4vfs::stat $db $name
- #error "read-only"
- } else {
- ::mk4vfs::stat $db $name
- }
+ ::mk4vfs::stat $db $name sb
}
proc open {db file mode permissions} {
::mk4vfs::stat $db $file sb
if { $sb(csize) != $sb(size) } {
- set fd [vfs::memchan]
- fconfigure $fd -translation binary
- set s [mk::get $sb(ino) contents]
- puts -nonewline $fd [vfs::zip -mode decompress $s]
+ if {$::mk4vfs::zstreamed} {
+ set fd [mk::channel $sb(ino) contents r]
+ fconfigure $fd -translation binary
+ set fd [vfs::zstream decompress $fd $sb(csize) $sb(size)]
+ } else {
+ set fd [vfs::memchan]
+ fconfigure $fd -translation binary
+ set s [mk::get $sb(ino) contents]
+ puts -nonewline $fd [vfs::zip -mode decompress $s]
- fconfigure $fd -translation auto
- seek $fd 0
- return $fd
+ fconfigure $fd -translation auto
+ seek $fd 0
+ }
} elseif { $::mk4vfs::direct } {
set fd [vfs::memchan]
fconfigure $fd -translation binary
fconfigure $fd -translation auto
seek $fd 0
- return $fd
} else {
set fd [mk::channel $sb(ino) contents r]
}
variable compress 1 ;# HACK - needs to be part of "Super-Block"
variable flush 5000 ;# Auto-Commit frequency
variable direct 0 ;# read through a memchan, or from Mk4tcl if zero
+ variable zstreamed 0 ;# decompress on the fly (needs zlib 1.1)
namespace eval v {
variable seq 0
mk::set $db.dirs!0 parent -1
}
+ # deprecated, use vfs::mk4::Mount (first two args are reversed!)
proc mount {local mkfile args} {
uplevel [list ::vfs::mk4::Mount $mkfile $local] $args
}
- proc _mount {path file args} {
+ proc _mount {{file ""} args} {
set db mk4vfs[incr v::seq]
- eval [list mk::file open $db $file] $args
-
- init $db
-
- set v::mode($db) rw
- for {set idx 0} {$idx < [llength $args]} {incr idx} {
- switch -- [lindex $args $idx] {
- -readonly { set v::mode($db) ro }
- -nocommit { set v::mode($db) nc }
- }
- }
- if {$v::mode($db) == "rw"} {
- periodicCommit $db
+ if {$file == ""} {
+ mk::file open $db
+ init $db
+ set v::mode($db) ro
+ } else {
+ eval [list mk::file open $db $file] $args
+
+ init $db
+
+ set v::mode($db) rw
+ for {set idx 0} {$idx < [llength $args]} {incr idx} {
+ switch -- [lindex $args $idx] {
+ -readonly { set v::mode($db) ro }
+ -nocommit { set v::mode($db) nc }
+ }
+ }
+ if {$v::mode($db) == "rw"} {
+ periodicCommit $db
+ }
}
return $db
}
mk::file commit $db
}
+ # deprecated: unmounts, but only if vfs was mounted on itself
proc umount {local} {
foreach {db path} [mk::file open] {
if {[string equal $local $path]} {
- uplevel 1 [list ::vfs::mk4::Unmount $db $local]
+ vfs::filesystem unmount $local
+ _umount $db
return
}
}
}
proc stat {db path {arr ""}} {
-
set sp [::file split $path]
set tail [lindex $sp end]
# Now check if final comp is a directory or a file
# CACHING is required - it can deliver a x15 speed-up!
- if {[string equal $tail "."] || [string equal $tail ":"] \
- || [string equal $tail ""]} {
+ if { [string equal $tail "."] || [string equal $tail ":"] \
+ || [string equal $tail ""] } {
set row $parent
} elseif { [info exists v::cache($db,$parent,$tail)] } {
}
}
}
-
- if {![string length $arr]} {
- # The caller doesn't need more detailed information.
- return 1
- }
-
+
+ if {![string length $arr]} {
+ # The caller doesn't need more detailed information.
+ return 1
+ }
+
set cur $view!$row
upvar 1 $arr sb
-
+
set sb(type) $type
set sb(view) $view
set sb(ino) $cur
# Starkit support, see http://www.equi4.com/starkit/
# by Jean-Claude Wippler, July 2002
-package provide starkit 1.0
+package provide starkit 1.1
# Starkit scripts can launched in a number of ways:
# - wrapped or unwrapped
# called from the startup script of a starkit to init topdir and auto_path
# returns how the script was launched: starkit, starpack, unwrapped, or
- # sourced
+ # sourced (Jan 2003: also tclhttpd or plugin)
proc startup {} {
global argv0
variable topdir ;# the root directory (while the starkit is mounted)
set a0 [file normalize $argv0]
if {$topdir eq $a0} { return starkit }
if {$script eq $a0} { return unwrapped }
+
+ # detect when sourced from tclhttpd
+ if {[info procs ::Httpd_Server] ne ""} { return tclhttpd }
+
+ # detect when sourced from the plugin (tentative)
+ if {[info exists ::embed_args]} { return plugin }
+
return sourced
}
if {[info commands wm] ne ""} {
wm withdraw .
tk_messageBox -icon error -message $msg -title "Fatal error"
- } elseif {[info commands eventlog] ne ""} {
+ } elseif {[info commands ::eventlog] ne ""} {
eventlog error $msg
} else {
puts stderr $msg
namespace eval ::vfs {
+ variable zseq 0 ;# used to generate temp zstream cmd names
+
# for backwards compatibility
proc normalize {path} { ::file normalize $path }
}
}
- # use rechan to define memchan if available
+ # use rechan to define memchan and zstream if available
if {[info command rechan] != "" || ![catch {load "" rechan}]} {
proc memchan_handler {cmd fd args} {
set ::vfs::_memchan_pos($fd) 0
return $fd
}
+
+ proc zstream_handler {zcmd ifd clen ilen imode cmd fd {a1 ""} {a2 ""}} {
+ #puts stderr "z $zcmd $ifd $ilen $cmd $fd $a1 $a2"
+ upvar ::vfs::_zstream_pos($fd) pos
+
+ switch -- $cmd {
+ seek {
+ switch $a2 {
+ 1 - current { incr a1 $pos }
+ 2 - end { incr a1 $ilen }
+ }
+ # to seek back, rewind, i.e. start from scratch
+ if {$a1 < $pos} {
+ rename $zcmd ""
+ zlib $imode $zcmd
+ seek $ifd 0
+ set pos 0
+ }
+ # consume data while not yet at seek position
+ while {$pos < $a1} {
+ set n [expr {$a1 - $pos}]
+ if {$n > 4096} { set n 4096 }
+ read $fd $n
+ }
+ return $pos
+ }
+ read {
+ set r ""
+ set n $a1
+ #puts stderr " want $n z $zcmd pos $pos ilen $ilen"
+ if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] }
+ while {$n > 0} {
+ if {[$zcmd fill] == 0} {
+ set c [expr {$clen - [tell $ifd]}]
+ if {$c > 4096} { set c 4096 }
+ set data [read $ifd $c]
+ #puts "filled $c [string length $data]"
+ $zcmd fill $data
+ }
+ set data [$zcmd drain $n]
+ #puts stderr " read [string length $data]"
+ if {$data eq ""} break
+ append r $data
+ incr pos [string length $data]
+ incr n -[string length $data]
+ }
+ return $r
+ }
+ close {
+ rename $zcmd ""
+ close $ifd
+ unset pos
+ }
+ default { error "bad cmd in zstream_handler: $cmd" }
+ }
+ }
+
+ proc zstream {mode ifd clen ilen} {
+ set cname _zstream_[incr ::vfs::zseq]
+ zlib s$mode $cname
+ set cmd [list ::vfs::zstream_handler $cname $ifd $clen $ilen s$mode]
+ set fd [rechan $cmd 2]
+ set ::vfs::_zstream_pos($fd) 0
+ return $fd
+ }
}
}
projects / tclvfs / commitdiff