/usr/share/tcltk/vfs1.3/starkit.tcl is in tcl-vfs 1.3-20080503-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | # Starkit support, see http://www.equi4.com/starkit/
# by Jean-Claude Wippler, July 2002
package provide starkit 1.3.2
package require vfs
# 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 {
# these variables are defined after the call to starkit::startup
# they are special in that a second call will not alter them
# (as needed when a starkit sources others for more packages)
variable topdir ;# root directory (while the starkit is mounted)
variable mode ;# startup mode (starkit, sourced, etc)
# called from the header of a starkit
proc header {driver args} {
if {[catch {
set self [fullnormalize [info script]]
package require ${driver}vfs
eval [list ::vfs::${driver}::Mount $self $self] $args
uplevel [list source [file join $self main.tcl]]
}]} {
panic $::errorInfo
}
}
proc fullnormalize {path} {
# SNARFED from tcllib, fileutil.
# 8.5
# return [file join {expand}[lrange [file split
# [file normalize [file join $path __dummy__]]] 0 end-1]]
return [file dirname [file normalize [file join $path __dummy__]]]
}
# called from the startup script of a starkit to init topdir and auto_path
# 2003/10/21, added in 1.3: remember startup mode in starkit::mode
proc startup {} {
if {![info exists starkit::mode]} { variable mode }
set mode [_startup]
}
# returns how the script was launched: starkit, starpack, unwrapped, or
# sourced (2003: also tclhttpd, plugin, or service)
proc _startup {} {
global argv0
# 2003/02/11: new behavior, if starkit::topdir exists, don't disturb it
if {![info exists starkit::topdir]} { variable topdir }
set script [vfs::filesystem fullynormalize [info script]]
set topdir [file dirname $script]
if {$topdir eq [vfs::filesystem fullynormalize [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 [vfs::filesystem fullynormalize $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 }
# detect when run as an NT service
if {[info exists ::tcl_service]} { return service }
return sourced
}
# append an entry to auto_path if it's not yet listed
proc autoextend {dir} {
global auto_path
set dir [vfs::filesystem fullynormalize $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 ""} {
catch { wm withdraw . }
tk_messageBox -icon error -message $msg -title "Fatal error"
} elseif {[info commands ::eventlog] ne ""} {
eventlog error $msg
} else {
puts stderr $msg
}
exit
}
# the following proc was copied from the critcl package:
# return a platform designator, including both OS and machine
#
# only use first element of $tcl_platform(os) - we don't care
# whether we are on "Windows NT" or "Windows XP" or whatever
#
# transforms $tcl_platform(machine) for some special cases
# - on SunOS, matches for sun4* are transformed to sparc
# - on all OS's matches for intel and i*86* are transformed to x86
# - on MacOS X "Power Macintosh" is transformed to ppc
#
proc platform {} {
global tcl_platform
set plat [lindex $tcl_platform(os) 0]
set mach $tcl_platform(machine)
switch -glob -- $mach {
sun4* { set mach sparc }
intel -
i*86* { set mach x86 }
"Power Macintosh" { set mach ppc }
}
switch -- $plat {
AIX { set mach ppc }
HP-UX { set mach hppa }
}
return "$plat-$mach"
}
# load extension from a platform-specific subdirectory
proc pload {dir name args} {
set f [file join $dir [platform] $name[info sharedlibext]]
uplevel 1 [linsert $args 0 load $f]
}
}
|