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