util/X86LINUX64/lib/tcl8/8.4/platform-1.0.13.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 {[string match "ix86" $cpu]} {
 107                 if {$tcl_platform(wordSize) == 8} {
 108                     set cpu x86_64
 109                 }
 110             } elseif {![string match "ia64*" $cpu]} {
 111                 # sparc
 112                 if {$tcl_platform(wordSize) == 8} {
 113                     append cpu 64
 114                 }
 115             }
 116         }
 117         darwin {
 118             set plat macosx
 119             # Correctly identify the cpu when running as a 64bit
 120             # process on a machine with a 32bit kernel
 121             if {$cpu eq "ix86"} {
 122                 if {$tcl_platform(wordSize) == 8} {
 123                     set cpu x86_64
 124                 }
 125             }
 126         }
 127         aix {
 128             set cpu powerpc
 129             if {$tcl_platform(wordSize) == 8} {
 130                 append cpu 64
 131             }
 132         }
 133         hp-ux {
 134             set plat hpux
 135             if {![string match "ia64*" $cpu]} {
 136                 set cpu parisc
 137                 if {$tcl_platform(wordSize) == 8} {
 138                     append cpu 64
 139                 }
 140             }
 141         }
 142         osf1 {
 143             set plat tru64
 144         }
 145     }
 146
 147     return "${plat}-${cpu}"
 148 }
 149
 150 # -- platform::identify
 151 #
 152 # Assembles an identifier for the exact platform, by extending the
 153 # generic identifier. I.e. it adds in details like kernel version,
 154 # libc version, etc., if they are relevant for the loading of
 155 # packages on the platform.
 156
 157 proc ::platform::identify {} {
 158     global tcl_platform
 159
 160     set id [generic]
 161     regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
 162
 163     switch -- $plat {
 164         solaris {
 165             regsub {^5} $tcl_platform(osVersion) 2 text
 166             append plat $text
 167             return "${plat}-${cpu}"
 168         }
 169         macosx {
 170             set major [lindex [split $tcl_platform(osVersion) .] 0]
 171             if {$major > 8} {
 172                 incr major -4
 173                 append plat 10.$major
 174                 return "${plat}-${cpu}"
 175             }
 176         }
 177         linux {
 178             # Look for the libc*.so and determine its version
 179             # (libc5/6, libc6 further glibc 2.X)
 180
 181             set v unknown
 182
 183             # Determine in which directory to look. /lib, or /lib64.
 184             # For that we use the tcl_platform(wordSize).
 185             #
 186             # We could use the 'cpu' info, per the equivalence below,
 187             # that however would be restricted to intel. And this may
 188             # be a arm, mips, etc. system. The wordsize is more
 189             # fundamental.
 190             #
 191             # ix86   <=> (wordSize == 4) <=> 32 bit ==> /lib
 192             # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64
 193             #
 194             # Do not look into /lib64 even if present, if the cpu
 195             # doesn't fit.
 196
 197             # TODO: Determine the prefixes (i386, x86_64, ...) for
 198             # other cpus.  The path after the generic one is utterly
 199             # specific to intel right now.  Ok, on Ubuntu, possibly
 200             # other Debian systems we may apparently be able to query
 201             # the necessary CPU code. If we can't we simply use the
 202             # hardwired fallback.
 203
 204             switch -exact -- $tcl_platform(wordSize) {
 205                 4 {
 206                     lappend bases /lib
 207                     if {[catch {
 208                         exec dpkg-architecture -qDEB_HOST_MULTIARCH
 209                     } res]} {
 210                         lappend bases /lib/i386-linux-gnu
 211                     } else {
 212                         # dpkg-arch returns the full tripled, not just cpu.
 213                         lappend bases /lib/$res
 214                     }
 215                 }
 216                 8 {
 217                     lappend bases /lib64
 218                     if {[catch {
 219                         exec dpkg-architecture -qDEB_HOST_MULTIARCH
 220                     } res]} {
 221                         lappend bases /lib/x86_64-linux-gnu
 222                     } else {
 223                         # dpkg-arch returns the full tripled, not just cpu.
 224                         lappend bases /lib/$res
 225                     }
 226                 }
 227                 default {
 228                     return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8"
 229                 }
 230             }
 231
 232             foreach base $bases {
 233                 if {[LibcVersion $base -> v]} break
 234             }
 235
 236             append plat -$v
 237             return "${plat}-${cpu}"
 238         }
 239     }
 240
 241     return $id
 242 }
 243
 244 proc ::platform::LibcVersion {base _->_ vv} {
 245     upvar 1 $vv v
 246     set libclist [lsort [glob -nocomplain -directory $base libc*]]
 247
 248     if {![llength $libclist]} { return 0 }
 249
 250     set libc [lindex $libclist 0]
 251
 252     # Try executing the library first. This should suceed
 253     # for a glibc library, and return the version
 254     # information.
 255
 256     if {![catch {
 257         set vdata [lindex [split [exec $libc] \n] 0]
 258     }]} {
 259         regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v
 260         foreach {major minor} [split $v .] break
 261         set v glibc${major}.${minor}
 262         return 1
 263     } else {
 264         # We had trouble executing the library. We are now
 265         # inspecting its name to determine the version
 266         # number. This code by Larry McVoy.
 267
 268         if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
 269             set v glibc${major}.${minor}
 270             return 1
 271         }
 272     }
 273     return 0
 274 }
 275
 276 # -- platform::patterns
 277 #
 278 # Given an exact platform identifier, i.e. _not_ the generic
 279 # identifier it assembles a list of exact platform identifier
 280 # describing platform which should be compatible with the
 281 # input.
 282 #
 283 # I.e. packages for all platforms in the result list should be
 284 # loadable on the specified platform.
 285
 286 # << Should we add the generic identifier to the list as well ? In
 287 #    general it is not compatible I believe. So better not. In many
 288 #    cases the exact identifier is identical to the generic one
 289 #    anyway.
 290 # >>
 291
 292 proc ::platform::patterns {id} {
 293     set res [list $id]
 294     if {$id eq "tcl"} {return $res}
 295
 296     switch -glob --  $id {
 297         solaris*-* {
 298             if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
 299                 if {$v eq ""} {return $id}
 300                 foreach {major minor} [split $v .] break
 301                 incr minor -1
 302                 for {set j $minor} {$j >= 6} {incr j -1} {
 303                     lappend res solaris${major}.${j}-${cpu}
 304                 }
 305             }
 306         }
 307         linux*-* {
 308             if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
 309                 foreach {major minor} [split $v .] break
 310                 incr minor -1
 311                 for {set j $minor} {$j >= 0} {incr j -1} {
 312                     lappend res linux-glibc${major}.${j}-${cpu}
 313                 }
 314             }
 315         }
 316         macosx-powerpc {
 317             lappend res macosx-universal
 318         }
 319         macosx-x86_64 {
 320             lappend res macosx-i386-x86_64
 321         }
 322         macosx-ix86 {
 323             lappend res macosx-universal macosx-i386-x86_64
 324         }
 325         macosx*-*    {
 326             # 10.5+
 327             if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
 328
 329                 switch -exact -- $cpu {
 330                     ix86    {
 331                         lappend alt i386-x86_64
 332                         lappend alt universal
 333                     }
 334                     x86_64  { lappend alt i386-x86_64 }
 335                     default { set alt {} }
 336                 }
 337
 338                 if {$v ne ""} {
 339                     foreach {major minor} [split $v .] break
 340
 341                     # Add 10.5 to 10.minor to patterns.
 342                     set res {}
 343                     for {set j $minor} {$j >= 5} {incr j -1} {
 344                         lappend res macosx${major}.${j}-${cpu}
 345                         foreach a $alt {
 346                             lappend res macosx${major}.${j}-$a
 347                         }
 348                     }
 349
 350                     # Add unversioned patterns for 10.3/10.4 builds.
 351                     lappend res macosx-${cpu}
 352                     foreach a $alt {
 353                         lappend res macosx-$a
 354                     }
 355                 } else {
 356                     # No version, just do unversioned patterns.
 357                     foreach a $alt {
 358                         lappend res macosx-$a
 359                     }
 360                 }
 361             } else {
 362                 # no v, no cpu ... nothing
 363             }
 364         }
 365     }
 366     lappend res tcl ; # Pure tcl packages are always compatible.
 367     return $res
 368 }
 369
 370
 371 # ### ### ### ######### ######### #########
 372 ## Ready
 373
 374 package provide platform 1.0.13
 375
 376 # ### ### ### ######### ######### #########
 377 ## Demo application
 378
 379 if {[info exists argv0] && ($argv0 eq [info script])} {
 380     puts ====================================
 381     parray tcl_platform
 382     puts ====================================
 383     puts Generic\ identification:\ [::platform::generic]
 384     puts Exact\ identification:\ \ \ [::platform::identify]
 385     puts ====================================
 386     puts Search\ patterns:
 387     puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
 388     puts ====================================
 389     exit 0
 390 }