summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog11
-rw-r--r--library/auto.tcl28
-rw-r--r--library/history.tcl14
-rw-r--r--library/init.tcl57
-rw-r--r--library/package.tcl26
-rw-r--r--library/safe.tcl21
-rw-r--r--library/word.tcl8
7 files changed, 86 insertions, 79 deletions
diff --git a/ChangeLog b/ChangeLog
index bf13767..961d32b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,13 @@
-2005-07-22 Mo DeJong <mdejong@users.sourceforge.net>
+2005-07-23 Don Porter <dgp@users.sourceforge.net>
+
+ * library/auto.tcl: Updates to the Tcl script library to make
+ * library/history.tcl: use of Tcl 8.4 features. Forward port of
+ * library/init.tcl: appropriate portions of [Patch 1237755].
+ * library/package.tcl:
+ * library/safe.tcl:
+ * library/word.tcl:
+
+2005-07-23 Mo DeJong <mdejong@users.sourceforge.net>
* tests/string.test: Add string is tests for
functionality that was not tested.
diff --git a/library/auto.tcl b/library/auto.tcl
index 94d0628..63260e7 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -3,7 +3,7 @@
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
-# RCS: @(#) $Id: auto.tcl,v 1.26 2005/06/24 23:32:26 dgp Exp $
+# RCS: @(#) $Id: auto.tcl,v 1.27 2005/07/23 04:12:48 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -62,8 +62,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# The C application may have hardwired a path, which we honor
- set variableSet [info exists the_library]
- if {$variableSet && $the_library ne ""} {
+ if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
@@ -157,9 +156,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
}
}
}
- if {!$variableSet} {
- unset the_library
- }
+ unset -nocomplain the_library
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
append msg "$errors\n\n"
@@ -215,7 +212,7 @@ proc auto_mkindex {dir args} {
}
auto_mkindex_parser::init
- foreach file [glob {expand}$args] {
+ foreach file [glob -- {expand}$args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
append index $msg
} else {
@@ -248,7 +245,7 @@ proc auto_mkindex_old {dir args} {
if {[llength $args] == 0} {
set args *.tcl
}
- foreach file [glob {expand}$args] {
+ foreach file [glob -- {expand}$args] {
set f ""
set error [catch {
set f [open $file]
@@ -444,11 +441,10 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
- if {[string equal $ns ""]} {
- set fakeName "[namespace current]::_%@fake_$tail"
+ if {$ns eq ""} {
+ set fakeName [namespace current]::_%@fake_$tail
} else {
- set fakeName [string map {:: _} "_%@fake_$name"]
- set fakeName "[namespace current]::$fakeName"
+ set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
}
proc $fakeName $arglist $body
@@ -457,7 +453,7 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
# we have to build procs with the fully qualified names, and
# have the procs point to the aliases.
- if {[string match "*::*" $name]} {
+ if {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
@@ -507,7 +503,7 @@ proc auto_mkindex_parser::fullname {name} {
}
}
- if {[string equal [namespace qualifiers $name] ""]} {
+ if {[namespace qualifiers $name] eq ""} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
@@ -551,7 +547,7 @@ auto_mkindex_parser::command proc {name args} {
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
- if {[llength [info commands tbcload::bcproc]] == 0} {
+ if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
@@ -602,7 +598,7 @@ auto_mkindex_parser::command namespace {op args} {
variable parser
variable imports
foreach pattern $args {
- if {[string compare $pattern "-force"]} {
+ if {$pattern ne "-force"} {
lappend imports $pattern
}
}
diff --git a/library/history.tcl b/library/history.tcl
index 7304d2a..3a3f16a 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -2,7 +2,7 @@
#
# Implementation of the history command.
#
-# RCS: @(#) $Id: history.tcl,v 1.6 2003/03/19 21:57:42 dgp Exp $
+# RCS: @(#) $Id: history.tcl,v 1.7 2005/07/23 04:12:49 dgp Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
@@ -168,14 +168,14 @@ proc history {args} {
variable history
# Do not add empty commands to the history
- if {[string trim $command] == ""} {
+ if {[string trim $command] eq ""} {
return ""
}
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
- if {[info exists history($j)]} {unset history($j)}
+ unset -nocomplain history($j)
if {[string match e* $exec]} {
return [uplevel #0 $command]
} else {
@@ -198,13 +198,13 @@ proc history {args} {
proc tcl::HistKeep {{limit {}}} {
variable history
- if {[string length $limit] == 0} {
+ if {$limit eq ""} {
return $history(keep)
} else {
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
- if {[info exists history($oldold)]} {unset history($oldold)}
+ unset -nocomplain history($oldold)
}
set history(keep) $limit
}
@@ -246,7 +246,7 @@ proc history {args} {
proc tcl::HistInfo {{num {}}} {
variable history
- if {$num == {}} {
+ if {$num eq ""} {
set num [expr {$history(keep) + 1}]
}
set result {}
@@ -280,7 +280,7 @@ proc history {args} {
proc tcl::HistRedo {{event -1}} {
variable history
- if {[string length $event] == 0} {
+ if {$event eq ""} {
set event -1
}
set i [HistIndex $event]
diff --git a/library/init.tcl b/library/init.tcl
index d93a653..e1f4b05 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.77 2005/06/06 23:45:46 dkf Exp $
+# RCS: @(#) $Id: init.tcl,v 1.78 2005/07/23 04:12:49 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -114,9 +114,9 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
if {![info exists env($u)]} {
set env($u) $env($p)
}
- trace variable env($p) w \
+ trace add variable env($p) write \
[namespace code [list EnvTraceProc $p]]
- trace variable env($u) w \
+ trace add variable env($u) write \
[namespace code [list EnvTraceProc $p]]
}
}
@@ -177,7 +177,7 @@ if {[interp issafe]} {
# Conditionalize for presence of exec.
-if {[llength [info commands exec]] == 0} {
+if {[namespace which -command exec] eq ""} {
# Some machines do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
@@ -188,7 +188,7 @@ if {[llength [info commands exec]] == 0} {
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
-if {[llength [info commands tclLog]] == 0} {
+if {[namespace which -command tclLog] eq ""} {
proc tclLog {string} {
catch {puts stderr $string}
}
@@ -235,7 +235,7 @@ proc unknown args {
catch {set savedErrorInfo $::errorInfo}
catch {set savedErrorCode $::errorCode}
- set name [lindex $args 0]
+ set name $cmd
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
@@ -323,9 +323,9 @@ proc unknown args {
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
- if {$new != ""} {
+ if {$new ne ""} {
set redir ""
- if {[info commands console] eq ""} {
+ if {[namespace which -command console] eq ""} {
set redir ">&@stdout <@stdin"
}
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
@@ -333,9 +333,9 @@ proc unknown args {
}
if {$name eq "!!"} {
set newcmd [history event]
- } elseif {[regexp {^!(.+)$} $name dummy event]} {
+ } elseif {[regexp {^!(.+)$} $name -> event]} {
set newcmd [history event $event]
- } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
+ } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
@@ -354,11 +354,19 @@ proc unknown args {
"\n (expanding command prefix \"$name\" in unknown)"
return -options $opts $msg
}
+ # Handle empty $name separately due to strangeness in [string first]
+ if {$name eq ""} {
+ if {[llength $candidates] != 1} {
+ return -code error "empty command name \"\""
+ }
+ # It's not really possible to reach here.
+ return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
+ }
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
set cmds [list]
foreach x $candidates {
- if {[string range $x 0 [expr [string length $name]-1]] eq $name} {
+ if {[string first $name $x] == 0} {
lappend cmds $x
}
}
@@ -366,12 +374,7 @@ proc unknown args {
return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
}
if {[llength $cmds]} {
- if {$name eq ""} {
- return -code error "empty command name \"\""
- } else {
- return -code error \
- "ambiguous command name \"$name\": [lsort $cmds]"
- }
+ return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
return -code error "invalid command name \"$name\""
@@ -392,7 +395,7 @@ proc unknown args {
proc auto_load {cmd {namespace {}}} {
global auto_index auto_path
- if {[string length $namespace] == 0} {
+ if {$namespace eq ""} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
@@ -480,7 +483,7 @@ proc auto_load_index {} {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg opts]
- if {$f != ""} {
+ if {$f ne ""} {
close $f
}
if {$error} {
@@ -519,13 +522,13 @@ proc auto_qualify {cmd namespace} {
# with the following form :
# ( inputCmd, inputNameSpace) -> output
- if {[regexp {^::(.*)$} $cmd x tail]} {
+ if {[string match ::* $cmd]} {
if {$n > 1} {
# ( ::foo::bar , * ) -> ::foo::bar
return [list $cmd]
} else {
# ( ::global , * ) -> global
- return [list $tail]
+ return [list [string range $cmd 2 end]]
}
}
@@ -735,7 +738,7 @@ proc tcl::CopyDirectory {action src dest} {
}
}
if {[file exists $dest]} {
- if {$nsrc == $ndest} {
+ if {$nsrc eq $ndest} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
@@ -755,10 +758,10 @@ proc tcl::CopyDirectory {action src dest} {
# can be returned in various combinations. Anyway,
# if any other file is returned, we must signal an error.
set existing [glob -nocomplain -directory $dest * .*]
- eval [list lappend existing] \
- [glob -nocomplain -directory $dest -type hidden * .*]
+ lappend existing {expand}[glob -nocomplain -directory $dest \
+ -type hidden * .*]
foreach s $existing {
- if {([file tail $s] != ".") && ([file tail $s] != "..")} {
+ if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
@@ -768,7 +771,7 @@ proc tcl::CopyDirectory {action src dest} {
if {[string first $nsrc $ndest] != -1} {
set srclen [expr {[llength [file split $nsrc]] -1}]
set ndest [lindex [file split $ndest] $srclen]
- if {$ndest == [file tail $nsrc]} {
+ if {$ndest eq [file tail $nsrc]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
@@ -786,7 +789,7 @@ proc tcl::CopyDirectory {action src dest} {
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
- if {([file tail $s] != ".") && ([file tail $s] != "..")} {
+ if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
file copy -force $s [file join $dest [file tail $s]]
}
}
diff --git a/library/package.tcl b/library/package.tcl
index 7c4e4e9..9d9e0a9 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -3,7 +3,7 @@
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
-# RCS: @(#) $Id: package.tcl,v 1.32 2004/08/02 22:01:38 dgp Exp $
+# RCS: @(#) $Id: package.tcl,v 1.33 2005/07/23 04:12:49 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -31,8 +31,8 @@ namespace eval tcl::Pkg {}
proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
global tcl_platform
- if {![string length $ext]} {set ext [info sharedlibextension]}
- if {[string equal $tcl_platform(platform) "windows"]} {
+ if {$ext eq ""} {set ext [info sharedlibextension]}
+ if {$tcl_platform(platform) eq "windows"} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
@@ -40,7 +40,7 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
set root $fileName
while {1} {
set currExt [file extension $root]
- if {[string equal $currExt $ext]} {
+ if {$currExt eq $ext} {
return 1
}
@@ -135,7 +135,7 @@ proc pkg_mkIndex {args} {
}
if {[catch {
- glob -directory $dir -tails -types {r f} {expand}$patternList
+ glob -directory $dir -tails -types {r f} -- {expand}$patternList
} fileList o]} {
return -options $o $fileList
}
@@ -145,7 +145,7 @@ proc pkg_mkIndex {args} {
# interpreter, and get a list of the new commands and packages
# that are defined.
- if {[string equal $file pkgIndex.tcl]} {
+ if {$file eq "pkgIndex.tcl"} {
continue
}
@@ -154,7 +154,7 @@ proc pkg_mkIndex {args} {
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
- if {[string length $loadPat]} {
+ if {$loadPat ne ""} {
if {$doVerbose} {
tclLog "currently loaded packages: '[info loaded]'"
tclLog "trying to load all packages matching $loadPat"
@@ -180,7 +180,7 @@ proc pkg_mkIndex {args} {
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
- if {[string equal [lindex $pkg 1] "Tk"]} {
+ if {[lindex $pkg 1] eq "Tk"} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
@@ -263,7 +263,7 @@ proc pkg_mkIndex {args} {
set ::tcl::namespaces($::tcl::x) 1
}
foreach ::tcl::x [package names] {
- if {[string compare [package provide $::tcl::x] ""]} {
+ if {[package provide $::tcl::x] ne ""} {
set ::tcl::packages($::tcl::x) 1
}
}
@@ -311,7 +311,7 @@ proc pkg_mkIndex {args} {
set ::tcl::newCmds($::tcl::x) 1
}
foreach ::tcl::x $::tcl::origCmds {
- catch {unset ::tcl::newCmds($::tcl::x)}
+ unset -nocomplain ::tcl::newCmds($::tcl::x)
}
foreach ::tcl::x [array names ::tcl::newCmds] {
# determine which namespace a command comes from
@@ -324,7 +324,7 @@ proc pkg_mkIndex {args} {
set ::tcl::abs \
[lindex [auto_qualify $::tcl::abs ::] 0]
- if {[string compare $::tcl::x $::tcl::abs]} {
+ if {$::tcl::x ne $::tcl::abs} {
# Name changed during qualification
set ::tcl::newCmds($::tcl::abs) 1
@@ -338,7 +338,7 @@ proc pkg_mkIndex {args} {
# a version provided, then record it
foreach ::tcl::x [package names] {
- if {[string compare [package provide $::tcl::x] ""] \
+ if {[package provide $::tcl::x] ne ""
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
@@ -437,7 +437,7 @@ proc tclPkgSetup {dir pkg version files} {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
- if {[string equal $type "load"]} {
+ if {$type eq "load"} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
diff --git a/library/safe.tcl b/library/safe.tcl
index 60687bf..61246e8 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: safe.tcl,v 1.14 2004/06/29 09:34:44 dkf Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.15 2005/07/23 04:12:49 dgp Exp $
#
# The implementation is based on namespaces. These naming conventions
@@ -77,7 +77,7 @@ namespace eval ::safe {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -noStatics];
- if {$flag && ($noStatics == $statics)
+ if {$flag && (!$noStatics == !$statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
"conflicting values given for -statics and -noStatics"
@@ -98,7 +98,7 @@ namespace eval ::safe {
set flag [::tcl::OptProcArgGiven -nestedLoadOk];
# note that the test here is the opposite of the "InterpStatics"
# one (it is not -noNested... because of the wanted default value)
- if {$flag && ($nestedLoadOk != $nested)
+ if {$flag && (!$nestedLoadOk != !$nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
"conflicting values given for -nested and -nestedLoadOk"
@@ -324,7 +324,7 @@ namespace eval ::safe {
nestedok deletehook} {
# determine and store the access path if empty
- if {[string equal "" $access_path]} {
+ if {$access_path eq ""} {
set access_path [uplevel \#0 set auto_path]
# Make sure that tcl_library is in auto_path
# and at the first position (needed by setAccessPath)
@@ -764,7 +764,7 @@ proc ::safe::setLogCmd {args} {
# Determine where to load. load use a relative interp path
# and {} means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
- if {[string length $target]} {
+ if {$target ne ""} {
# we will try to load into a sub sub interp
# check that we want to authorize that.
if {![NestedOk $slave]} {
@@ -776,9 +776,9 @@ proc ::safe::setLogCmd {args} {
}
# Determine what kind of load is requested
- if {[string length $file] == 0} {
+ if {$file eq ""} {
# static package loading
- if {[string length $package] == 0} {
+ if {$package eq ""} {
set msg "load error: empty filename and no package name"
Log $slave $msg
return -code error $msg
@@ -846,7 +846,7 @@ proc ::safe::setLogCmd {args} {
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
- return [$command $subcommand {expand}[lrange $args 1 end]]
+ return [$command {expand}$args]
}
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
@@ -881,11 +881,10 @@ proc ::safe::setLogCmd {args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
- return [::interp invokehidden $slave encoding $subcommand \
- {expand}[lrange $args 1 end]]
+ return [::interp invokehidden $slave encoding {expand}$args]
}
- if {[string match $subcommand system]} {
+ if {[string first $subcommand system] == 0} {
if {$argc == 1} {
# passed all the tests , lets source it:
if {[catch {::interp invokehidden \
diff --git a/library/word.tcl b/library/word.tcl
index edcb93a..05c3bab 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -10,12 +10,12 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: word.tcl,v 1.7 2002/11/01 00:28:51 andreas_kupries Exp $
+# RCS: @(#) $Id: word.tcl,v 1.8 2005/07/23 04:12:49 dgp Exp $
# The following variables are used to determine which characters are
# interpreted as white space.
-if {[string equal $::tcl_platform(platform) "windows"]} {
+if {$::tcl_platform(platform) eq "windows"} {
# Windows style - any but a unicode space char
set tcl_wordchars "\\S"
set tcl_nonwordchars "\\s"
@@ -58,7 +58,7 @@ proc tcl_wordBreakAfter {str start} {
proc tcl_wordBreakBefore {str start} {
global tcl_nonwordchars tcl_wordchars
- if {[string equal $start end]} {
+ if {$start eq "end"} {
set start [string length $str]
}
if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
@@ -120,7 +120,7 @@ proc tcl_startOfNextWord {str start} {
proc tcl_startOfPreviousWord {str start} {
global tcl_nonwordchars tcl_wordchars
- if {[string equal $start end]} {
+ if {$start eq "end"} {
set start [string length $str]
}
if {[regexp -indices \