1
2# -*- tcl -*-
3# ### ### ### ######### ######### #########
4## Overview
5
6# Higher-level commands which invoke the functionality of this package
7# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a
8# repository as while the tcl shell executing packages uses the same
9# platform in general as a repository application there can be
10# differences in detail (i.e. 32/64 bit builds).
11
12# ### ### ### ######### ######### #########
13## Requirements
14
15package require platform
16namespace eval ::platform::shell {}
17
18# ### ### ### ######### ######### #########
19## Implementation
20
21# -- platform::shell::generic
22
23proc ::platform::shell::generic {shell} {
24    # Argument is the path to a tcl shell.
25
26    CHECK $shell
27    LOCATE base out
28
29    set     code {}
30    # Forget any pre-existing platform package, it might be in
31    # conflict with this one.
32    lappend code {package forget platform}
33    # Inject our platform package
34    lappend code [list source $base]
35    # Query and print the architecture
36    lappend code {puts [platform::generic]}
37    # And done
38    lappend code {exit 0}
39
40    set arch [RUN $shell [join $code \n]]
41
42    if {$out} {file delete -force $base}
43    return $arch
44}
45
46# -- platform::shell::identify
47
48proc ::platform::shell::identify {shell} {
49    # Argument is the path to a tcl shell.
50
51    CHECK $shell
52    LOCATE base out
53
54    set     code {}
55    # Forget any pre-existing platform package, it might be in
56    # conflict with this one.
57    lappend code {package forget platform}
58    # Inject our platform package
59    lappend code [list source $base]
60    # Query and print the architecture
61    lappend code {puts [platform::identify]}
62    # And done
63    lappend code {exit 0}
64
65    set arch [RUN $shell [join $code \n]]
66
67    if {$out} {file delete -force $base}
68    return $arch
69}
70
71# -- platform::shell::platform
72
73proc ::platform::shell::platform {shell} {
74    # Argument is the path to a tcl shell.
75
76    CHECK $shell
77
78    set     code {}
79    lappend code {puts $tcl_platform(platform)}
80    lappend code {exit 0}
81
82    return [RUN $shell [join $code \n]]
83}
84
85# ### ### ### ######### ######### #########
86## Internal helper commands.
87
88proc ::platform::shell::CHECK {shell} {
89    if {![file exists $shell]} {
90	return -code error "Shell \"$shell\" does not exist"
91    }
92    if {![file executable $shell]} {
93	return -code error "Shell \"$shell\" is not executable (permissions)"
94    }
95    return
96}
97
98proc ::platform::shell::LOCATE {bv ov} {
99    upvar 1 $bv base $ov out
100
101    # Locate the platform package for injection into the specified
102    # shell. We are using package management to find it, whereever it
103    # is, instead of using hardwired relative paths. This allows us to
104    # install the two packages as TMs without breaking the code
105    # here. If the found package is wrapped we copy the code somewhere
106    # where the spawned shell will be able to read it.
107
108    # This code is brittle, it needs has to adapt to whatever changes
109    # are made to the TM code, i.e. the provide statement generated by
110    # tm.tcl
111
112    set pl [package ifneeded platform [package require platform]]
113    set base [lindex $pl end]
114
115    set out 0
116    if {[lindex [file system $base]] ne "native"} {
117	set temp [TEMP]
118	file copy -force $base $temp
119	set base $temp
120	set out 1
121    }
122    return
123}
124
125proc ::platform::shell::RUN {shell code} {
126    set     c [TEMP]
127    set    cc [open $c w]
128    puts  $cc $code
129    close $cc
130
131    set e [TEMP]
132
133    set code [catch {
134        exec $shell $c 2> $e
135    } res]
136
137    file delete $c
138
139    if {$code} {
140	append res \n[read [set chan [open $e r]]][close $chan]
141	file delete $e
142	return -code error "Shell \"$shell\" is not executable ($res)"
143    }
144
145    file delete $e
146    return $res
147}
148
149proc ::platform::shell::TEMP {} {
150    set prefix platform
151
152    # This code is copied out of Tcllib's fileutil package.
153    # (TempFile/tempfile)
154
155    set tmpdir [DIR]
156
157    set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
158    set nrand_chars 10
159    set maxtries 10
160    set access [list RDWR CREAT EXCL TRUNC]
161    set permission 0600
162    set channel ""
163    set checked_dir_writable 0
164    set mypid [pid]
165    for {set i 0} {$i < $maxtries} {incr i} {
166 	set newname $prefix
167 	for {set j 0} {$j < $nrand_chars} {incr j} {
168 	    append newname [string index $chars \
169		    [expr {int(rand()*62)}]]
170 	}
171	set newname [file join $tmpdir $newname]
172 	if {[file exists $newname]} {
173 	    after 1
174 	} else {
175 	    if {[catch {open $newname $access $permission} channel]} {
176 		if {!$checked_dir_writable} {
177 		    set dirname [file dirname $newname]
178 		    if {![file writable $dirname]} {
179 			return -code error "Directory $dirname is not writable"
180 		    }
181 		    set checked_dir_writable 1
182 		}
183 	    } else {
184 		# Success
185		close $channel
186 		return [file normalize $newname]
187 	    }
188 	}
189    }
190    if {[string compare $channel ""]} {
191 	return -code error "Failed to open a temporary file: $channel"
192    } else {
193 	return -code error "Failed to find an unused temporary file name"
194    }
195}
196
197proc ::platform::shell::DIR {} {
198    # This code is copied out of Tcllib's fileutil package.
199    # (TempDir/tempdir)
200
201    global tcl_platform env
202
203    set attempdirs [list]
204
205    foreach tmp {TMPDIR TEMP TMP} {
206	if { [info exists env($tmp)] } {
207	    lappend attempdirs $env($tmp)
208	}
209    }
210
211    switch $tcl_platform(platform) {
212	windows {
213	    lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
214	}
215	macintosh {
216	    set tmpdir $env(TRASH_FOLDER)  ;# a better place?
217	}
218	default {
219	    lappend attempdirs \
220		[file join / tmp] \
221		[file join / var tmp] \
222		[file join / usr tmp]
223	}
224    }
225
226    lappend attempdirs [pwd]
227
228    foreach tmp $attempdirs {
229	if { [file isdirectory $tmp] && [file writable $tmp] } {
230	    return [file normalize $tmp]
231	}
232    }
233
234    # Fail if nothing worked.
235    return -code error "Unable to determine a proper directory for temporary files"
236}
237
238# ### ### ### ######### ######### #########
239## Ready
240
241package provide platform::shell 1.1.4
242