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