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
	Mikhail Teterin <mi+thun@aldan.algebra.com>.

2009-10-21  Donal K. Fellows  <dkf@users.sf.net>

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]]

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

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

#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# 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@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#----------------------------------------------------------------

	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		mkdir -p $$i; \
		chmod 755 $$i; \
		else true; \
		fi; \
	    done;
	@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"; \
		mkdir -p $(SCRIPT_INSTALL_DIR)/$$i; \
		chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \
		else true; \
		fi; \

	    done;
	@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
	@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
		$(UNIX_DIR)/tclAppInit.c $(UNIX_DIR)/ldAix @DTRACE_SRC@; \
	    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 \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \
	    done;
	@echo "Installing library http2.5 directory";
	@for j in $(TOP_DIR)/library/http/*.tcl ; \

#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.68.2.8 2009/10/23 19:22:24 andreas_kupries Exp $

VERSION = @TCL_VERSION@

#----------------------------------------------------------------
# Things you can change to personalize the Makefile for your own
# site (you can make these changes in either Makefile.in or
# Makefile, but changes to Makefile will get lost if you re-run

	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		$(MKDIR) $$i; \
		else true; \
		fi; \
	    done;
	@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"; \
		$(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \
		else true; \
		fi; \
	    done;
	@echo "Installing header files";
	@for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \
		"$(GENERIC_DIR)/tclPlatDecls.h" ; \
	    do \
	    $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \
	    done;
	@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
	@for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \
	    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 \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
	    done;
	@echo "Installing library http2.5 directory";
	@for j in $(ROOT_DIR)/library/http/*.tcl; \