diff options
Diffstat (limited to 'library/platform')
| -rw-r--r-- | library/platform/pkgIndex.tcl | 3 | ||||
| -rw-r--r-- | library/platform/platform.tcl | 308 | ||||
| -rw-r--r-- | library/platform/shell.tcl | 238 |
3 files changed, 549 insertions, 0 deletions
diff --git a/library/platform/pkgIndex.tcl b/library/platform/pkgIndex.tcl new file mode 100644 index 0000000..0b69432 --- /dev/null +++ b/library/platform/pkgIndex.tcl @@ -0,0 +1,3 @@ +package ifneeded platform 1.0.5 [list source [file join $dir platform.tcl]] +package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] + diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl new file mode 100644 index 0000000..1a454cd --- /dev/null +++ b/library/platform/platform.tcl @@ -0,0 +1,308 @@ +# -*- 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 -- $plat { + windows { + 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 "ia64*" $cpu]} { + 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 + + if {[file exists /lib64] && [file isdirectory /lib64]} { + set base /lib64 + } else { + set base /lib + } + + set libclist [lsort [glob -nocomplain -directory $base libc*]] + if {[llength $libclist]} { + 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 {([0-9]+(\.[0-9]+)*)} $vdata -> v + foreach {major minor} [split $v .] break + set v glibc${major}.${minor} + } 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} + } + } + } + append plat -$v + return "${plat}-${cpu}" + } + } + + return $id +} + +# -- 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*-* { + # 10.5+ + if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { + 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} + lappend res macosx${major}.${j}-universal + } + + # Add unversioned patterns for 10.3/10.4 builds. + lappend res macosx-${cpu} + lappend res macosx-universal + } else { + lappend res macosx-universal + } + } else { + lappend res macosx-universal + } + } + macosx-powerpc - + macosx-ix86 { + lappend res macosx-universal + } + } + lappend res tcl ; # Pure tcl packages are always compatible. + return $res +} + + +# ### ### ### ######### ######### ######### +## Ready + +package provide platform 1.0.5 + +# ### ### ### ######### ######### ######### +## 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 +} diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl new file mode 100644 index 0000000..407e639 --- /dev/null +++ b/library/platform/shell.tcl @@ -0,0 +1,238 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Overview + +# Higher-level commands which invoke the functionality of this package +# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a +# repository as while the tcl shell executing packages uses the same +# platform in general as a repository application there can be +# differences in detail (i.e. 32/64 bit builds). + +# ### ### ### ######### ######### ######### +## Requirements + +package require platform +namespace eval ::platform::shell {} + +# ### ### ### ######### ######### ######### +## Implementation + +# -- platform::shell::generic + +proc ::platform::shell::generic {shell} { + # Argument is the path to a tcl shell. + + CHECK $shell + LOCATE base out + + set code {} + # Forget any pre-existing platform package, it might be in + # conflict with this one. + lappend code {package forget platform} + # Inject our platform package + lappend code [list source $base] + # Query and print the architecture + lappend code {puts [platform::generic]} + # And done + lappend code {exit 0} + + set arch [RUN $shell [join $code \n]] + + if {$out} {file delete -force $base} + return $arch +} + +# -- platform::shell::identify + +proc ::platform::shell::identify {shell} { + # Argument is the path to a tcl shell. + + CHECK $shell + LOCATE base out + + set code {} + # Forget any pre-existing platform package, it might be in + # conflict with this one. + lappend code {package forget platform} + # Inject our platform package + lappend code [list source $base] + # Query and print the architecture + lappend code {puts [platform::identify]} + # And done + lappend code {exit 0} + + set arch [RUN $shell [join $code \n]] + + if {$out} {file delete -force $base} + return $arch +} + +# -- platform::shell::platform + +proc ::platform::shell::platform {shell} { + # Argument is the path to a tcl shell. + + CHECK $shell + + set code {} + lappend code {puts $tcl_platform(platform)} + lappend code {exit 0} + + return [RUN $shell [join $code \n]] +} + +# ### ### ### ######### ######### ######### +## Internal helper commands. + +proc ::platform::shell::CHECK {shell} { + if {![file exists $shell]} { + return -code error "Shell \"$shell\" does not exist" + } + if {![file executable $shell]} { + return -code error "Shell \"$shell\" is not executable (permissions)" + } + return +} + +proc ::platform::shell::LOCATE {bv ov} { + upvar 1 $bv base $ov out + + # Locate the platform package for injection into the specified + # shell. We are using package management to find it, whereever it + # is, instead of using hardwired relative paths. This allows us to + # install the two packages as TMs without breaking the code + # here. If the found package is wrapped we copy the code somewhere + # where the spawned shell will be able to read it. + + # Note: This code depends on the form of the 'provide' command + # generated by tm.tcl. Keep them in sync. See Bug 2255235. + set pl [package ifneeded platform [package require platform]] + set base [lindex $pl end] + + set out 0 + if {[lindex [file system $base]] ne "native"} { + set temp [TEMP] + file copy -force $base $temp + set base $temp + set out 1 + } + return +} + +proc ::platform::shell::RUN {shell code} { + set c [TEMP] + set cc [open $c w] + puts $cc $code + close $cc + + set e [TEMP] + + set code [catch { + exec $shell $c 2> $e + } res] + + file delete $c + + if {$code} { + append res \n[read [set chan [open $e r]]][close $chan] + file delete $e + return -code error "Shell \"$shell\" is not executable ($res)" + } + + file delete $e + return $res +} + +proc ::platform::shell::TEMP {} { + set prefix platform + + # This code is copied out of Tcllib's fileutil package. + # (TempFile/tempfile) + + set tmpdir [DIR] + + set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + set nrand_chars 10 + set maxtries 10 + set access [list RDWR CREAT EXCL TRUNC] + set permission 0600 + set channel "" + set checked_dir_writable 0 + set mypid [pid] + for {set i 0} {$i < $maxtries} {incr i} { + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars \ + [expr {int(rand()*62)}]] + } + set newname [file join $tmpdir $newname] + if {[file exists $newname]} { + after 1 + } else { + if {[catch {open $newname $access $permission} channel]} { + if {!$checked_dir_writable} { + set dirname [file dirname $newname] + if {![file writable $dirname]} { + return -code error "Directory $dirname is not writable" + } + set checked_dir_writable 1 + } + } else { + # Success + close $channel + return [file normalize $newname] + } + } + } + if {[string compare $channel ""]} { + return -code error "Failed to open a temporary file: $channel" + } else { + return -code error "Failed to find an unused temporary file name" + } +} + +proc ::platform::shell::DIR {} { + # This code is copied out of Tcllib's fileutil package. + # (TempDir/tempdir) + + global tcl_platform env + + set attempdirs [list] + + foreach tmp {TMPDIR TEMP TMP} { + if { [info exists env($tmp)] } { + lappend attempdirs $env($tmp) + } + } + + switch $tcl_platform(platform) { + windows { + lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" + } + macintosh { + set tmpdir $env(TRASH_FOLDER) ;# a better place? + } + default { + lappend attempdirs \ + [file join / tmp] \ + [file join / var tmp] \ + [file join / usr tmp] + } + } + + lappend attempdirs [pwd] + + foreach tmp $attempdirs { + if { [file isdirectory $tmp] && [file writable $tmp] } { + return [file normalize $tmp] + } + } + + # Fail if nothing worked. + return -code error "Unable to determine a proper directory for temporary files" +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide platform::shell 1.1.4 |