From 72ed94f9d339d8fff1ba1354074167457fde3161 Mon Sep 17 00:00:00 2001 From: Jean-Claude Wippler Date: Sat, 1 Feb 2003 22:46:32 +0000 Subject: [PATCH] changes merged from tclkit project --- ChangeLog | 8 +++ library/mk4vfs.tcl | 114 ++++++++++++++++++++++------------------ library/pkgIndex.tcl | 8 +-- library/pkgIndex.tcl.in | 8 +-- library/starkit.tcl | 13 +++-- library/vfslib.tcl | 69 +++++++++++++++++++++++- 6 files changed, 157 insertions(+), 63 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4bf1177..01ef117 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2003-02-01 Jean-Claude Wippler + + * library/pkgIndex.tcl.in: mk4vfs 1.8, starkit 1.1, vfslib 1.3.1 + * library/pkgIndex.tcl: (shouldn't this be dropped from CVS now?) + * library/mk4vfs.tcl: updated from tclkit project + * library/starkit.tcl: updated from tclkit project + * library/vfslib.tcl: updated from tclkit project + 2003-01-30 Jeff Hobbs * Makefile.in: only install pkgIndex.tcl for shared builds diff --git a/library/mk4vfs.tcl b/library/mk4vfs.tcl index 873dcf8..99e26b0 100644 --- a/library/mk4vfs.tcl +++ b/library/mk4vfs.tcl @@ -1,5 +1,5 @@ # 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 and Jean-Claude Wippler # # $Id$ @@ -10,9 +10,11 @@ # 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 @@ -34,20 +36,22 @@ if {![info exists auto_index(lassign)] && [info commands lassign] == ""} { 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"} { @@ -89,12 +93,7 @@ namespace eval vfs::mk4 { 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} { @@ -108,14 +107,19 @@ namespace eval vfs::mk4 { ::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 @@ -123,7 +127,6 @@ namespace eval vfs::mk4 { fconfigure $fd -translation auto seek $fd 0 - return $fd } else { set fd [mk::channel $sb(ino) contents r] } @@ -231,6 +234,7 @@ namespace eval mk4vfs { 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 @@ -257,26 +261,33 @@ namespace eval mk4vfs { 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 } @@ -287,10 +298,12 @@ namespace eval mk4vfs { 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 } } @@ -307,7 +320,6 @@ namespace eval mk4vfs { } proc stat {db path {arr ""}} { - set sp [::file split $path] set tail [lindex $sp end] @@ -332,8 +344,8 @@ namespace eval mk4vfs { # 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)] } { @@ -369,16 +381,16 @@ namespace eval mk4vfs { } } } - - 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 diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl index 6269c39..4fdb6e1 100644 --- a/library/pkgIndex.tcl +++ b/library/pkgIndex.tcl @@ -39,17 +39,17 @@ proc loadvfs {dll} { } package ifneeded vfs 1.0 [list loadvfs $dll] -package ifneeded starkit 1.0 [list source [file join $dir starkit.tcl]] -package ifneeded vfslib 1.3 [list source [file join $dir vfslib.tcl]] +package ifneeded starkit 1.1 [list source [file join $dir starkit.tcl]] +package ifneeded vfslib 1.3.1 [list source [file join $dir vfslib.tcl]] # Old -package ifneeded mk4vfs 1.6 [list source [file join $dir mk4vfs.tcl]] +package ifneeded mk4vfs 1.8 [list source [file join $dir mk4vfs.tcl]] package ifneeded zipvfs 1.0 [list source [file join $dir zipvfs.tcl]] # New package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]] package ifneeded vfs::http 0.5 [list source [file join $dir httpvfs.tcl]] -package ifneeded vfs::mk4 1.6 [list source [file join $dir mk4vfs.tcl]] +package ifneeded vfs::mk4 1.8 [list source [file join $dir mk4vfs.tcl]] package ifneeded vfs::ns 0.5 [list source [file join $dir tclprocvfs.tcl]] package ifneeded vfs::tar 0.9 [list source [file join $dir tarvfs.tcl]] package ifneeded vfs::test 1.0 [list source [file join $dir testvfs.tcl]] diff --git a/library/pkgIndex.tcl.in b/library/pkgIndex.tcl.in index c13ae9f..7affa1f 100644 --- a/library/pkgIndex.tcl.in +++ b/library/pkgIndex.tcl.in @@ -26,17 +26,17 @@ proc loadvfs {dll} { } package ifneeded vfs 1.0 [list loadvfs $dll] -package ifneeded starkit 1.0 [list source [file join $dir starkit.tcl]] -package ifneeded vfslib 1.3 [list source [file join $dir vfslib.tcl]] +package ifneeded starkit 1.1 [list source [file join $dir starkit.tcl]] +package ifneeded vfslib 1.3.1 [list source [file join $dir vfslib.tcl]] # Old -package ifneeded mk4vfs 1.6 [list source [file join $dir mk4vfs.tcl]] +package ifneeded mk4vfs 1.8 [list source [file join $dir mk4vfs.tcl]] package ifneeded zipvfs 1.0 [list source [file join $dir zipvfs.tcl]] # New package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]] package ifneeded vfs::http 0.5 [list source [file join $dir httpvfs.tcl]] -package ifneeded vfs::mk4 1.6 [list source [file join $dir mk4vfs.tcl]] +package ifneeded vfs::mk4 1.8 [list source [file join $dir mk4vfs.tcl]] package ifneeded vfs::ns 0.5 [list source [file join $dir tclprocvfs.tcl]] package ifneeded vfs::tar 0.9 [list source [file join $dir tarvfs.tcl]] package ifneeded vfs::test 1.0 [list source [file join $dir testvfs.tcl]] diff --git a/library/starkit.tcl b/library/starkit.tcl index 3d9c370..d6304ab 100644 --- a/library/starkit.tcl +++ b/library/starkit.tcl @@ -1,7 +1,7 @@ # 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 @@ -42,7 +42,7 @@ namespace eval starkit { # 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) @@ -59,6 +59,13 @@ namespace eval starkit { 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 } @@ -85,7 +92,7 @@ namespace eval starkit { 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 diff --git a/library/vfslib.tcl b/library/vfslib.tcl index b1290b1..5755729 100644 --- a/library/vfslib.tcl +++ b/library/vfslib.tcl @@ -5,6 +5,8 @@ package provide vfslib 1.3 namespace eval ::vfs { + variable zseq 0 ;# used to generate temp zstream cmd names + # for backwards compatibility proc normalize {path} { ::file normalize $path } @@ -33,7 +35,7 @@ namespace eval ::vfs { } } - # 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} { @@ -79,5 +81,70 @@ namespace eval ::vfs { 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 + } } } -- 2.23.0