3 # ### ### ### ######### ######### #########
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).
12 # ### ### ### ######### ######### #########
15 package require platform
16 namespace eval ::platform::shell {}
18 # ### ### ### ######### ######### #########
21 # -- platform::shell::generic
23 proc ::platform::shell::generic {shell} {
24 # Argument is the path to a tcl shell.
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]}
40 set arch [RUN $shell [join $code \n]]
42 if {$out} {file delete -force $base}
46 # -- platform::shell::identify
48 proc ::platform::shell::identify {shell} {
49 # Argument is the path to a tcl shell.
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]}
65 set arch [RUN $shell [join $code \n]]
67 if {$out} {file delete -force $base}
71 # -- platform::shell::platform
73 proc ::platform::shell::platform {shell} {
74 # Argument is the path to a tcl shell.
79 lappend code {puts $tcl_platform(platform)}
82 return [RUN $shell [join $code \n]]
85 # ### ### ### ######### ######### #########
86 ## Internal helper commands.
88 proc ::platform::shell::CHECK {shell} {
89 if {![file exists $shell]} {
90 return -code error "Shell \"$shell\" does not exist"
92 if {![file executable $shell]} {
93 return -code error "Shell \"$shell\" is not executable (permissions)"
98 proc ::platform::shell::LOCATE {bv ov} {
99 upvar 1 $bv base $ov out
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.
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
112 set pl [package ifneeded platform [package require platform]]
113 set base [lindex $pl end]
116 if {[lindex [file system $base]] ne "native"} {
118 file copy -force $base $temp
125 proc ::platform::shell::RUN {shell code} {
140 append res \n[read [set chan [open $e r]]][close $chan]
142 return -code error "Shell \"$shell\" is not executable ($res)"
149 proc ::platform::shell::TEMP {} {
152 # This code is copied out of Tcllib's fileutil package.
153 # (TempFile/tempfile)
157 set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
160 set access [list RDWR CREAT EXCL TRUNC]
163 set checked_dir_writable 0
165 for {set i 0} {$i < $maxtries} {incr i} {
167 for {set j 0} {$j < $nrand_chars} {incr j} {
168 append newname [string index $chars \
169 [expr {int(rand()*62)}]]
171 set newname [file join $tmpdir $newname]
172 if {[file exists $newname]} {
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"
181 set checked_dir_writable 1
186 return [file normalize $newname]
190 if {[string compare $channel ""]} {
191 return -code error "Failed to open a temporary file: $channel"
193 return -code error "Failed to find an unused temporary file name"
197 proc ::platform::shell::DIR {} {
198 # This code is copied out of Tcllib's fileutil package.
201 global tcl_platform env
203 set attempdirs [list]
205 foreach tmp {TMPDIR TEMP TMP} {
206 if { [info exists env($tmp)] } {
207 lappend attempdirs $env($tmp)
211 switch $tcl_platform(platform) {
213 lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
216 set tmpdir $env(TRASH_FOLDER) ;# a better place?
221 [file join / var tmp] \
222 [file join / usr tmp]
226 lappend attempdirs [pwd]
228 foreach tmp $attempdirs {
229 if { [file isdirectory $tmp] && [file writable $tmp] } {
230 return [file normalize $tmp]
234 # Fail if nothing worked.
235 return -code error "Unable to determine a proper directory for temporary files"
238 # ### ### ### ######### ######### #########
241 package provide platform::shell 1.1.4