diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | library/auto.tcl | 28 | ||||
| -rw-r--r-- | library/history.tcl | 14 | ||||
| -rw-r--r-- | library/init.tcl | 57 | ||||
| -rw-r--r-- | library/package.tcl | 26 | ||||
| -rw-r--r-- | library/safe.tcl | 21 | ||||
| -rw-r--r-- | library/word.tcl | 8 |
7 files changed, 86 insertions, 79 deletions
@@ -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 \ |