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