diff options
Diffstat (limited to 'tcl8.6/library/platform')
-rw-r--r-- | tcl8.6/library/platform/pkgIndex.tcl | 3 | ||||
-rw-r--r-- | tcl8.6/library/platform/platform.tcl | 397 | ||||
-rw-r--r-- | tcl8.6/library/platform/shell.tcl | 241 |
3 files changed, 0 insertions, 641 deletions
diff --git a/tcl8.6/library/platform/pkgIndex.tcl b/tcl8.6/library/platform/pkgIndex.tcl deleted file mode 100644 index 5970a3f..0000000 --- a/tcl8.6/library/platform/pkgIndex.tcl +++ /dev/null @@ -1,3 +0,0 @@ -package ifneeded platform 1.0.14 [list source [file join $dir platform.tcl]] -package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] - diff --git a/tcl8.6/library/platform/platform.tcl b/tcl8.6/library/platform/platform.tcl deleted file mode 100644 index 35a22a3..0000000 --- a/tcl8.6/library/platform/platform.tcl +++ /dev/null @@ -1,397 +0,0 @@ -# -*- 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 -# % arm* -> arm -# % sun4* -> sparc -# % 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 - - i*86* { - set cpu ix86 - } - x86_64 { - if {$tcl_platform(wordSize) == 4} { - # See Example <1> at the top of this file. - set cpu ix86 - } - } - "Power*" { - set cpu powerpc - } - "arm*" { - set cpu arm - } - ia64 { - if {$tcl_platform(wordSize) == 4} { - append cpu _32 - } - } - } - - switch -glob -- $plat { - cygwin* { - set plat cygwin - } - 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 - } - } - - 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 > 8} { - incr major -4 - append plat 10.$major - 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+ - if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { - - switch -exact -- $cpu { - ix86 { - lappend alt i386-x86_64 - lappend alt universal - } - x86_64 { lappend alt i386-x86_64 } - default { set alt {} } - } - - if {$v ne ""} { - foreach {major minor} [split $v .] break - - # Add 10.5 to 10.minor to patterns. - set res {} - for {set j $minor} {$j >= 5} {incr j -1} { - 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.14 - -# ### ### ### ######### ######### ######### -## 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 -} diff --git a/tcl8.6/library/platform/shell.tcl b/tcl8.6/library/platform/shell.tcl deleted file mode 100644 index 6eb9691..0000000 --- a/tcl8.6/library/platform/shell.tcl +++ /dev/null @@ -1,241 +0,0 @@ - -# -*- 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 |