mingw/lib/tcl8/8.4/platform/shell-1.1.4.tm

   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
  15 package require platform
  16 namespace eval ::platform::shell {}
  17
  18 # ### ### ### ######### ######### #########
  19 ## Implementation
  20
  21 # -- platform::shell::generic
  22
  23 proc ::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
  48 proc ::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
  73 proc ::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
  88 proc ::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
  98 proc ::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
 125 proc ::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
 149 proc ::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 {$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
 197 proc ::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
 241 package provide platform::shell 1.1.4