mingw/lib/tcl8/8.4/platform-1.0.3.tm

   1 # -*- tcl -*-
   2 # ### ### ### ######### ######### #########
   3 ## Overview
   4
   5 # Heuristics to assemble a platform identifier from publicly available
   6 # information. The identifier describes the platform of the currently
   7 # running tcl shell. This is a mixture of the runtime environment and
   8 # of build-time properties of the executable itself.
   9 #
  10 # Examples:
  11 # <1> A tcl shell executing on a x86_64 processor, but having a
  12 #   wordsize of 4 was compiled for the x86 environment, i.e. 32
  13 #   bit, and loaded packages have to match that, and not the
  14 #   actual cpu.
  15 #
  16 # <2> The hp/solaris 32/64 bit builds of the core cannot be
  17 #   distinguished by looking at tcl_platform. As packages have to
  18 #   match the 32/64 information we have to look in more places. In
  19 #   this case we inspect the executable itself (magic numbers,
  20 #   i.e. fileutil::magic::filetype).
  21 #
  22 # The basic information used comes out of the 'os' and 'machine'
  23 # entries of the 'tcl_platform' array. A number of general and
  24 # os/machine specific transformation are applied to get a canonical
  25 # result.
  26 #
  27 # General
  28 # Only the first element of 'os' is used - we don't care whether we
  29 # are on "Windows NT" or "Windows XP" or whatever.
  30 #
  31 # Machine specific
  32 # % arm*   -> arm
  33 # % sun4*  -> sparc
  34 # % intel  -> ix86
  35 # % i*86*  -> ix86
  36 # % Power* -> powerpc
  37 # % x86_64 + wordSize 4 => x86 code
  38 #
  39 # OS specific
  40 # % AIX are always powerpc machines
  41 # % HP-UX 9000/800 etc means parisc
  42 # % linux has to take glibc version into account
  43 # % sunos -> solaris, and keep version number
  44 #
  45 # NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff
  46 # has to provide all possible allowed platform identifiers when
  47 # searching search. Ditto a solaris 2.8 platform can use solaris 2.6
  48 # packages. Etc. This is handled by the other procedure, see below.
  49
  50 # ### ### ### ######### ######### #########
  51 ## Requirements
  52
  53 namespace eval ::platform {}
  54
  55 # ### ### ### ######### ######### #########
  56 ## Implementation
  57
  58 # -- platform::generic
  59 #
  60 # Assembles an identifier for the generic platform. It leaves out
  61 # details like kernel version, libc version, etc.
  62
  63 proc ::platform::generic {} {
  64     global tcl_platform
  65
  66     set plat [string tolower [lindex $tcl_platform(os) 0]]
  67     set cpu  $tcl_platform(machine)
  68
  69     switch -glob -- $cpu {
  70         sun4* {
  71             set cpu sparc
  72         }
  73         intel -
  74         i*86* {
  75             set cpu ix86
  76         }
  77         x86_64 {
  78             if {$tcl_platform(wordSize) == 4} {
  79                 # See Example <1> at the top of this file.
  80                 set cpu ix86
  81             }
  82         }
  83         "Power*" {
  84             set cpu powerpc
  85         }
  86         "arm*" {
  87             set cpu arm
  88         }
  89         ia64 {
  90             if {$tcl_platform(wordSize) == 4} {
  91                 append cpu _32
  92             }
  93         }
  94     }
  95
  96     switch -- $plat {
  97         windows {
  98             set plat win32
  99             if {$cpu eq "amd64"} {
 100                 # Do not check wordSize, win32-x64 is an IL32P64 platform.
 101                 set cpu x86_64
 102             }
 103         }
 104         sunos {
 105             set plat solaris
 106             if {$cpu ne "ia64"} {
 107                 if {$tcl_platform(wordSize) == 8} {
 108                     append cpu 64
 109                 }
 110             }
 111         }
 112         darwin {
 113             set plat macosx
 114         }
 115         aix {
 116             set cpu powerpc
 117             if {$tcl_platform(wordSize) == 8} {
 118                 append cpu 64
 119             }
 120         }
 121         hp-ux {
 122             set plat hpux
 123             if {$cpu ne "ia64"} {
 124                 set cpu parisc
 125                 if {$tcl_platform(wordSize) == 8} {
 126                     append cpu 64
 127                 }
 128             }
 129         }
 130         osf1 {
 131             set plat tru64
 132         }
 133     }
 134
 135     return "${plat}-${cpu}"
 136 }
 137
 138 # -- platform::identify
 139 #
 140 # Assembles an identifier for the exact platform, by extending the
 141 # generic identifier. I.e. it adds in details like kernel version,
 142 # libc version, etc., if they are relevant for the loading of
 143 # packages on the platform.
 144
 145 proc ::platform::identify {} {
 146     global tcl_platform
 147
 148     set id [generic]
 149     regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
 150
 151     switch -- $plat {
 152         solaris {
 153             regsub {^5} $tcl_platform(osVersion) 2 text
 154             append plat $text
 155             return "${plat}-${cpu}"
 156         }
 157         linux {
 158             # Look for the libc*.so and determine its version
 159             # (libc5/6, libc6 further glibc 2.X)
 160
 161             set v unknown
 162
 163             if {[file exists /lib64] && [file isdirectory /lib64]} {
 164                 set base /lib64
 165             } else {
 166                 set base /lib
 167             }
 168
 169             set libclist [lsort [glob -nocomplain -directory $base libc*]]
 170             if {[llength $libclist]} {
 171                 set libc [lindex $libclist 0]
 172
 173                 # Try executing the library first. This should suceed
 174                 # for a glibc library, and return the version
 175                 # information.
 176
 177                 if {![catch {
 178                     set vdata [lindex [split [exec $libc] \n] 0]
 179                 }]} {
 180                     regexp {([0-9]+(\.[0-9]+)*)} $vdata -> v
 181                     foreach {major minor} [split $v .] break
 182                     set v glibc${major}.${minor}
 183                 } else {
 184                     # We had trouble executing the library. We are now
 185                     # inspecting its name to determine the version
 186                     # number. This code by Larry McVoy.
 187
 188                     if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
 189                         set v glibc${major}.${minor}
 190                     }
 191                 }
 192             }
 193             append plat -$v
 194             return "${plat}-${cpu}"
 195         }
 196     }
 197
 198     return $id
 199 }
 200
 201 # -- platform::patterns
 202 #
 203 # Given an exact platform identifier, i.e. _not_ the generic
 204 # identifier it assembles a list of exact platform identifier
 205 # describing platform which should be compatible with the
 206 # input.
 207 #
 208 # I.e. packages for all platforms in the result list should be
 209 # loadable on the specified platform.
 210
 211 # << Should we add the generic identifier to the list as well ? In
 212 #    general it is not compatible I believe. So better not. In many
 213 #    cases the exact identifier is identical to the generic one
 214 #    anyway.
 215 # >>
 216
 217 proc ::platform::patterns {id} {
 218     set res [list $id]
 219     if {$id eq "tcl"} {return $res}
 220
 221     switch -glob --  $id {
 222         solaris*-* {
 223             if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
 224                 if {$v eq ""} {return $id}
 225                 foreach {major minor} [split $v .] break
 226                 incr minor -1
 227                 for {set j $minor} {$j >= 6} {incr j -1} {
 228                     lappend res solaris${major}.${j}-${cpu}
 229                 }
 230             }
 231         }
 232         linux*-* {
 233             if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
 234                 foreach {major minor} [split $v .] break
 235                 incr minor -1
 236                 for {set j $minor} {$j >= 0} {incr j -1} {
 237                     lappend res linux-glibc${major}.${j}-${cpu}
 238                 }
 239             }
 240         }
 241         macosx-powerpc -
 242         macosx-ix86    {
 243             lappend res macosx-universal
 244         }
 245     }
 246     lappend res tcl ; # Pure tcl packages are always compatible.
 247     return $res
 248 }
 249
 250
 251 # ### ### ### ######### ######### #########
 252 ## Ready
 253
 254 package provide platform 1.0.3
 255
 256 # ### ### ### ######### ######### #########
 257 ## Demo application
 258
 259 if {[info exists argv0] && ($argv0 eq [info script])} {
 260     puts ====================================
 261     parray tcl_platform
 262     puts ====================================
 263     puts Generic\ identification:\ [::platform::generic]
 264     puts Exact\ identification:\ \ \ [::platform::identify]
 265     puts ====================================
 266     puts Search\ patterns:
 267     puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
 268     puts ====================================
 269     exit 0
 270 }