Import TCL release 8.0 beta 2.

7 files changed, 1193 insertions, 74 deletions

diff --git a/contrib/tcl/library/http1.0/http.tcl b/contrib/tcl/library/http1.0/http.tcl
new file mode 100644
index 000000000000..366b3ed39ba7
--- /dev/null
+++ b/contrib/tcl/library/http1.0/http.tcl
@@ -0,0 +1,371 @@
+# http.tcl
+# Client-side HTTP for GET, POST, and HEAD commands.
+# These routines can be used in untrusted code that uses the Safesock
+# security policy.
+# These procedures use a callback interface to avoid using vwait,
+# which is not defined in the safe base.
+#
+# SCCS: @(#) http.tcl 1.6 97/05/20 18:09:27
+#
+# See the http.n man page for documentation
+
+package provide http 1.0
+
+array set http {
+    -accept */*
+    -proxyhost {}
+    -proxyport {}
+    -useragent {Tcl http client package 1.0}
+    -proxyfilter httpProxyRequired
+}
+proc http_config {args} {
+    global http
+    set options [lsort [array names http -*]]
+    set usage [join $options ", "]
+    if {[llength $args] == 0} {
+	set result {}
+	foreach name $options {
+	    lappend result $name $http($name)
+	}
+	return $result
+    }
+    regsub -all -- - $options {} options
+    set pat ^-([join $options |])$
+    if {[llength $args] == 1} {
+	set flag [lindex $args 0]
+	if {[regexp -- $pat $flag]} {
+	    return $http($flag)
+	} else {
+	    return -code error "Unknown option $flag, must be: $usage"
+	}
+    } else {
+	foreach {flag value} $args {
+	    if [regexp -- $pat $flag] {
+		set http($flag) $value
+	    } else {
+		return -code error "Unknown option $flag, must be: $usage"
+	    }
+	}
+    }
+}
+
+ proc httpFinish { token {errormsg ""} } {
+    upvar #0 $token state
+    global errorInfo errorCode
+    if {[string length $errormsg] != 0} {
+	set state(error) [list $errormsg $errorInfo $errorCode]
+	set state(status) error
+    }
+    catch {close $state(sock)}
+    catch {after cancel $state(after)}
+    if {[info exists state(-command)]} {
+	if {[catch {eval $state(-command) {$token}} err]} {
+	    if {[string length $errormsg] == 0} {
+		set state(error) [list $err $errorInfo $errorCode]
+		set state(status) error
+	    }
+	}
+	unset state(-command)
+    }
+}
+proc http_reset { token {why reset} } {
+    upvar #0 $token state
+    set state(status) $why
+    catch {fileevent $state(sock) readable {}}
+    httpFinish $token
+    if {[info exists state(error)]} {
+	set errorlist $state(error)
+	unset state(error)
+	eval error $errorlist
+    }
+}
+proc http_get { url args } {
+    global http
+    if ![info exists http(uid)] {
+	set http(uid) 0
+    }
+    set token http#[incr http(uid)]
+    upvar #0 $token state
+    http_reset $token
+    array set state {
+	-blocksize 	8192
+	-validate 	0
+	-headers 	{}
+	-timeout 	0
+	state		header
+	meta		{}
+	currentsize	0
+	totalsize	0
+        type            text/html
+        body            {}
+	status		""
+    }
+    set options {-blocksize -channel -command -handler -headers \
+		-progress -query -validate -timeout}
+    set usage [join $options ", "]
+    regsub -all -- - $options {} options
+    set pat ^-([join $options |])$
+    foreach {flag value} $args {
+	if [regexp $pat $flag] {
+	    # Validate numbers
+	    if {[info exists state($flag)] && \
+		    [regexp {^[0-9]+$} $state($flag)] && \
+		    ![regexp {^[0-9]+$} $value]} {
+		return -code error "Bad value for $flag ($value), must be integer"
+	    }
+	    set state($flag) $value
+	} else {
+	    return -code error "Unknown option $flag, can be: $usage"
+	}
+    }
+    if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)} $url \
+	    x proto host y port srvurl]} {
+	error "Unsupported URL: $url"
+    }
+    if {[string length $port] == 0} {
+	set port 80
+    }
+    if {[string length $proto] == 0} {
+	set url http://$url
+    }
+    set state(url) $url
+    if {![catch {$http(-proxyfilter) $host} proxy]} {
+	set phost [lindex $proxy 0]
+	set pport [lindex $proxy 1]
+    }
+    if {$state(-timeout) > 0} {
+	set state(after) [after $state(-timeout) [list http_reset $token timeout]]
+    }
+    if {[info exists phost] && [string length $phost]} {
+	set srvurl $url
+	set s [socket $phost $pport]
+    } else {
+	set s [socket $host $port]
+    }
+    set state(sock) $s
+
+    # Send data in cr-lf format, but accept any line terminators
+
+    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
+
+    # The following is disallowed in safe interpreters, but the socket
+    # is already in non-blocking mode in that case.
+
+    catch {fconfigure $s -blocking off}
+    set len 0
+    set how GET
+    if {[info exists state(-query)]} {
+	set len [string length $state(-query)]
+	if {$len > 0} {
+	    set how POST
+	}
+    } elseif {$state(-validate)} {
+	set how HEAD
+    }
+    puts $s "$how $srvurl HTTP/1.0"
+    puts $s "Accept: $http(-accept)"
+    puts $s "Host: $host"
+    puts $s "User-Agent: $http(-useragent)"
+    foreach {key value} $state(-headers) {
+	regsub -all \[\n\r\]  $value {} value
+	set key [string trim $key]
+	if {[string length $key]} {
+	    puts $s "$key: $value"
+	}
+    }
+    if {$len > 0} {
+	puts $s "Content-Length: $len"
+	puts $s "Content-Type: application/x-www-form-urlencoded"
+	puts $s ""
+	fconfigure $s -translation {auto binary}
+	puts $s $state(-query)
+    } else {
+	puts $s ""
+    }
+    flush $s
+    fileevent $s readable [list httpEvent $token]
+    if {! [info exists state(-command)]} {
+	http_wait $token
+    }
+    return $token
+}
+proc http_data {token} {
+    upvar #0 $token state
+    return $state(body)
+}
+proc http_status {token} {
+    upvar #0 $token state
+    return $state(status)
+}
+proc http_code {token} {
+    upvar #0 $token state
+    return $state(http)
+}
+proc http_size {token} {
+    upvar #0 $token state
+    return $state(currentsize)
+}
+
+ proc httpEvent {token} {
+    upvar #0 $token state
+    set s $state(sock)
+
+    if [eof $s] then {
+	httpEof $token
+	return
+    }
+    if {$state(state) == "header"} {
+	set n [gets $s line]
+	if {$n == 0} {
+	    set state(state) body
+	    if ![regexp -nocase ^text $state(type)] {
+		# Turn off conversions for non-text data
+		fconfigure $s -translation binary
+	    }
+	    if {[info exists state(-channel)] &&
+		    ![info exists state(-handler)]} {
+		# Initiate a sequence of background fcopies
+		fileevent $s readable {}
+		httpCopyStart $s $token
+	    }
+	} elseif {$n > 0} {
+	    if [regexp -nocase {^content-type:(.+)$} $line x type] {
+		set state(type) [string trim $type]
+	    }
+	    if [regexp -nocase {^content-length:(.+)$} $line x length] {
+		set state(totalsize) [string trim $length]
+	    }
+	    if [regexp -nocase {^([^:]+):(.+)$} $line x key value] {
+		lappend state(meta) $key $value
+	    } elseif {[regexp ^HTTP $line]} {
+		set state(http) $line
+	    }
+	}
+    } else {
+	if [catch {
+	    if {[info exists state(-handler)]} {
+		set n [eval $state(-handler) {$s $token}]
+	    } else {
+		set block [read $s $state(-blocksize)]
+		set n [string length $block]
+		if {$n >= 0} {
+		    append state(body) $block
+		}
+	    }
+	    if {$n >= 0} {
+		incr state(currentsize) $n
+	    }
+	} err] {
+	    httpFinish $token $err
+	} else {
+	    if [info exists state(-progress)] {
+		eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+	    }
+	}
+    }
+}
+ proc httpCopyStart {s token} {
+    upvar #0 $token state
+    if [catch {
+	fcopy $s $state(-channel) -size $state(-blocksize) -command \
+	    [list httpCopyDone $token]
+    } err] {
+	httpFinish $token $err
+    }
+}
+ proc httpCopyDone {token count} {
+    upvar #0 $token state
+    set s $state(sock)
+    incr state(currentsize) $count
+    if [info exists state(-progress)] {
+	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+    }
+    if [eof $s] {
+	httpEof $token
+    } else {
+	httpCopyStart $s $token
+    }
+}
+ proc httpEof {token} {
+    upvar #0 $token state
+    if {$state(state) == "header"} {
+	# Premature eof
+	set state(status) eof
+    } else {
+	set state(status) ok
+    }
+    set state(state) eof
+    httpFinish $token
+}
+proc http_wait {token} {
+    upvar #0 $token state
+    if {![info exists state(status)] || [string length $state(status)] == 0} {
+	vwait $token\(status)
+    }
+    if {[info exists state(error)]} {
+	set errorlist $state(error)
+	unset state(error)
+	eval error $errorlist
+    }
+    return $state(status)
+}
+
+# Call http_formatQuery with an even number of arguments, where the first is
+# a name, the second is a value, the third is another name, and so on.
+
+proc http_formatQuery {args} {
+    set result ""
+    set sep ""
+    foreach i $args {
+	append result  $sep [httpMapReply $i]
+	if {$sep != "="} {
+	    set sep =
+	} else {
+	    set sep &
+	}
+    }
+    return $result
+}
+
+# do x-www-urlencoded character mapping
+# The spec says: "non-alphanumeric characters are replaced by '%HH'"
+# 1 leave alphanumerics characters alone
+# 2 Convert every other character to an array lookup
+# 3 Escape constructs that are "special" to the tcl parser
+# 4 "subst" the result, doing all the array substitutions
+ 
+ proc httpMapReply {string} {
+    global httpFormMap
+    set alphanumeric	a-zA-Z0-9
+    if ![info exists httpFormMap] {
+	 
+	for {set i 1} {$i <= 256} {incr i} {
+	    set c [format %c $i]
+	    if {![string match \[$alphanumeric\] $c]} {
+		set httpFormMap($c) %[format %.2x $i]
+	    }
+	}
+	# These are handled specially
+	array set httpFormMap {
+	    " " +   \n %0d%0a
+	}
+    }
+    regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
+    regsub -all \n $string {\\n} string
+    regsub -all \t $string {\\t} string
+    regsub -all {[][{})\\]\)} $string {\\&} string
+    return [subst $string]
+}
+
+# Default proxy filter. 
+ proc httpProxyRequired {host} {
+    global http
+    if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
+	if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
+	    set http(-proxyport) 8080
+	}
+	return [list $http(-proxyhost) $http(-proxyport)]
+    } else {
+	return {}
+    }
+}
diff --git a/contrib/tcl/library/http1.0/pkgIndex.tcl b/contrib/tcl/library/http1.0/pkgIndex.tcl
new file mode 100644
index 000000000000..ab6170f7f623
--- /dev/null
+++ b/contrib/tcl/library/http1.0/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.0
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}]
diff --git a/contrib/tcl/library/init.tcl b/contrib/tcl/library/init.tcl
index 2a7cb4978cb9..43bd37c04487 100644
--- a/contrib/tcl/library/init.tcl
+++ b/contrib/tcl/library/init.tcl
@@ -3,7 +3,7 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# SCCS: @(#) init.tcl 1.57 96/07/23 08:53:03
+# SCCS: @(#) init.tcl 1.79 97/06/24 17:18:54
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -15,13 +15,27 @@
 if {[info commands package] == ""} {
     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
 }
-package require -exact Tcl 7.5
+package require -exact Tcl 8.0
+
+# Compute the auto path to use in this interpreter.
+
 if [catch {set auto_path $env(TCLLIBPATH)}] {
     set auto_path ""
 }
 if {[lsearch -exact $auto_path [info library]] < 0} {
     lappend auto_path [info library]
 }
+catch {
+    foreach dir $tcl_pkgPath {
+	if {[lsearch -exact $auto_path $dir] < 0} {
+	    lappend auto_path $dir
+	}
+    }
+    unset dir
+}
+
+# Conditionalize for presence of exec.
+
 package unknown tclPkgUnknown
 if {[info commands exec] == ""} {
 
@@ -33,6 +47,7 @@ if {[info commands exec] == ""} {
 set errorCode ""
 set errorInfo ""
 
+
 # unknown --
 # This procedure is called when a Tcl command is invoked that doesn't
 # exist in the interpreter.  It takes the following steps to make the
@@ -69,10 +84,6 @@ proc unknown args {
 	# Make sure we're not trying to load the same proc twice.
 	#
 	if [info exists unknown_pending($name)] {
-	    unset unknown_pending($name)
-	    if {[array size unknown_pending] == 0} {
-		unset unknown_pending
-	    }
 	    return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
 	}
 	set unknown_pending($name) pending;
@@ -88,7 +99,7 @@ proc unknown args {
 	if $msg {
 	    set errorCode $savedErrorCode
 	    set errorInfo $savedErrorInfo
-	    set code [catch {uplevel $args} msg]
+	    set code [catch {uplevel 1 $args} msg]
 	    if {$code ==  1} {
 		#
 		# Strip the last five lines off the error stack (they're
@@ -107,16 +118,22 @@ proc unknown args {
     if {([info level] == 1) && ([info script] == "") \
 	    && [info exists tcl_interactive] && $tcl_interactive} {
 	if ![info exists auto_noexec] {
-	    if [auto_execok $name] {
+	    set new [auto_execok $name]
+	    if {$new != ""} {
 		set errorCode $savedErrorCode
 		set errorInfo $savedErrorInfo
-		return [uplevel exec >&@stdout <@stdin $args]
+		set redir ""
+		if {[info commands console] == ""} {
+		    set redir ">&@stdout <@stdin"
+		}
+		return [uplevel exec $redir $new [lrange $args 1 end]]
 	    }
 	}
 	set errorCode $savedErrorCode
 	set errorInfo $savedErrorInfo
 	if {$name == "!!"} {
-	    return [uplevel {history redo}]
+#	    return [uplevel {history redo}]
+	    return -code error "!! is disabled until history is fixed in Tcl8.0"
 	}
 	if [regexp {^!(.+)$} $name dummy event] {
 	    return [uplevel [list history redo $event]]
@@ -124,7 +141,15 @@ proc unknown args {
 	if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
 	    return [uplevel [list history substitute $old $new]]
 	}
-	set cmds [info commands $name*]
+
+	set ret [catch {set cmds [info commands $name*]} msg]
+	if {[string compare $name "::"] == 0} {
+	    set name ""
+	}
+	if {$ret != 0} {
+	    return -code $ret -errorcode $errorCode \
+		"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
+	}
 	if {[llength $cmds] == 1} {
 	    return [uplevel [lreplace $args 0 0 $cmds]]
 	}
@@ -165,35 +190,45 @@ proc auto_load cmd {
 	}
     }
     set auto_oldpath $auto_path
+
+    # Check if we are a safe interpreter. In that case, we support only
+    # newer format tclIndex files.
+
+    set issafe [interp issafe]
     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
 	set dir [lindex $auto_path $i]
 	set f ""
-	if [catch {set f [open [file join $dir tclIndex]]}] {
+	if {$issafe} {
+	    catch {source [file join $dir tclIndex]}
+	} elseif [catch {set f [open [file join $dir tclIndex]]}] {
 	    continue
-	}
-	set error [catch {
-	    set id [gets $f]
-	    if {$id == "# Tcl autoload index file, version 2.0"} {
-		eval [read $f]
-	    } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
-		while {[gets $f line] >= 0} {
-		    if {([string index $line 0] == "#")
-			    || ([llength $line] != 2)} {
-			continue
+	} else {
+	    set error [catch {
+		set id [gets $f]
+		if {$id == "# Tcl autoload index file, version 2.0"} {
+		    eval [read $f]
+		} elseif {$id == \
+		    "# Tcl autoload index file: each line identifies a Tcl"} {
+		    while {[gets $f line] >= 0} {
+			if {([string index $line 0] == "#")
+				|| ([llength $line] != 2)} {
+			    continue
+			}
+			set name [lindex $line 0]
+			set auto_index($name) \
+			    "source [file join $dir [lindex $line 1]]"
 		    }
-		    set name [lindex $line 0]
-		    set auto_index($name) \
-			"source [file join $dir [lindex $line 1]]"
+		} else {
+		    error \
+		      "[file join $dir tclIndex] isn't a proper Tcl index file"
 		}
-	    } else {
-		error "[file join $dir tclIndex] isn't a proper Tcl index file"
+	    } msg]
+	    if {$f != ""} {
+		close $f
+	    }
+	    if $error {
+		error $msg $errorInfo $errorCode
 	    }
-	} msg]
-	if {$f != ""} {
-	    close $f
-	}
-	if $error {
-	    error $msg $errorInfo $errorCode
 	}
     }
     if [info exists auto_index($cmd)] {
@@ -209,9 +244,11 @@ if {[string compare $tcl_platform(platform) windows] == 0} {
 
 # auto_execok --
 #
-# Returns 1 if there's an executable in the current path for the
-# given name, 0 otherwise.  Builds an associative array auto_execs
-# that caches information about previous checks, for speed.
+# Returns string that indicates name of program to execute if 
+# name corresponds to a shell builtin or an executable in the
+# Windows search path, or "" otherwise.  Builds an associative 
+# array auto_execs that caches information about previous checks, 
+# for speed.
 #
 # Arguments: 
 # name -			Name of a command.
@@ -224,47 +261,69 @@ if {[string compare $tcl_platform(platform) windows] == 0} {
 # components are separated with semicolons, not colons as under Unix.
 #
 proc auto_execok name {
-    global auto_execs env
+    global auto_execs env tcl_platform
 
     if [info exists auto_execs($name)] {
 	return $auto_execs($name)
     }
-    set auto_execs($name) 0
-    if {[file pathtype $name] != "relative"} {
-	foreach ext {{} .exe .bat .cmd} {
-	    if {[file exists ${name}${ext}]
-		&& ![file isdirectory ${name}${ext}]} {
-		set auto_execs($name) 1
+    set auto_execs($name) ""
+
+    if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename 
+	    ren rmdir rd time type ver vol} $name] != -1} {
+	return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
+    }
+
+    if {[llength [file split $name]] != 1} {
+	foreach ext {{} .com .exe .bat} {
+	    set file ${name}${ext}
+	    if {[file exists $file] && ![file isdirectory $file]} {
+		return [set auto_execs($name) [list $file]]
 	    }
 	}
-	return $auto_execs($name)
+	return ""
     }
-    if {! [info exists env(PATH)]} {
-	if [info exists env(Path)] {
-	    set path $env(Path)
-	} else {
-	    return 0
+
+    set path "[file dirname [info nameof]];.;"
+    if {[info exists env(WINDIR)]} {
+	set windir $env(WINDIR) 
+    }
+    if {[info exists windir]} {
+	if {$tcl_platform(os) == "Windows NT"} {
+	    append path "$windir/system32;"
 	}
-    } else {
-	set path $env(PATH)
+	append path "$windir/system;$windir;"
+    }
+
+    if {[info exists env(PATH)]} {
+	append path $env(PATH)
     }
+
     foreach dir [split $path {;}] {
 	if {$dir == ""} {
 	    set dir .
 	}
-	foreach ext {{} .exe .bat .cmd} {
+	foreach ext {{} .com .exe .bat} {
 	    set file [file join $dir ${name}${ext}]
 	    if {[file exists $file] && ![file isdirectory $file]} {
-		set auto_execs($name) 1
-		return 1
+		return [set auto_execs($name) [list $file]]
 	    }
 	}
     }
-    return 0
+    return ""
 }
 
 } else {
 
+# auto_execok --
+#
+# Returns string that indicates name of program to execute if 
+# name corresponds to an executable in the path. Builds an associative 
+# array auto_execs that caches information about previous checks, 
+# for speed.
+#
+# Arguments: 
+# name -			Name of a command.
+
 # Unix version.
 #
 proc auto_execok name {
@@ -273,10 +332,10 @@ proc auto_execok name {
     if [info exists auto_execs($name)] {
 	return $auto_execs($name)
     }
-    set auto_execs($name) 0
-    if {[file pathtype $name] != "relative"} {
+    set auto_execs($name) ""
+    if {[llength [file split $name]] != 1} {
 	if {[file executable $name] && ![file isdirectory $name]} {
-	    set auto_execs($name) 1
+	    set auto_execs($name) [list $name]
 	}
 	return $auto_execs($name)
     }
@@ -286,11 +345,11 @@ proc auto_execok name {
 	}
 	set file [file join $dir $name]
 	if {[file executable $file] && ![file isdirectory $file]} {
-	    set auto_execs($name) 1
-	    return 1
+	    set auto_execs($name) [list $file]
+	    return $auto_execs($name)
 	}
     }
-    return 0
+    return ""
 }
 
 }
@@ -524,11 +583,30 @@ proc tclPkgSetup {dir pkg version files} {
     }
 }
 
+# tclMacPkgSearch --
+# The procedure is used on the Macintosh to search a given directory for files
+# with a TEXT resource named "pkgIndex".  If it exists it is sourced in to the
+# interpreter to setup the package database.
+
+proc tclMacPkgSearch {dir} {
+    foreach x [glob -nocomplain [file join $dir *.shlb]] {
+	if [file isfile $x] {
+	    set res [resource open $x]
+	    foreach y [resource list TEXT $res] {
+		if {$y == "pkgIndex"} {source -rsrc pkgIndex}
+	    }
+	    resource close $res
+	}
+    }
+}
+
 # tclPkgUnknown --
 # This procedure provides the default for the "package unknown" function.
 # It is invoked when a package that's needed can't be found.  It scans
-# the auto_path directories looking for pkgIndex.tcl files and sources any
-# such files that are found to setup the package database.
+# the auto_path directories and their immediate children looking for
+# pkgIndex.tcl files and sources any such files that are found to setup
+# the package database.  (On the Macintosh we also search for pkgIndex
+# TEXT resources in all files.)
 #
 # Arguments:
 # name -		Name of desired package.  Not used.
@@ -536,16 +614,47 @@ proc tclPkgSetup {dir pkg version files} {
 # exact -		Either "-exact" or omitted.  Not used.
 
 proc tclPkgUnknown {name version {exact {}}} {
-    global auto_path
+    global auto_path tcl_platform env dir
 
     if ![info exists auto_path] {
 	return
     }
+    if {[info exists dir]} {
+	set save_dir $dir
+    }
     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
+	foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
+		* pkgIndex.tcl]] {
+	    set dir [file dirname $file]
+	    if [catch {source $file} msg] {
+		puts stderr \
+		    "error reading package index file $file: $msg"
+	    }
+	}
 	set dir [lindex $auto_path $i]
 	set file [file join $dir pkgIndex.tcl]
 	if [file readable $file] {
-	    source $file
+	    if [catch {source $file} msg] {
+		puts stderr \
+		    "error reading package index file $file: $msg"
+	    }
+	}
+	# On the Macintosh we also look in the resource fork 
+	# of shared libraries
+	if {$tcl_platform(platform) == "macintosh"} {
+	    set dir [lindex $auto_path $i]
+	    tclMacPkgSearch $dir
+	    foreach x [glob -nocomplain [file join $dir *]] {
+		if [file isdirectory $x] {
+		    set dir $x
+		    tclMacPkgSearch $dir
+		}
+	    }
 	}
     }
+    if {[info exists save_dir]} {
+	set dir $save_dir
+    } else {
+	unset dir
+    }
 }
diff --git a/contrib/tcl/library/ldAout.tcl b/contrib/tcl/library/ldAout.tcl
index 5a928931d597..79145081901f 100644
--- a/contrib/tcl/library/ldAout.tcl
+++ b/contrib/tcl/library/ldAout.tcl
@@ -18,7 +18,7 @@
 #	its .o file placed before all others in the command; then
 #	"ld" is executed to bind the objects together.
 #
-# SCCS: @(#) ldAout.tcl 1.10 96/05/18 16:40:42
+# SCCS: @(#) ldAout.tcl 1.12 96/11/30 17:11:02
 #
 # Copyright (c) 1995, by General Electric Company. All rights reserved.
 #
@@ -44,12 +44,10 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
   # function now accepts both 2 and 3 parameters.
 
   if {$shlib_suffix==""} {
-    set shlib_suffix $env(SHLIB_SUFFIX)
     set shlib_cflags $env(SHLIB_CFLAGS)
   } else {
     if {$shlib_cflags=="none"} {
       set shlib_cflags $shlib_suffix
-      set shlib_suffix [info sharedlibextension]
     }
   }
 
@@ -112,7 +110,6 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
     }
   }
   lappend libdirs /lib /usr/lib
-  lappend libraries -lm -lc
 
   # MIPS -- If there are corresponding G0 libraries, replace the
   # ordinary ones with the G0 ones.
@@ -140,9 +137,15 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
     error "-o option must be supplied to link a Tcl load module"
   }
   set m [file tail $outputFile]
-  set l [expr [string length $m] - [string length $shlib_suffix]]
-  if [string compare [string range $m $l end] $shlib_suffix] {
-    error "Output file does not appear to have a $shlib_suffix suffix"
+  if [regexp {\.a$} $outputFile] {
+    set shlib_suffix .a
+  } else {
+    set shlib_suffix ""
+  }
+  if [regexp {\..*$} $outputFile match] {
+    set l [expr [string length $m] - [string length $match]]
+  } else {
+    error "Output file does not appear to have a suffix"
   }
   set modName [string tolower [string range $m 0 [expr $l-1]]]
   if [regexp {^lib} $modName] {
@@ -212,16 +215,24 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
 
   # Now compose and execute the ld command that packages the module
 
+  if {$shlib_suffix == ".a"} {
+    set ldCommand "ar cr $outputFile"
+    regsub { -o} $tail {} tail
+  } else {
   set ldCommand ld
   foreach item $head {
     lappend ldCommand $item
   }
+  }
   lappend ldCommand tcl$modName.o
   foreach item $tail {
     lappend ldCommand $item
   }
   puts stderr $ldCommand
   eval exec $ldCommand
+  if {$shlib_suffix == ".a"} {
+    exec ranlib $outputFile
+  }
 
   # Clean up working files
 
diff --git a/contrib/tcl/library/safeinit.tcl b/contrib/tcl/library/safeinit.tcl
new file mode 100644
index 000000000000..e1ce1a039599
--- /dev/null
+++ b/contrib/tcl/library/safeinit.tcl
@@ -0,0 +1,461 @@
+# safeinit.tcl --
+#
+# This code runs in a master to manage a safe slave with Safe Tcl.
+# See the safe.n man page for details.
+#
+# Copyright (c) 1996-1997 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) safeinit.tcl 1.38 97/06/20 12:57:39
+
+# This procedure creates a safe slave, initializes it with the
+# safe base and installs the aliases for the security policy mechanism.
+
+proc tcl_safeCreateInterp {slave} {
+    global auto_path
+
+    # Create the slave.
+    interp create -safe $slave
+
+    # Set its auto_path
+    interp eval $slave [list set auto_path $auto_path]
+
+    # And initialize it.
+    return [tcl_safeInitInterp $slave]
+}
+
+# This procedure applies the initializations to an already existing
+# interpreter. It is useful when you want to enable an interpreter
+# created with "interp create -safe" to use security policies.
+
+proc tcl_safeInitInterp {slave} {
+    upvar #0 tclSafe$slave state
+    global tcl_library tk_library auto_path tcl_platform
+
+    # These aliases let the slave load files to define new commands
+
+    interp alias $slave source {} tclSafeAliasSource $slave
+    interp alias $slave load {} tclSafeAliasLoad $slave
+
+    # This alias lets the slave have access to a subset of the 'file'
+    # command functionality.
+    tclAliasSubset $slave file file dir.* join root.* ext.* tail \
+	path.* split
+
+    # This alias interposes on the 'exit' command and cleanly terminates
+    # the slave.
+    interp alias $slave exit {} tcl_safeDeleteInterp $slave
+
+    # Source init.tcl into the slave, to get auto_load and other
+    # procedures defined:
+
+    if {$tcl_platform(platform) == "macintosh"} {
+	if {[catch {interp eval $slave [list source -rsrc Init]}]} {
+	    if {[catch {interp eval $slave \
+			[list source [file join $tcl_library init.tcl]]}]} {
+		error "can't source init.tcl into slave $slave"
+	    }
+	}
+    } else {
+	if {[catch {interp eval $slave \
+			[list source [file join $tcl_library init.tcl]]}]} {
+	    error "can't source init.tcl into slave $slave"
+	}
+    }
+
+    # Loading packages into slaves is handled by their master.
+    # This is overloaded to deal with regular packages and security policies
+
+    interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave
+    interp eval $slave {package unknown tclPkgUnknown}
+
+    # We need a helper procedure to define a $dir variable and then
+    # do a source of the pkgIndex.tcl file
+    interp eval $slave \
+	[list proc tclPkgSource {dir args} {
+		if {[llength $args] == 2} {
+		    source [lindex $args 0] [lindex $args 1]
+		} else {
+		    source [lindex $args 0]
+		}
+	      }]
+
+    # Let the slave inherit a few variables
+    foreach varName \
+	{tcl_library tcl_version tcl_patchLevel \
+	 tcl_platform(platform) auto_path} {
+	upvar #0 $varName var
+	interp eval $slave [list set $varName $var]
+    }
+
+    # Other variables are predefined with set values
+    foreach {varName value} {
+	    auto_noexec 1
+	    errorCode {}
+	    errorInfo {}
+	    env() {}
+	    argv0 {}
+	    argv {}
+	    argc 0
+	    tcl_interactive 0
+	    } {
+	interp eval $slave [list set $varName $value]
+    }
+
+    # If auto_path is not set in the slave, set it to empty so it has
+    # a value and exists. Otherwise auto_loading and package require
+    # will complain.
+
+    interp eval $slave {
+	if {![info exists auto_path]} {
+	    set auto_path {}
+	}
+    }
+
+    # If we have Tk, make the slave have the same library as us:
+
+    if {[info exists tk_library]} {
+        interp eval $slave [list set tk_library $tk_library]
+    }
+
+    # Stub out auto-exec mechanism in slave
+    interp eval $slave [list proc auto_execok {name} {return {}}]
+
+    return $slave
+}
+
+# This procedure deletes a safe slave managed by Safe Tcl and
+# cleans up associated state:
+
+proc tcl_safeDeleteInterp {slave args} {
+    upvar #0 tclSafe$slave state
+
+    # If the slave has a policy loaded, clean it up now.
+    if {[info exists state(policyLoaded)]} {
+	set policy $state(policyLoaded)
+	set proc ${policy}_PolicyCleanup
+	if {[string compare [info proc $proc] $proc] == 0} {
+	    $proc $slave
+	}
+    }
+
+    # Discard the global array of state associated with the slave, and
+    # delete the interpreter.
+    catch {unset state}
+    catch {interp delete $slave}
+
+    return
+}
+
+# This procedure computes the global security policy search path.
+
+proc tclSafeComputePolicyPath {} {
+    global auto_path tclSafeAutoPathComputed tclSafePolicyPath
+
+    set recompute 0
+    if {(![info exists tclSafePolicyPath]) ||
+	    ("$tclSafePolicyPath" == "")} {
+	set tclSafePolicyPath ""
+	set tclSafeAutoPathComputed ""
+	set recompute 1
+    }
+    if {"$tclSafeAutoPathComputed" != "$auto_path"} {
+	set recompute 1
+	set tclSafeAutoPathComputed $auto_path
+    }
+    if {$recompute == 1} {
+	set tclSafePolicyPath ""
+	foreach i $auto_path {
+	    lappend tclSafePolicyPath [file join $i policies]
+	}
+    }
+    return $tclSafePolicyPath
+}
+
+# ---------------------------------------------------------------------------
+# ---------------------------------------------------------------------------
+
+# tclSafeAliasSource is the target of the "source" alias in safe interpreters.
+
+proc tclSafeAliasSource {slave args} {
+    global auto_path errorCode errorInfo
+
+    if {[llength $args] == 2} {
+	if {[string compare "-rsrc" [lindex $args 0]] != 0} {
+	    return -code error "incorrect arguments to source"
+	}
+	if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \
+		 msg]} {
+	    return -code error $msg
+	}
+    } else {
+	set file [lindex $args 0]
+	if {[catch {tclFileInPath $file $auto_path $slave} msg]} {
+	    return -code error "permission denied"
+	}
+	set errorInfo ""
+	if {[catch {interp invokehidden $slave source $file} msg]} {
+	    return -code error $msg
+	}
+    }
+    return $msg
+}
+
+# tclSafeAliasLoad is the target of the "load" alias in safe interpreters.
+
+proc tclSafeAliasLoad {slave file args} {
+    global auto_path
+
+    if {[llength $args] == 2} {
+	# Trying to load into another interpreter
+	# Allow this for a child of the slave, or itself
+	set other [lindex $args 1]
+	foreach x $slave y $other {
+	    if {[string length $x] == 0} {
+		break
+	    } elseif {[string compare $x $y] != 0} {
+		return -code error "permission denied"
+	    }
+	}
+	set slave $other
+    }
+
+    if {[string length $file] && \
+		[catch {tclFileInPath $file $auto_path $slave} msg]} {
+	return -code error "permission denied"
+    }
+    if {[catch {
+	switch [llength $args] {
+	    0 {
+		interp invokehidden $slave load $file
+	    }
+	    1 -
+	    2 {
+		interp invokehidden $slave load $file [lindex $args 0]
+	    }
+	    default {
+		error "too many arguments to load"
+	    }
+	}
+    } msg]} {
+	return -code error $msg
+    }
+    return $msg
+}
+
+# tclFileInPath raises an error if the file is not found in
+# the list of directories contained in path.
+
+proc tclFileInPath {file path slave} {
+    set realcheckpath [tclSafeCheckAutoPath $path $slave]
+    set pwd [pwd]
+    if {[file isdirectory $file]} {
+	error "$file: not found"
+    }
+    set parent [file dirname $file]
+    if {[catch {cd $parent} msg]} {
+	error "$file: not found"
+    }
+    set realfilepath [file split [pwd]]
+    foreach dir $realcheckpath {
+	set match 1
+	foreach a [file split $dir] b $realfilepath {
+	    if {[string length $a] == 0} {
+		break
+	    } elseif {[string compare $a $b] != 0} {
+		set match 0
+		break
+	    }
+	}
+	if {$match} {
+	    cd $pwd
+	    return 1
+	}
+    }
+    cd $pwd
+    error "$file: not found"
+}
+
+# This procedure computes our expanded copy of the path, as needed.
+# It returns the path after expanding out all aliases.
+
+proc tclSafeCheckAutoPath {path slave} {
+    global auto_path
+    upvar #0 tclSafe$slave state
+
+    if {![info exists state(expanded_auto_path)]} {
+	# Compute for the first time:
+	set state(cached_auto_path) $path
+    } elseif {"$state(cached_auto_path)" != "$path"} {
+	# The value of our path changed, so recompute:
+	set state(cached_auto_path) $path
+    } else {
+	# No change: no need to recompute.
+	return $state(expanded_auto_path)
+    }
+
+    set pwd [pwd]
+    set state(expanded_auto_path) ""
+    foreach dir $state(cached_auto_path) {
+	if {![catch {cd $dir}]} {
+	    lappend state(expanded_auto_path) [pwd]
+	}
+    }
+    cd $pwd
+    return $state(expanded_auto_path)
+}
+
+proc tclSafeAliasPkgUnknown {slave package version {exact {}}} {
+    tclSafeLoadPkg $slave $package $version $exact
+}
+
+proc tclSafeLoadPkg {slave package version exact} {
+    if {[string length $version] == 0} {
+	set version 1.0
+    }
+    tclSafeLoadPkgInternal $slave $package $version $exact 0
+}
+
+proc tclSafeLoadPkgInternal {slave package version exact round} {
+    global auto_path
+    upvar #0 tclSafe$slave state
+
+    # Search the policy path again; it might have changed in the meantime.
+
+    if {$round == 1} {
+	tclSafeResearchPolicyPath
+
+	if {[tclSafeLoadPolicy $slave $package $version]} {
+	    return
+	}
+    }
+
+    # Try to load as a policy.
+
+    if [tclSafeLoadPolicy $slave $package $version] {
+	return
+    }
+
+    # The package is not a security policy, so do the regular setup.
+
+    # Here we run tclPkgUnknown in the master, but we hijack
+    # the source command so the setup ends up happening in the slave.
+
+    rename source source.orig
+    proc source {args} "upvar dir dir
+	interp eval [list $slave] tclPkgSource \[list \$dir\] \$args"
+
+    if [catch {tclPkgUnknown $package $version $exact} err] {
+	global errorInfo
+
+	rename source {}
+	rename source.orig source
+
+	error "$err\n$errorInfo"
+    }
+    rename source {}
+    rename source.orig source
+
+    # If we are in the first round, check if the package
+    # is now known in the slave:
+
+    if {$round == 0} {
+        set ifneeded \
+		[interp eval $slave [list package ifneeded $package $version]]
+
+	if {"$ifneeded" == ""} {
+	    return [tclSafeLoadPkgInternal $slave $package $version $exact 1]
+	}
+    }
+}
+
+proc tclSafeResearchPolicyPath {} {
+    global tclSafePolicyPath auto_index auto_path
+
+    # If there was no change, do not search again.
+
+    if {![info exists tclSafePolicyPath]} {
+	set tclSafePolicyPath ""
+    }
+    set oldPolicyPath $tclSafePolicyPath
+    set newPolicyPath [tclSafeComputePolicyPath]
+    if {"$newPolicyPath" == "$oldPolicyPath"} {
+	return
+    }
+
+    # Loop through the path from back to front so early directories
+    # end up overriding later directories.  This code is like auto_load,
+    # but only new-style tclIndex files (version 2) are supported.
+
+    for {set i [expr [llength $newPolicyPath] - 1]} \
+	    {$i >= 0} \
+	    {incr i -1} {
+	set dir [lindex $newPolicyPath $i]
+        set file [file join $dir tclIndex]
+	if {[file exists $file]} {
+	    if {[catch {source $file} msg]} {
+		puts stderr "error sourcing $file: $msg"
+	    }
+	}
+	foreach file [lsort [glob -nocomplain [file join $dir *]]] {
+	    if {[file isdir $file]} {
+		set dir $file
+		set file [file join $file tclIndex]
+		if {[file exists $file]} {
+		    if {[catch {source $file} msg]} {
+			puts stderr "error sourcing $file: $msg"
+		    }
+		}
+	    }
+	}
+    }
+}
+
+proc tclSafeLoadPolicy {slave package version} {
+    upvar #0 tclSafe$slave state
+    global auto_index
+
+    set proc ${package}_PolicyInit
+
+    if {[info command $proc] == "$proc" ||
+	    [info exists auto_index($proc)]} {
+	if [info exists state(policyLoaded)] {
+	    error "security policy $state(policyLoaded) already loaded"
+	}	
+	$proc $slave $version
+	interp eval $slave [list package provide $package $version]
+	set state(policyLoaded) $package
+	return 1
+    } else {
+	return 0
+    }
+}
+# This procedure enables access from a safe interpreter to only a subset of
+# the subcommands of a command:
+
+proc tclSafeSubset {command okpat args} {
+    set subcommand [lindex $args 0]
+    if {[regexp $okpat $subcommand]} {
+	return [eval {$command $subcommand} [lrange $args 1 end]]
+    }
+    error "not allowed to invoke subcommand $subcommand of $command"
+}
+
+# This procedure installs an alias in a slave that invokes "safesubset"
+# in the master to execute allowed subcommands. It precomputes the pattern
+# of allowed subcommands; you can use wildcards in the pattern if you wish
+# to allow subcommand abbreviation.
+#
+# Syntax is: tclAliasSubset slave alias target subcommand1 subcommand2...
+
+proc tclAliasSubset {slave alias target args} {
+    set pat ^(; set sep ""
+    foreach sub $args {
+	append pat $sep$sub
+	set sep |
+    }
+    append pat )\$
+    interp alias $slave $alias {} tclSafeSubset $target $pat
+}
diff --git a/contrib/tcl/library/tclIndex b/contrib/tcl/library/tclIndex
index 98ceff171f9c..a0acc86af8e2 100644
--- a/contrib/tcl/library/tclIndex
+++ b/contrib/tcl/library/tclIndex
@@ -6,6 +6,28 @@
 # element name is the name of a command and the value is
 # a script that loads the command.
 
+set auto_index(parray) [list source [file join $dir parray.tcl]]
+set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]
+set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]]
+set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]]
+set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]]
+set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]]
+set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
+set auto_index(tcl_safeCreateInterp) [list source [file join $dir safeinit.tcl]]
+set auto_index(tcl_safeInitInterp) [list source [file join $dir safeinit.tcl]]
+set auto_index(tcl_safeDeleteInterp) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeComputePolicyPath) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeAliasSource) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeAliasLoad) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclFileInPath) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeCheckAutoPath) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeAliasPkgUnknown) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeLoadPkg) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeLoadPkgInternal) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeResearchPolicyPath) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeLoadPolicy) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclSafeSubset) [list source [file join $dir safeinit.tcl]]
+set auto_index(tclAliasSubset) [list source [file join $dir safeinit.tcl]]
 set auto_index(unknown) [list source [file join $dir init.tcl]]
 set auto_index(auto_load) [list source [file join $dir init.tcl]]
 set auto_index(auto_execok) [list source [file join $dir init.tcl]]
@@ -14,6 +36,5 @@ set auto_index(auto_reset) [list source [file join $dir init.tcl]]
 set auto_index(auto_mkindex) [list source [file join $dir init.tcl]]
 set auto_index(pkg_mkIndex) [list source [file join $dir init.tcl]]
 set auto_index(tclPkgSetup) [list source [file join $dir init.tcl]]
+set auto_index(tclMacPkgSearch) [list source [file join $dir init.tcl]]
 set auto_index(tclPkgUnknown) [list source [file join $dir init.tcl]]
-set auto_index(parray) [list source [file join $dir parray.tcl]]
-set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]]
diff --git a/contrib/tcl/library/word.tcl b/contrib/tcl/library/word.tcl
new file mode 100644
index 000000000000..64639f221629
--- /dev/null
+++ b/contrib/tcl/library/word.tcl
@@ -0,0 +1,135 @@
+# word.tcl --
+#
+# This file defines various procedures for computing word boundaries
+# in strings.  This file is primarily needed so Tk text and entry
+# widgets behave properly for different platforms.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# SCCS: @(#) word.tcl 1.2 96/11/20 14:07:22
+# 
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+# The following variables are used to determine which characters are
+# interpreted as white space.  
+
+if {$tcl_platform(platform) == "windows"} {
+    # Windows style - any but space, tab, or newline
+    set tcl_wordchars "\[^ \t\n\]"
+    set tcl_nonwordchars "\[ \t\n\]"
+} else {
+    # Motif style - any number, letter, or underscore
+    set tcl_wordchars {[a-zA-Z0-9_]}
+    set tcl_nonwordchars {[^a-zA-Z0-9_]}
+}
+
+# tcl_wordBreakAfter --
+#
+# This procedure returns the index of the first word boundary
+# after the starting point in the given string, or -1 if there
+# are no more boundaries in the given string.  The index returned refers
+# to the first character of the pair that comprises a boundary.
+#
+# Arguments:
+# str -		String to search.
+# start -	Index into string specifying starting point.
+
+proc tcl_wordBreakAfter {str start} {
+    global tcl_nonwordchars tcl_wordchars
+    set str [string range $str $start end]
+    if [regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result] {
+	return [expr [lindex $result 1] + $start]
+    }
+    return -1
+}
+
+# tcl_wordBreakBefore --
+#
+# This procedure returns the index of the first word boundary
+# before the starting point in the given string, or -1 if there
+# are no more boundaries in the given string.  The index returned
+# refers to the second character of the pair that comprises a boundary.
+#
+# Arguments:
+# str -		String to search.
+# start -	Index into string specifying starting point.
+
+proc tcl_wordBreakBefore {str start} {
+    global tcl_nonwordchars tcl_wordchars
+    if {[string compare $start end] == 0} {
+	set start [string length $str]
+    }
+    if [regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result] {
+	return [lindex $result 1]
+    }
+    return -1
+}
+
+# tcl_endOfWord --
+#
+# This procedure returns the index of the first end-of-word location
+# after a starting index in the given string.  An end-of-word location
+# is defined to be the first whitespace character following the first
+# non-whitespace character after the starting point.  Returns -1 if
+# there are no more words after the starting point.
+#
+# Arguments:
+# str -		String to search.
+# start -	Index into string specifying starting point.
+
+proc tcl_endOfWord {str start} {
+    global tcl_nonwordchars tcl_wordchars
+    if [regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \
+	    [string range $str $start end] result] {
+	return [expr [lindex $result 1] + $start]
+    }
+    return -1
+}
+
+# tcl_startOfNextWord --
+#
+# This procedure returns the index of the first start-of-word location
+# after a starting index in the given string.  A start-of-word
+# location is defined to be a non-whitespace character following a
+# whitespace character.  Returns -1 if there are no more start-of-word
+# locations after the starting point.
+#
+# Arguments:
+# str -		String to search.
+# start -	Index into string specifying starting point.
+
+proc tcl_startOfNextWord {str start} {
+    global tcl_nonwordchars tcl_wordchars
+    if [regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \
+	    [string range $str $start end] result] {
+	return [expr [lindex $result 1] + $start]
+    }
+    return -1
+}
+
+# tcl_startOfPreviousWord --
+#
+# This procedure returns the index of the first start-of-word location
+# before a starting index in the given string.
+#
+# Arguments:
+# str -		String to search.
+# start -	Index into string specifying starting point.
+
+proc tcl_startOfPreviousWord {str start} {
+    global tcl_nonwordchars tcl_wordchars
+    if {[string compare $start end] == 0} {
+	set start [string length $str]
+    }
+    if [regexp -indices \
+	    "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
+	    [string range $str 0 [expr $start - 1]] result word] {
+	return [lindex $word 0]
+    }
+    return -1
+}