From df73c352f557f1c2e30008f8d093c8ed0cf22f5b Mon Sep 17 00:00:00 2001
From: andreas_kupries <akupries@shaw.ca>
Date: Fri, 23 Oct 2009 19:22:23 +0000
Subject: 	* library/platform/pkgIndex.tcl: Backported the platform
 packages 	* library/platform/platform.tcl: from head and8.5 into the 8.4
 	* library/platform/shell.tcl: branch. Updated makefiles to install 
 * unix/Makfile.in: the packages. 	* win/Makefile.in:

---
 ChangeLog                     |   6 +
 library/platform/pkgIndex.tcl |   3 +
 library/platform/platform.tcl | 308 ++++++++++++++++++++++++++++++++++++++++++
 library/platform/shell.tcl    | 238 ++++++++++++++++++++++++++++++++
 unix/Makefile.in              |   9 +-
 win/Makefile.in               |   9 +-
 6 files changed, 569 insertions(+), 4 deletions(-)
 create mode 100644 library/platform/pkgIndex.tcl
 create mode 100644 library/platform/platform.tcl
 create mode 100644 library/platform/shell.tcl

diff --git a/ChangeLog b/ChangeLog
index 5316163..99cec01 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,11 @@
 2009-10-23  Andreas Kupries  <andreask@activestate.com>
 
+	* library/platform/pkgIndex.tcl: Backported the platform packages
+	* library/platform/platform.tcl: from head and8.5 into the 8.4
+	* library/platform/shell.tcl: branch. Updated makefiles to install
+	* unix/Makfile.in: the packages.
+	* win/Makefile.in:
+
 	* generic/tclIO.c (FlushChannel): Skip OutputProc for low-level
 	0-length writes. When closing pipes which have already been closed
 	not skipping leads to spurious SIG_PIPE signals. Reported by
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
diff --git a/unix/Makefile.in b/unix/Makefile.in
index b7cabd4..5815ed4 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -5,7 +5,7 @@
 # "autoconf" program (constructs like "@foo@" will get replaced in the
 # actual Makefile.
 #
-# RCS: @(#) $Id: Makefile.in,v 1.121.2.28 2008/08/13 23:07:27 das Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.121.2.29 2009/10/23 19:22:24 andreas_kupries Exp $
 
 VERSION 		= @TCL_VERSION@
 MAJOR_VERSION		= @TCL_MAJOR_VERSION@
@@ -660,7 +660,7 @@ install-libraries: libraries
 		else true; \
 		fi; \
 	    done;
-	@for i in http2.5 http1.0 opt0.4 encoding msgcat1.3 tcltest2.2; \
+	@for i in platform http2.5 http1.0 opt0.4 encoding msgcat1.3 tcltest2.2; \
 	    do \
 	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
 		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -684,6 +684,11 @@ install-libraries: libraries
 	    do \
 	    $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \
 	    done;
+	@echo "Installing library platform directory";
+	@for j in $(TOP_DIR)/library/platform/*.tcl ; \
+	    do \
+	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/platform; \
+	    done;
 	@echo "Installing library http1.0 directory";
 	@for j in $(TOP_DIR)/library/http1.0/*.tcl ; \
 	    do \
diff --git a/win/Makefile.in b/win/Makefile.in
index 25cbbf7..858e2f3 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -5,7 +5,7 @@
 # "autoconf" program (constructs like "@foo@" will get replaced in the
 # actual Makefile.
 #
-# RCS: @(#) $Id: Makefile.in,v 1.68.2.7 2007/01/30 23:21:12 hobbs Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.68.2.8 2009/10/23 19:22:24 andreas_kupries Exp $
 
 VERSION = @TCL_VERSION@
 
@@ -493,7 +493,7 @@ install-libraries: libraries
 		else true; \
 		fi; \
 	    done;
-	@for i in http1.0 http2.5 opt0.4 encoding msgcat1.3 tcltest2.2; \
+	@for i in platform http1.0 http2.5 opt0.4 encoding msgcat1.3 tcltest2.2; \
 	    do \
 	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
 		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -512,6 +512,11 @@ install-libraries: libraries
 	    do \
 	    $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
 	    done;
+	@echo "Installing library platform directory";
+	@for j in $(ROOT_DIR)/library/platform/*.tcl; \
+	    do \
+	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/platform"; \
+	    done;
 	@echo "Installing library http1.0 directory";
 	@for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
 	    do \
-- 
cgit v0.12