From: Jean-Claude Wippler Date: Tue, 10 Sep 2002 22:41:33 +0000 (+0000) Subject: added starkit/vfslib scripts X-Git-Tag: vfs-1-2~35 X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=c0d7ac3377330794c7b61ca82788c6c4c312eca4;p=tclvfs added starkit/vfslib scripts --- diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl index ed9dabf..33c7bd8 100644 --- a/library/pkgIndex.tcl +++ b/library/pkgIndex.tcl @@ -20,12 +20,16 @@ if {[info tclversion] == 8.4} { } } -if {[info exists tcl_platform(debug)]} { - set file [file join $dir vfs10d[info sharedlibextension]] +if {$tcl_platform(platform) eq "unix"} { + set file libvfs1.0 +} elseif {[info exists tcl_platform(debug)]} { + set file vfs10d } else { - set file [file join $dir vfs10[info sharedlibextension]] + set file vfs10 } +set file [file join $dir $file[info sharedlibextension]] + # Don't do anything if our shared lib doesn't exist. This should # help stop a crash on pre-release MacOS X. if {![file exists $file]} { @@ -46,3 +50,5 @@ package ifneeded vfs 1.0 [list loadvfs $file] unset file package ifneeded mk4vfs 1.5 [list source [file join $dir mk4vfs.tcl]] +package ifneeded starkit 1.0 [list source [file join $dir starkit.tcl]] +package ifneeded vfslib 1.3 [list source [file join $dir vfslib.tcl]] diff --git a/library/starkit.tcl b/library/starkit.tcl new file mode 100644 index 0000000..cfd0763 --- /dev/null +++ b/library/starkit.tcl @@ -0,0 +1,95 @@ +# Starkit support, see http://www.equi4.com/starkit/ +# by Jean-Claude Wippler, July 2002 + +package provide starkit 1.0 + +# Starkit scripts can launched in a number of ways: +# - wrapped or unwrapped +# - using tclkit, or from tclsh/wish with a couple of pkgs installed +# - with real MetaKit support, or with a read-only fake (ReadKit) +# - as 2-file starkit deployment, or as 1-file starpack +# +# Furthermore, there are three variations: +# current: starkits +# older: VFS-based "scripted documents" +# oldest: pre-VFS "scripted documents" +# +# The code in here is only called directly from the current starkits. + +# lassign is used so widely by now, make sure it is always available +if {![info exists auto_index(lassign)] && [info commands lassign] eq ""} { + set auto_index(lassign) { + proc lassign {l args} { + foreach v $l a $args { uplevel 1 [list set $a $v] } + } + } +} + +namespace eval starkit { + +# called from the header of a starkit + proc header {driver args} { + if {[catch { + set self [info script] + + package require ${driver}vfs + eval [list ::vfs::${driver}::Mount $self $self] $args + + uplevel [list source [file join $self main.tcl]] + }]} { + panic $::errorInfo + } + } + +# 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 + proc startup {} { + global argv0 + variable topdir ;# the root directory (while the starkit is mounted) + + set script [file normalize [info script]] + set topdir [file dirname $script] + + if {$topdir eq [info nameofexe]} { return starpack } + + # pkgs live in the $topdir/lib/ directory + set lib [file join $topdir lib] + if {[file isdir $lib]} { autoextend $lib } + + set a0 [file normalize $argv0] + if {$topdir eq $a0} { return starkit } + if {$script eq $a0} { return unwrapped } + return sourced + } + +# append an entry to auto_path if it's not yet listed + proc autoextend {dir} { + global auto_path + set dir [file normalize $dir] + if {[lsearch $auto_path $dir] < 0} { + lappend auto_path $dir + } + } + +# remount a starkit with different options + proc remount {args} { + variable topdir + lassign [vfs::filesystem info $topdir] drv arg + vfs::unmount $topdir + + eval [list [regsub handler $drv Mount] $topdir $topdir] $args + } + +# terminate with an error message, using most appropriate mechanism + proc panic {msg} { + if {[info commands wm] ne ""} { + wm withdraw . + tk_messageBox -icon error -message $msg -title "Fatal error" + } elseif {[info commands eventlog] ne ""} { + eventlog error $msg + } else { + puts stderr $msg + } + exit + } +} diff --git a/library/vfslib.tcl b/library/vfslib.tcl new file mode 100644 index 0000000..f6d440f --- /dev/null +++ b/library/vfslib.tcl @@ -0,0 +1,82 @@ +# Remnants of what used to be VFS init, this is TclKit-specific + +package provide vfslib 1.3 + +namespace eval ::vfs { + +# for backwards compatibility + proc normalize {path} { ::file normalize $path } + +# use zlib to define zip and crc if available + if {[info command zlib] != "" || ![catch {load "" zlib}]} { + + proc zip {flag value args} { + switch -glob -- "$flag $value" { + {-mode d*} { set mode decompress } + {-mode c*} { set mode compress } + default { error "usage: zip -mode {compress|decompress} data" } + } + # kludge to allow "-nowrap 1" as second option, 5-9-2002 + if {[llength $args] > 2 && [lrange $args 0 1] == "-nowrap 1"} { + if {$mode == "compress"} { + set mode deflate + } else { + set mode inflate + } + } + return [zlib $mode [lindex $args end]] + } + + proc crc {data} { + return [zlib crc32 $data] + } + } + +# use rechan to define memchan if available + if {[info command rechan] != "" || ![catch {load "" rechan}]} { + + proc memchan_handler {cmd fd args} { + upvar ::vfs::_memchan_buf($fd) buf + upvar ::vfs::_memchan_pos($fd) pos + set arg1 [lindex $args 0] + + switch -- $cmd { + seek { + switch [lindex $args 1] { + 1 - current { incr arg1 $pos } + 2 - end { incr arg1 [string length $buf]} + } + return [set pos $arg1] + } + read { + set r [string range $buf $pos [expr { $pos + $arg1 - 1 }]] + incr pos [string length $r] + return $r + } + write { + set n [string length $arg1] + if { $pos >= [string length $buf] } { + append buf $arg1 + } else { # the following doesn't work yet :( + set last [expr { $pos + $n - 1 }] + set buf [string replace $buf $pos $last $arg1] + error "vfs memchan: sorry no inline write yet" + } + incr pos $n + return $n + } + close { + unset buf pos + } + default { error "bad cmd in memchan_handler: $cmd" } + } + } + + proc memchan {} { + set fd [rechan ::vfs::memchan_handler 6] + set ::vfs::_memchan_buf($fd) "" + set ::vfs::_memchan_pos($fd) 0 + return $fd + } + } +}