22

✏️ Editing: platform-1.0.14.tm

# -*- 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
}

MR SKB