mingw/lib/tcl8/8.4/platform-1.0.9.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             switch -exact -- $tcl_platform(wordSize) {
 198                 4 {
 199                     set base /lib
 200                 }
 201                 8 {
 202                     set base /lib64
 203                 }
 204                 default {
 205                     return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8"
 206                 }
 207             }
 208
 209             set libclist [lsort [glob -nocomplain -directory $base libc*]]
 210             if {[llength $libclist]} {
 211                 set libc [lindex $libclist 0]
 212
 213                 # Try executing the library first. This should suceed
 214                 # for a glibc library, and return the version
 215                 # information.
 216
 217                 if {![catch {
 218                     set vdata [lindex [split [exec $libc] \n] 0]
 219                 }]} {
 220                     regexp {([0-9]+(\.[0-9]+)*)} $vdata -> v
 221                     foreach {major minor} [split $v .] break
 222                     set v glibc${major}.${minor}
 223                 } else {
 224                     # We had trouble executing the library. We are now
 225                     # inspecting its name to determine the version
 226                     # number. This code by Larry McVoy.
 227
 228                     if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
 229                         set v glibc${major}.${minor}
 230                     }
 231                 }
 232             }
 233             append plat -$v
 234             return "${plat}-${cpu}"
 235         }
 236     }
 237
 238     return $id
 239 }
 240
 241 # -- platform::patterns
 242 #
 243 # Given an exact platform identifier, i.e. _not_ the generic
 244 # identifier it assembles a list of exact platform identifier
 245 # describing platform which should be compatible with the
 246 # input.
 247 #
 248 # I.e. packages for all platforms in the result list should be
 249 # loadable on the specified platform.
 250
 251 # << Should we add the generic identifier to the list as well ? In
 252 #    general it is not compatible I believe. So better not. In many
 253 #    cases the exact identifier is identical to the generic one
 254 #    anyway.
 255 # >>
 256
 257 proc ::platform::patterns {id} {
 258     set res [list $id]
 259     if {$id eq "tcl"} {return $res}
 260
 261     switch -glob --  $id {
 262         solaris*-* {
 263             if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
 264                 if {$v eq ""} {return $id}
 265                 foreach {major minor} [split $v .] break
 266                 incr minor -1
 267                 for {set j $minor} {$j >= 6} {incr j -1} {
 268                     lappend res solaris${major}.${j}-${cpu}
 269                 }
 270             }
 271         }
 272         linux*-* {
 273             if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
 274                 foreach {major minor} [split $v .] break
 275                 incr minor -1
 276                 for {set j $minor} {$j >= 0} {incr j -1} {
 277                     lappend res linux-glibc${major}.${j}-${cpu}
 278                 }
 279             }
 280         }
 281         macosx*-*    {
 282             # 10.5+
 283             if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
 284
 285                 switch -exact -- $cpu {
 286                     ix86    -
 287                     x86_64  { set alt i386-x86_64 }
 288                     default { set alt {} }
 289                 }
 290
 291                 if {$v ne ""} {
 292                     foreach {major minor} [split $v .] break
 293
 294                     # Add 10.5 to 10.minor to patterns.
 295                     set res {}
 296                     for {set j $minor} {$j >= 5} {incr j -1} {
 297                         lappend res macosx${major}.${j}-${cpu}
 298                         lappend res macosx${major}.${j}-universal
 299                         if {$alt ne {}} {
 300                             lappend res macosx${major}.${j}-$alt
 301                         }
 302                     }
 303
 304                     # Add unversioned patterns for 10.3/10.4 builds.
 305                     lappend res macosx-${cpu}
 306                     lappend res macosx-universal
 307                     if {$alt ne {}} {
 308                         lappend res macosx-$alt
 309                     }
 310                 } else {
 311                     lappend res macosx-universal
 312                     if {$alt ne {}} {
 313                         lappend res macosx-$alt
 314                     }
 315                 }
 316             } else {
 317                 lappend res macosx-universal
 318             }
 319         }
 320         macosx-powerpc {
 321             lappend res macosx-universal
 322         }
 323         macosx-x86_64 -
 324         macosx-ix86 {
 325             lappend res macosx-universal macosx-i386-x86_64
 326         }
 327     }
 328     lappend res tcl ; # Pure tcl packages are always compatible.
 329     return $res
 330 }
 331
 332
 333 # ### ### ### ######### ######### #########
 334 ## Ready
 335
 336 package provide platform 1.0.9
 337
 338 # ### ### ### ######### ######### #########
 339 ## Demo application
 340
 341 if {[info exists argv0] && ($argv0 eq [info script])} {
 342     puts ====================================
 343     parray tcl_platform
 344     puts ====================================
 345     puts Generic\ identification:\ [::platform::generic]
 346     puts Exact\ identification:\ \ \ [::platform::identify]
 347     puts ====================================
 348     puts Search\ patterns:
 349     puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
 350     puts ====================================
 351     exit 0
 352 }