}
}
-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]} {
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]]
--- /dev/null
+# 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
+ }
+}
--- /dev/null
+# 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
+ }
+ }
+}
projects / tclvfs / commitdiff