aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/library
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1997-07-25 19:27:55 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1997-07-25 19:27:55 +0000
commit3d33409926539d866dcea9fc5cb14113b312adf0 (patch)
treed2f88b3e9ffa79ffb2cc1a0699dd3ee96c47c3e5 /contrib/tcl/library
parent8569730d6bc2e4cb5e784997313325b13518e066 (diff)
downloadsrc-3d33409926539d866dcea9fc5cb14113b312adf0.tar.gz
src-3d33409926539d866dcea9fc5cb14113b312adf0.zip
Import TCL release 8.0 beta 2.
Notes
Notes: svn path=/vendor/tcl/dist/; revision=27676
Diffstat (limited to 'contrib/tcl/library')
-rw-r--r--contrib/tcl/library/http1.0/http.tcl371
-rw-r--r--contrib/tcl/library/http1.0/pkgIndex.tcl11
-rw-r--r--contrib/tcl/library/init.tcl239
-rw-r--r--contrib/tcl/library/ldAout.tcl25
-rw-r--r--contrib/tcl/library/safeinit.tcl461
-rw-r--r--contrib/tcl/library/tclIndex25
-rw-r--r--contrib/tcl/library/word.tcl135
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
+}