From: Jean-Claude Wippler <jcw@equi4.com>
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: https://privyetmir.co.uk/gitweb.cgi?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
+    }
+  }
+}