3 changed files with 6148 additions and 0 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,450 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Overview |
||||||
|
|
||||||
|
# Heuristics to assemble a platform identifier from publicly available |
||||||
|
# information. The identifier describes the platform of the currently |
||||||
|
# running tcl shell. This is a mixture of the runtime environment and |
||||||
|
# of build-time properties of the executable itself. |
||||||
|
# |
||||||
|
# Examples: |
||||||
|
# <1> A tcl shell executing on a x86_64 processor, but having a |
||||||
|
# wordsize of 4 was compiled for the x86 environment, i.e. 32 |
||||||
|
# bit, and loaded packages have to match that, and not the |
||||||
|
# actual cpu. |
||||||
|
# |
||||||
|
# <2> The hp/solaris 32/64 bit builds of the core cannot be |
||||||
|
# distinguished by looking at tcl_platform. As packages have to |
||||||
|
# match the 32/64 information we have to look in more places. In |
||||||
|
# this case we inspect the executable itself (magic numbers, |
||||||
|
# i.e. fileutil::magic::filetype). |
||||||
|
# |
||||||
|
# The basic information used comes out of the 'os' and 'machine' |
||||||
|
# entries of the 'tcl_platform' array. A number of general and |
||||||
|
# os/machine specific transformation are applied to get a canonical |
||||||
|
# result. |
||||||
|
# |
||||||
|
# General |
||||||
|
# Only the first element of 'os' is used - we don't care whether we |
||||||
|
# are on "Windows NT" or "Windows XP" or whatever. |
||||||
|
# |
||||||
|
# Machine specific |
||||||
|
# % amd64 -> x86_64 |
||||||
|
# % arm* -> arm |
||||||
|
# % sun4* -> sparc |
||||||
|
# % ia32* -> ix86 |
||||||
|
# % intel -> ix86 |
||||||
|
# % i*86* -> ix86 |
||||||
|
# % Power* -> powerpc |
||||||
|
# % x86_64 + wordSize 4 => x86 code |
||||||
|
# |
||||||
|
# OS specific |
||||||
|
# % AIX are always powerpc machines |
||||||
|
# % HP-UX 9000/800 etc means parisc |
||||||
|
# % linux has to take glibc version into account |
||||||
|
# % sunos -> solaris, and keep version number |
||||||
|
# |
||||||
|
# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff |
||||||
|
# has to provide all possible allowed platform identifiers when |
||||||
|
# searching search. Ditto a solaris 2.8 platform can use solaris 2.6 |
||||||
|
# packages. Etc. This is handled by the other procedure, see below. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
namespace eval ::platform {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Implementation |
||||||
|
|
||||||
|
# -- platform::generic |
||||||
|
# |
||||||
|
# Assembles an identifier for the generic platform. It leaves out |
||||||
|
# details like kernel version, libc version, etc. |
||||||
|
|
||||||
|
proc ::platform::generic {} { |
||||||
|
global tcl_platform |
||||||
|
|
||||||
|
set plat [string tolower [lindex $tcl_platform(os) 0]] |
||||||
|
set cpu $tcl_platform(machine) |
||||||
|
|
||||||
|
switch -glob -- $cpu { |
||||||
|
sun4* { |
||||||
|
set cpu sparc |
||||||
|
} |
||||||
|
intel - |
||||||
|
ia32* - |
||||||
|
i*86* { |
||||||
|
set cpu ix86 |
||||||
|
} |
||||||
|
x86_64 { |
||||||
|
if {$tcl_platform(wordSize) == 4} { |
||||||
|
# See Example <1> at the top of this file. |
||||||
|
set cpu ix86 |
||||||
|
} |
||||||
|
} |
||||||
|
ppc - |
||||||
|
"Power*" { |
||||||
|
set cpu powerpc |
||||||
|
} |
||||||
|
"arm*" { |
||||||
|
set cpu arm |
||||||
|
} |
||||||
|
ia64 { |
||||||
|
if {$tcl_platform(wordSize) == 4} { |
||||||
|
append cpu _32 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
switch -glob -- $plat { |
||||||
|
windows { |
||||||
|
if {$tcl_platform(platform) == "unix"} { |
||||||
|
set plat cygwin |
||||||
|
} else { |
||||||
|
set plat win32 |
||||||
|
} |
||||||
|
if {$cpu eq "amd64"} { |
||||||
|
# Do not check wordSize, win32-x64 is an IL32P64 platform. |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} |
||||||
|
sunos { |
||||||
|
set plat solaris |
||||||
|
if {[string match "ix86" $cpu]} { |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} elseif {![string match "ia64*" $cpu]} { |
||||||
|
# sparc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
darwin { |
||||||
|
set plat macosx |
||||||
|
# Correctly identify the cpu when running as a 64bit |
||||||
|
# process on a machine with a 32bit kernel |
||||||
|
if {$cpu eq "ix86"} { |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
set cpu x86_64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
aix { |
||||||
|
set cpu powerpc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
hp-ux { |
||||||
|
set plat hpux |
||||||
|
if {![string match "ia64*" $cpu]} { |
||||||
|
set cpu parisc |
||||||
|
if {$tcl_platform(wordSize) == 8} { |
||||||
|
append cpu 64 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
osf1 { |
||||||
|
set plat tru64 |
||||||
|
} |
||||||
|
default { |
||||||
|
set plat [lindex [split $plat _-] 0] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
|
||||||
|
# -- platform::identify |
||||||
|
# |
||||||
|
# Assembles an identifier for the exact platform, by extending the |
||||||
|
# generic identifier. I.e. it adds in details like kernel version, |
||||||
|
# libc version, etc., if they are relevant for the loading of |
||||||
|
# packages on the platform. |
||||||
|
|
||||||
|
proc ::platform::identify {} { |
||||||
|
global tcl_platform |
||||||
|
|
||||||
|
set id [generic] |
||||||
|
regexp {^([^-]+)-([^-]+)$} $id -> plat cpu |
||||||
|
|
||||||
|
switch -- $plat { |
||||||
|
solaris { |
||||||
|
regsub {^5} $tcl_platform(osVersion) 2 text |
||||||
|
append plat $text |
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
macosx { |
||||||
|
set major [lindex [split $tcl_platform(osVersion) .] 0] |
||||||
|
if {$major > 19} { |
||||||
|
set minor [lindex [split $tcl_platform(osVersion) .] 1] |
||||||
|
incr major -9 |
||||||
|
append plat $major.[expr {$minor - 1}] |
||||||
|
} else { |
||||||
|
incr major -4 |
||||||
|
append plat 10.$major |
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
linux { |
||||||
|
# Look for the libc*.so and determine its version |
||||||
|
# (libc5/6, libc6 further glibc 2.X) |
||||||
|
|
||||||
|
set v unknown |
||||||
|
|
||||||
|
# Determine in which directory to look. /lib, or /lib64. |
||||||
|
# For that we use the tcl_platform(wordSize). |
||||||
|
# |
||||||
|
# We could use the 'cpu' info, per the equivalence below, |
||||||
|
# that however would be restricted to intel. And this may |
||||||
|
# be a arm, mips, etc. system. The wordsize is more |
||||||
|
# fundamental. |
||||||
|
# |
||||||
|
# ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib |
||||||
|
# x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64 |
||||||
|
# |
||||||
|
# Do not look into /lib64 even if present, if the cpu |
||||||
|
# doesn't fit. |
||||||
|
|
||||||
|
# TODO: Determine the prefixes (i386, x86_64, ...) for |
||||||
|
# other cpus. The path after the generic one is utterly |
||||||
|
# specific to intel right now. Ok, on Ubuntu, possibly |
||||||
|
# other Debian systems we may apparently be able to query |
||||||
|
# the necessary CPU code. If we can't we simply use the |
||||||
|
# hardwired fallback. |
||||||
|
|
||||||
|
switch -exact -- $tcl_platform(wordSize) { |
||||||
|
4 { |
||||||
|
lappend bases /lib |
||||||
|
if {[catch { |
||||||
|
exec dpkg-architecture -qDEB_HOST_MULTIARCH |
||||||
|
} res]} { |
||||||
|
lappend bases /lib/i386-linux-gnu |
||||||
|
} else { |
||||||
|
# dpkg-arch returns the full tripled, not just cpu. |
||||||
|
lappend bases /lib/$res |
||||||
|
} |
||||||
|
} |
||||||
|
8 { |
||||||
|
lappend bases /lib64 |
||||||
|
if {[catch { |
||||||
|
exec dpkg-architecture -qDEB_HOST_MULTIARCH |
||||||
|
} res]} { |
||||||
|
lappend bases /lib/x86_64-linux-gnu |
||||||
|
} else { |
||||||
|
# dpkg-arch returns the full tripled, not just cpu. |
||||||
|
lappend bases /lib/$res |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
foreach base $bases { |
||||||
|
if {[LibcVersion $base -> v]} break |
||||||
|
} |
||||||
|
|
||||||
|
append plat -$v |
||||||
|
return "${plat}-${cpu}" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $id |
||||||
|
} |
||||||
|
|
||||||
|
proc ::platform::LibcVersion {base _->_ vv} { |
||||||
|
upvar 1 $vv v |
||||||
|
set libclist [lsort [glob -nocomplain -directory $base libc*]] |
||||||
|
|
||||||
|
if {![llength $libclist]} { return 0 } |
||||||
|
|
||||||
|
set libc [lindex $libclist 0] |
||||||
|
|
||||||
|
# Try executing the library first. This should suceed |
||||||
|
# for a glibc library, and return the version |
||||||
|
# information. |
||||||
|
|
||||||
|
if {![catch { |
||||||
|
set vdata [lindex [split [exec $libc] \n] 0] |
||||||
|
}]} { |
||||||
|
regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v |
||||||
|
foreach {major minor} [split $v .] break |
||||||
|
set v glibc${major}.${minor} |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
# We had trouble executing the library. We are now |
||||||
|
# inspecting its name to determine the version |
||||||
|
# number. This code by Larry McVoy. |
||||||
|
|
||||||
|
if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { |
||||||
|
set v glibc${major}.${minor} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
# -- platform::patterns |
||||||
|
# |
||||||
|
# Given an exact platform identifier, i.e. _not_ the generic |
||||||
|
# identifier it assembles a list of exact platform identifier |
||||||
|
# describing platform which should be compatible with the |
||||||
|
# input. |
||||||
|
# |
||||||
|
# I.e. packages for all platforms in the result list should be |
||||||
|
# loadable on the specified platform. |
||||||
|
|
||||||
|
# << Should we add the generic identifier to the list as well ? In |
||||||
|
# general it is not compatible I believe. So better not. In many |
||||||
|
# cases the exact identifier is identical to the generic one |
||||||
|
# anyway. |
||||||
|
# >> |
||||||
|
|
||||||
|
proc ::platform::patterns {id} { |
||||||
|
set res [list $id] |
||||||
|
if {$id eq "tcl"} {return $res} |
||||||
|
|
||||||
|
switch -glob -- $id { |
||||||
|
solaris*-* { |
||||||
|
if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { |
||||||
|
if {$v eq ""} {return $id} |
||||||
|
foreach {major minor} [split $v .] break |
||||||
|
incr minor -1 |
||||||
|
for {set j $minor} {$j >= 6} {incr j -1} { |
||||||
|
lappend res solaris${major}.${j}-${cpu} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
linux*-* { |
||||||
|
if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { |
||||||
|
foreach {major minor} [split $v .] break |
||||||
|
incr minor -1 |
||||||
|
for {set j $minor} {$j >= 0} {incr j -1} { |
||||||
|
lappend res linux-glibc${major}.${j}-${cpu} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
macosx-powerpc { |
||||||
|
lappend res macosx-universal |
||||||
|
} |
||||||
|
macosx-x86_64 { |
||||||
|
lappend res macosx-i386-x86_64 |
||||||
|
} |
||||||
|
macosx-ix86 { |
||||||
|
lappend res macosx-universal macosx-i386-x86_64 |
||||||
|
} |
||||||
|
macosx*-* { |
||||||
|
# 10.5+,11.0+ |
||||||
|
if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { |
||||||
|
|
||||||
|
switch -exact -- $cpu { |
||||||
|
ix86 { |
||||||
|
lappend alt i386-x86_64 |
||||||
|
lappend alt universal |
||||||
|
} |
||||||
|
x86_64 { |
||||||
|
if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} { |
||||||
|
set alt i386-x86_64 |
||||||
|
} else { |
||||||
|
set alt {} |
||||||
|
} |
||||||
|
} |
||||||
|
arm { |
||||||
|
lappend alt x86_64 |
||||||
|
} |
||||||
|
default { set alt {} } |
||||||
|
} |
||||||
|
|
||||||
|
if {$v ne ""} { |
||||||
|
foreach {major minor} [split $v .] break |
||||||
|
|
||||||
|
set res {} |
||||||
|
if {$major eq 13} { |
||||||
|
# Add 13.0 to 13.minor to patterns. |
||||||
|
for {set j $minor} {$j >= 0} {incr j -1} { |
||||||
|
lappend res macosx${major}.${j}-${cpu} |
||||||
|
foreach a $alt { |
||||||
|
lappend res macosx${major}.${j}-$a |
||||||
|
} |
||||||
|
} |
||||||
|
set major 12 |
||||||
|
set minor 5 |
||||||
|
} |
||||||
|
if {$major eq 12} { |
||||||
|
# Add 12.0 to 12.minor to patterns. |
||||||
|
for {set j $minor} {$j >= 0} {incr j -1} { |
||||||
|
lappend res macosx${major}.${j}-${cpu} |
||||||
|
foreach a $alt { |
||||||
|
lappend res macosx${major}.${j}-$a |
||||||
|
} |
||||||
|
} |
||||||
|
set major 11 |
||||||
|
set minor 5 |
||||||
|
} |
||||||
|
if {$major eq 11} { |
||||||
|
# Add 11.0 to 11.minor to patterns. |
||||||
|
for {set j $minor} {$j >= 0} {incr j -1} { |
||||||
|
lappend res macosx${major}.${j}-${cpu} |
||||||
|
foreach a $alt { |
||||||
|
lappend res macosx${major}.${j}-$a |
||||||
|
} |
||||||
|
} |
||||||
|
set major 10 |
||||||
|
set minor 15 |
||||||
|
} |
||||||
|
# Add 10.5 to 10.minor to patterns. |
||||||
|
for {set j $minor} {$j >= 5} {incr j -1} { |
||||||
|
if {$cpu ne "arm"} { |
||||||
|
lappend res macosx${major}.${j}-${cpu} |
||||||
|
} |
||||||
|
foreach a $alt { |
||||||
|
lappend res macosx${major}.${j}-$a |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Add unversioned patterns for 10.3/10.4 builds. |
||||||
|
lappend res macosx-${cpu} |
||||||
|
foreach a $alt { |
||||||
|
lappend res macosx-$a |
||||||
|
} |
||||||
|
} else { |
||||||
|
# No version, just do unversioned patterns. |
||||||
|
foreach a $alt { |
||||||
|
lappend res macosx-$a |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
# no v, no cpu ... nothing |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
lappend res tcl ; # Pure tcl packages are always compatible. |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide platform 1.0.19 |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Demo application |
||||||
|
|
||||||
|
if {[info exists argv0] && ($argv0 eq [info script])} { |
||||||
|
puts ==================================== |
||||||
|
parray tcl_platform |
||||||
|
puts ==================================== |
||||||
|
puts Generic\ identification:\ [::platform::generic] |
||||||
|
puts Exact\ identification:\ \ \ [::platform::identify] |
||||||
|
puts ==================================== |
||||||
|
puts Search\ patterns: |
||||||
|
puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ] |
||||||
|
puts ==================================== |
||||||
|
exit 0 |
||||||
|
} |
||||||
@ -0,0 +1,241 @@ |
|||||||
|
|
||||||
|
# -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Overview |
||||||
|
|
||||||
|
# Higher-level commands which invoke the functionality of this package |
||||||
|
# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a |
||||||
|
# repository as while the tcl shell executing packages uses the same |
||||||
|
# platform in general as a repository application there can be |
||||||
|
# differences in detail (i.e. 32/64 bit builds). |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require platform |
||||||
|
namespace eval ::platform::shell {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Implementation |
||||||
|
|
||||||
|
# -- platform::shell::generic |
||||||
|
|
||||||
|
proc ::platform::shell::generic {shell} { |
||||||
|
# Argument is the path to a tcl shell. |
||||||
|
|
||||||
|
CHECK $shell |
||||||
|
LOCATE base out |
||||||
|
|
||||||
|
set code {} |
||||||
|
# Forget any pre-existing platform package, it might be in |
||||||
|
# conflict with this one. |
||||||
|
lappend code {package forget platform} |
||||||
|
# Inject our platform package |
||||||
|
lappend code [list source $base] |
||||||
|
# Query and print the architecture |
||||||
|
lappend code {puts [platform::generic]} |
||||||
|
# And done |
||||||
|
lappend code {exit 0} |
||||||
|
|
||||||
|
set arch [RUN $shell [join $code \n]] |
||||||
|
|
||||||
|
if {$out} {file delete -force $base} |
||||||
|
return $arch |
||||||
|
} |
||||||
|
|
||||||
|
# -- platform::shell::identify |
||||||
|
|
||||||
|
proc ::platform::shell::identify {shell} { |
||||||
|
# Argument is the path to a tcl shell. |
||||||
|
|
||||||
|
CHECK $shell |
||||||
|
LOCATE base out |
||||||
|
|
||||||
|
set code {} |
||||||
|
# Forget any pre-existing platform package, it might be in |
||||||
|
# conflict with this one. |
||||||
|
lappend code {package forget platform} |
||||||
|
# Inject our platform package |
||||||
|
lappend code [list source $base] |
||||||
|
# Query and print the architecture |
||||||
|
lappend code {puts [platform::identify]} |
||||||
|
# And done |
||||||
|
lappend code {exit 0} |
||||||
|
|
||||||
|
set arch [RUN $shell [join $code \n]] |
||||||
|
|
||||||
|
if {$out} {file delete -force $base} |
||||||
|
return $arch |
||||||
|
} |
||||||
|
|
||||||
|
# -- platform::shell::platform |
||||||
|
|
||||||
|
proc ::platform::shell::platform {shell} { |
||||||
|
# Argument is the path to a tcl shell. |
||||||
|
|
||||||
|
CHECK $shell |
||||||
|
|
||||||
|
set code {} |
||||||
|
lappend code {puts $tcl_platform(platform)} |
||||||
|
lappend code {exit 0} |
||||||
|
|
||||||
|
return [RUN $shell [join $code \n]] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal helper commands. |
||||||
|
|
||||||
|
proc ::platform::shell::CHECK {shell} { |
||||||
|
if {![file exists $shell]} { |
||||||
|
return -code error "Shell \"$shell\" does not exist" |
||||||
|
} |
||||||
|
if {![file executable $shell]} { |
||||||
|
return -code error "Shell \"$shell\" is not executable (permissions)" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::platform::shell::LOCATE {bv ov} { |
||||||
|
upvar 1 $bv base $ov out |
||||||
|
|
||||||
|
# Locate the platform package for injection into the specified |
||||||
|
# shell. We are using package management to find it, whereever it |
||||||
|
# is, instead of using hardwired relative paths. This allows us to |
||||||
|
# install the two packages as TMs without breaking the code |
||||||
|
# here. If the found package is wrapped we copy the code somewhere |
||||||
|
# where the spawned shell will be able to read it. |
||||||
|
|
||||||
|
# This code is brittle, it needs has to adapt to whatever changes |
||||||
|
# are made to the TM code, i.e. the provide statement generated by |
||||||
|
# tm.tcl |
||||||
|
|
||||||
|
set pl [package ifneeded platform [package require platform]] |
||||||
|
set base [lindex $pl end] |
||||||
|
|
||||||
|
set out 0 |
||||||
|
if {[lindex [file system $base]] ne "native"} { |
||||||
|
set temp [TEMP] |
||||||
|
file copy -force $base $temp |
||||||
|
set base $temp |
||||||
|
set out 1 |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::platform::shell::RUN {shell code} { |
||||||
|
set c [TEMP] |
||||||
|
set cc [open $c w] |
||||||
|
puts $cc $code |
||||||
|
close $cc |
||||||
|
|
||||||
|
set e [TEMP] |
||||||
|
|
||||||
|
set code [catch { |
||||||
|
exec $shell $c 2> $e |
||||||
|
} res] |
||||||
|
|
||||||
|
file delete $c |
||||||
|
|
||||||
|
if {$code} { |
||||||
|
append res \n[read [set chan [open $e r]]][close $chan] |
||||||
|
file delete $e |
||||||
|
return -code error "Shell \"$shell\" is not executable ($res)" |
||||||
|
} |
||||||
|
|
||||||
|
file delete $e |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
proc ::platform::shell::TEMP {} { |
||||||
|
set prefix platform |
||||||
|
|
||||||
|
# This code is copied out of Tcllib's fileutil package. |
||||||
|
# (TempFile/tempfile) |
||||||
|
|
||||||
|
set tmpdir [DIR] |
||||||
|
|
||||||
|
set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" |
||||||
|
set nrand_chars 10 |
||||||
|
set maxtries 10 |
||||||
|
set access [list RDWR CREAT EXCL TRUNC] |
||||||
|
set permission 0600 |
||||||
|
set channel "" |
||||||
|
set checked_dir_writable 0 |
||||||
|
set mypid [pid] |
||||||
|
for {set i 0} {$i < $maxtries} {incr i} { |
||||||
|
set newname $prefix |
||||||
|
for {set j 0} {$j < $nrand_chars} {incr j} { |
||||||
|
append newname [string index $chars \ |
||||||
|
[expr {int(rand()*62)}]] |
||||||
|
} |
||||||
|
set newname [file join $tmpdir $newname] |
||||||
|
if {[file exists $newname]} { |
||||||
|
after 1 |
||||||
|
} else { |
||||||
|
if {[catch {open $newname $access $permission} channel]} { |
||||||
|
if {!$checked_dir_writable} { |
||||||
|
set dirname [file dirname $newname] |
||||||
|
if {![file writable $dirname]} { |
||||||
|
return -code error "Directory $dirname is not writable" |
||||||
|
} |
||||||
|
set checked_dir_writable 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# Success |
||||||
|
close $channel |
||||||
|
return [file normalize $newname] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$channel ne ""} { |
||||||
|
return -code error "Failed to open a temporary file: $channel" |
||||||
|
} else { |
||||||
|
return -code error "Failed to find an unused temporary file name" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::platform::shell::DIR {} { |
||||||
|
# This code is copied out of Tcllib's fileutil package. |
||||||
|
# (TempDir/tempdir) |
||||||
|
|
||||||
|
global tcl_platform env |
||||||
|
|
||||||
|
set attempdirs [list] |
||||||
|
|
||||||
|
foreach tmp {TMPDIR TEMP TMP} { |
||||||
|
if { [info exists env($tmp)] } { |
||||||
|
lappend attempdirs $env($tmp) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
switch $tcl_platform(platform) { |
||||||
|
windows { |
||||||
|
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||||
|
} |
||||||
|
macintosh { |
||||||
|
set tmpdir $env(TRASH_FOLDER) ;# a better place? |
||||||
|
} |
||||||
|
default { |
||||||
|
lappend attempdirs \ |
||||||
|
[file join / tmp] \ |
||||||
|
[file join / var tmp] \ |
||||||
|
[file join / usr tmp] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend attempdirs [pwd] |
||||||
|
|
||||||
|
foreach tmp $attempdirs { |
||||||
|
if { [file isdirectory $tmp] && [file writable $tmp] } { |
||||||
|
return [file normalize $tmp] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Fail if nothing worked. |
||||||
|
return -code error "Unable to determine a proper directory for temporary files" |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide platform::shell 1.1.4 |
||||||
Loading…
Reference in new issue