mingw/lib/tcl8/8.4/platform-1.0.5.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 "ia64*" $cpu]} {
 107                 if {$tcl_platform(wordSize) == 8} {
 108                     append cpu 64
 109                 }
 110             }
 111         }
 112         darwin {
 113             set plat macosx
 114             # Correctly identify the cpu when running as a 64bit
 115             # process on a machine with a 32bit kernel
 116             if {$cpu eq "ix86"} {
 117                 if {$tcl_platform(wordSize) == 8} {
 118                     set cpu x86_64
 119                 }
 120             }
 121         }
 122         aix {
 123             set cpu powerpc
 124             if {$tcl_platform(wordSize) == 8} {
 125                 append cpu 64
 126             }
 127         }
 128         hp-ux {
 129             set plat hpux
 130             if {![string match "ia64*" $cpu]} {
 131                 set cpu parisc
 132                 if {$tcl_platform(wordSize) == 8} {
 133                     append cpu 64
 134                 }
 135             }
 136         }
 137         osf1 {
 138             set plat tru64
 139         }
 140     }
 141
 142     return "${plat}-${cpu}"
 143 }
 144
 145 # -- platform::identify
 146 #
 147 # Assembles an identifier for the exact platform, by extending the
 148 # generic identifier. I.e. it adds in details like kernel version,
 149 # libc version, etc., if they are relevant for the loading of
 150 # packages on the platform.
 151
 152 proc ::platform::identify {} {
 153     global tcl_platform
 154
 155     set id [generic]
 156     regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
 157
 158     switch -- $plat {
 159         solaris {
 160             regsub {^5} $tcl_platform(osVersion) 2 text
 161             append plat $text
 162             return "${plat}-${cpu}"
 163         }
 164         macosx {
 165             set major [lindex [split $tcl_platform(osVersion) .] 0]
 166             if {$major > 8} {
 167                 incr major -4
 168                 append plat 10.$major
 169                 return "${plat}-${cpu}"
 170             }
 171         }
 172         linux {
 173             # Look for the libc*.so and determine its version
 174             # (libc5/6, libc6 further glibc 2.X)
 175
 176             set v unknown
 177
 178             if {[file exists /lib64] && [file isdirectory /lib64]} {
 179                 set base /lib64
 180             } else {
 181                 set base /lib
 182             }
 183
 184             set libclist [lsort [glob -nocomplain -directory $base libc*]]
 185             if {[llength $libclist]} {
 186                 set libc [lindex $libclist 0]
 187
 188                 # Try executing the library first. This should suceed
 189                 # for a glibc library, and return the version
 190                 # information.
 191
 192                 if {![catch {
 193                     set vdata [lindex [split [exec $libc] \n] 0]
 194                 }]} {
 195                     regexp {([0-9]+(\.[0-9]+)*)} $vdata -> v
 196                     foreach {major minor} [split $v .] break
 197                     set v glibc${major}.${minor}
 198                 } else {
 199                     # We had trouble executing the library. We are now
 200                     # inspecting its name to determine the version
 201                     # number. This code by Larry McVoy.
 202
 203                     if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
 204                         set v glibc${major}.${minor}
 205                     }
 206                 }
 207             }
 208             append plat -$v
 209             return "${plat}-${cpu}"
 210         }
 211     }
 212
 213     return $id
 214 }
 215
 216 # -- platform::patterns
 217 #
 218 # Given an exact platform identifier, i.e. _not_ the generic
 219 # identifier it assembles a list of exact platform identifier
 220 # describing platform which should be compatible with the
 221 # input.
 222 #
 223 # I.e. packages for all platforms in the result list should be
 224 # loadable on the specified platform.
 225
 226 # << Should we add the generic identifier to the list as well ? In
 227 #    general it is not compatible I believe. So better not. In many
 228 #    cases the exact identifier is identical to the generic one
 229 #    anyway.
 230 # >>
 231
 232 proc ::platform::patterns {id} {
 233     set res [list $id]
 234     if {$id eq "tcl"} {return $res}
 235
 236     switch -glob --  $id {
 237         solaris*-* {
 238             if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
 239                 if {$v eq ""} {return $id}
 240                 foreach {major minor} [split $v .] break
 241                 incr minor -1
 242                 for {set j $minor} {$j >= 6} {incr j -1} {
 243                     lappend res solaris${major}.${j}-${cpu}
 244                 }
 245             }
 246         }
 247         linux*-* {
 248             if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
 249                 foreach {major minor} [split $v .] break
 250                 incr minor -1
 251                 for {set j $minor} {$j >= 0} {incr j -1} {
 252                     lappend res linux-glibc${major}.${j}-${cpu}
 253                 }
 254             }
 255         }
 256         macosx*-*    {
 257             # 10.5+
 258             if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
 259                 if {$v ne ""} {
 260                     foreach {major minor} [split $v .] break
 261
 262                     # Add 10.5 to 10.minor to patterns.
 263                     set res {}
 264                     for {set j $minor} {$j >= 5} {incr j -1} {
 265                         lappend res macosx${major}.${j}-${cpu}
 266                         lappend res macosx${major}.${j}-universal
 267                     }
 268
 269                     # Add unversioned patterns for 10.3/10.4 builds.
 270                     lappend res macosx-${cpu}
 271                     lappend res macosx-universal
 272                 } else {
 273                     lappend res macosx-universal
 274                 }
 275             } else {
 276                 lappend res macosx-universal
 277             }
 278         }
 279         macosx-powerpc -
 280         macosx-ix86    {
 281             lappend res macosx-universal
 282         }
 283     }
 284     lappend res tcl ; # Pure tcl packages are always compatible.
 285     return $res
 286 }
 287
 288
 289 # ### ### ### ######### ######### #########
 290 ## Ready
 291
 292 package provide platform 1.0.5
 293
 294 # ### ### ### ######### ######### #########
 295 ## Demo application
 296
 297 if {[info exists argv0] && ($argv0 eq [info script])} {
 298     puts ====================================
 299     parray tcl_platform
 300     puts ====================================
 301     puts Generic\ identification:\ [::platform::generic]
 302     puts Exact\ identification:\ \ \ [::platform::identify]
 303     puts ====================================
 304     puts Search\ patterns:
 305     puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
 306     puts ====================================
 307     exit 0
 308 }