diff options
Diffstat (limited to 'tcl8.6/library/platform/platform.tcl')
| -rw-r--r-- | tcl8.6/library/platform/platform.tcl | 397 |
1 files changed, 397 insertions, 0 deletions
diff --git a/tcl8.6/library/platform/platform.tcl b/tcl8.6/library/platform/platform.tcl new file mode 100644 index 0000000..35a22a3 --- /dev/null +++ b/tcl8.6/library/platform/platform.tcl @@ -0,0 +1,397 @@ +# -*- 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 +} |