From 14816591e601d46ce04cda2a9046995076aa51f5 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Jul 2005 21:59:36 +0000 Subject: * library/auto.tcl: Updates to the Tcl script library to make * library/history.tcl: use of Tcl 8.4 feautures. Thanks to * library/init.tcl: Patrick Fradin for prompting on this. * library/package.tcl: [Patch 1237755]. * library/safe.tcl: * library/word.tcl: --- ChangeLog | 9 +++++ library/auto.tcl | 42 +++++++++------------ library/history.tcl | 17 ++++----- library/init.tcl | 105 ++++++++++++++++++++++++++-------------------------- library/package.tcl | 37 +++++++++--------- library/safe.tcl | 28 +++++++------- library/word.tcl | 8 ++-- 7 files changed, 124 insertions(+), 122 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1de88f6..8907845 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2005-07-22 Don Porter + + * library/auto.tcl: Updates to the Tcl script library to make + * library/history.tcl: use of Tcl 8.4 feautures. Thanks to + * library/init.tcl: Patrick Fradin for prompting on this. + * library/package.tcl: [Patch 1237755]. + * library/safe.tcl: + * library/word.tcl: + 2005-07-07 Jeff Hobbs * unix/tcl.m4, unix/configure: Backported [Bug 1095909], removing diff --git a/library/auto.tcl b/library/auto.tcl index b02b77f..90f8b14 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.12.2.8 2005/06/27 18:20:26 dgp Exp $ +# RCS: @(#) $Id: auto.tcl,v 1.12.2.9 2005/07/22 21:59:39 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -33,9 +33,7 @@ proc auto_reset {} { rename $p {} } } - catch {unset auto_execs} - catch {unset auto_index} - catch {unset auto_oldpath} + unset -nocomplain auto_execs auto_index auto_oldpath } # tcl_findLibrary -- @@ -61,8 +59,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 { @@ -164,9 +161,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" @@ -219,12 +214,12 @@ proc auto_mkindex {dir args} { append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" - if {$args == ""} { + if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init - foreach file [eval glob $args] { + foreach file [eval [linsert $args 0 glob --]] { if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} { append index $msg } else { @@ -257,10 +252,10 @@ proc auto_mkindex_old {dir args} { append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" - if {[string equal $args ""]} { + if {[llength $args] == 0} { set args *.tcl } - foreach file [eval glob $args] { + foreach file [eval [linsert $args 0 glob --]] { set f "" set error [catch { set f [open $file] @@ -378,7 +373,7 @@ proc auto_mkindex_parser::mkindex {file} { # in case there were any $ in the proc name. This will cause a problem # if somebody actually tries to have a \0 in their proc name. Too bad # for them. - regsub -all {\$} $contents "\0" contents + set contents [string map "$ \u0000" $contents] set index "" set contextStack "" @@ -456,12 +451,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 "_%@fake_$name" - regsub -all {::} $fakeName "_" fakeName - set fakeName "[namespace current]::$fakeName" + set fakeName [namespace current]::[string map {:: _} _%@fake_$name] } proc $fakeName $arglist $body @@ -470,7 +463,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 {[regexp {::} $name]} { + if {[string match *::* $name]} { set exportCmd [list _%@namespace export [namespace tail $name]] $parser eval [list _%@namespace eval $ns $exportCmd] @@ -520,7 +513,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" @@ -528,8 +521,7 @@ proc auto_mkindex_parser::fullname {name} { # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse # that replacement. - regsub -all "\0" $name "\$" name - return $name + return [string map "\u0000 $" $name] } # Register all of the procedures for the auto_mkindex parser that @@ -561,7 +553,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] ne ""} { auto_load tbcload::bcproc } load {} tbcload $auto_mkindex_parser::parser @@ -612,7 +604,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 d75c354..b8e27ce 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -2,7 +2,7 @@ # # Implementation of the history command. # -# RCS: @(#) $Id: history.tcl,v 1.5 2001/05/17 08:18:56 hobbs Exp $ +# RCS: @(#) $Id: history.tcl,v 1.5.14.1 2005/07/22 21:59:40 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 {} @@ -256,8 +256,7 @@ proc history {args} { if {![info exists history($i)]} { continue } - set cmd [string trimright $history($i) \ \n] - regsub -all \n $cmd "\n\t" cmd + set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] append result $newline[format "%6d %s" $i $cmd] set newline \n } @@ -281,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 ea1cd85..8105642 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.55.2.5 2005/04/28 05:34:40 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.55.2.6 2005/07/22 21:59:40 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -48,7 +48,7 @@ if {![info exists auto_path]} { } namespace eval tcl { variable Dir - if {[info library] != ""} { + if {[info library] ne ""} { foreach Dir [list [info library] [file dirname [info library]]] { if {[lsearch -exact $::auto_path $Dir] < 0} { lappend ::auto_path $Dir @@ -71,7 +71,7 @@ namespace eval tcl { # Windows specific end of initialization -if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { +if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { set x $::env($n2) @@ -82,23 +82,23 @@ if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { global env tcl_platform foreach p [array names env] { set u [string toupper $p] - if {![string equal $u $p]} { + if {$u ne $p} { switch -- $u { COMSPEC - PATH { 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]] } } } } if {![info exists env(COMSPEC)]} { - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { set env(COMSPEC) cmd.exe } else { set env(COMSPEC) command.com @@ -115,18 +115,18 @@ package unknown tclPkgUnknown if {![interp issafe]} { # setup platform specific unknown package handlers - if {[string equal $::tcl_platform(platform) "unix"] && \ - [string equal $::tcl_platform(os) "Darwin"]} { + if {$::tcl_platform(platform) eq "unix" + && $::tcl_platform(os) eq "Darwin"} { package unknown [list tcl::MacOSXPkgUnknown [package unknown]] } - if {[string equal $::tcl_platform(platform) "macintosh"]} { + if {$::tcl_platform(platform) eq "macintosh"} { package unknown [list tcl::MacPkgUnknown [package unknown]] } } # Conditionalize for presence of exec. -if {[llength [info commands exec]] == 0} { +if {[namespace which -command exec] eq ""} { # Some machines, such as the Macintosh, do not have exec. Also, on all # platforms, safe interpreters do not have exec. @@ -139,7 +139,7 @@ set errorInfo "" # 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} } @@ -199,7 +199,7 @@ proc unknown args { } set savedErrorCode $errorCode set savedErrorInfo $errorInfo - 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. @@ -273,15 +273,15 @@ proc unknown args { } } - if {([info level] == 1) && [string equal [info script] ""] \ + if {([info level] == 1) && [info script] eq "" \ && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] - if {$new != ""} { + if {$new ne ""} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set redir "" - if {[string equal [info commands console] ""]} { + if {[namespace which -command console] eq ""} { set redir ">&@stdout <@stdin" } return [uplevel 1 exec $redir $new [lrange $args 1 end]] @@ -289,11 +289,11 @@ proc unknown args { } set errorCode $savedErrorCode set errorInfo $savedErrorInfo - if {[string equal $name "!!"]} { + 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} } @@ -304,7 +304,7 @@ proc unknown args { } set ret [catch {set candidates [info commands $name*]} msg] - if {[string equal $name "::"]} { + if {$name eq "::"} { set name "" } if {$ret != 0} { @@ -312,11 +312,18 @@ proc unknown args { "error in unknown while checking if \"$name\" is\ a unique command abbreviation:\n$msg" } + # Handle empty $name separately due to strangeness in [string first] + if {$name eq ""} { + if {[llength $candidates] != 1} { + return -code error "empty command name \"\"" + } + 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 } } @@ -324,12 +331,7 @@ proc unknown args { return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]] } if {[llength $cmds]} { - if {[string equal $name ""]} { - 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\"" @@ -350,7 +352,7 @@ proc unknown args { proc auto_load {cmd {namespace {}}} { global auto_index auto_oldpath auto_path - if {[string length $namespace] == 0} { + if {$namespace eq ""} { set namespace [uplevel 1 [list ::namespace current]] } set nameList [auto_qualify $cmd $namespace] @@ -402,8 +404,7 @@ proc auto_load {cmd {namespace {}}} { proc auto_load_index {} { global auto_index auto_oldpath auto_path errorInfo errorCode - if {[info exists auto_oldpath] && \ - [string equal $auto_oldpath $auto_path]} { + if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} { return 0 } set auto_oldpath $auto_path @@ -422,12 +423,11 @@ proc auto_load_index {} { } else { set error [catch { set id [gets $f] - if {[string equal $id \ - "# Tcl autoload index file, version 2.0"]} { + if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] - } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} { + } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { while {[gets $f line] >= 0} { - if {[string equal [string index $line 0] "#"] \ + if {[string index $line 0] eq "#" || ([llength $line] != 2)} { continue } @@ -439,7 +439,7 @@ proc auto_load_index {} { error "[file join $dir tclIndex] isn't a proper Tcl index file" } } msg] - if {$f != ""} { + if {$f ne ""} { close $f } if {$error} { @@ -478,13 +478,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]] } } @@ -492,14 +492,14 @@ proc auto_qualify {cmd namespace} { # (if the current namespace is not the global one) if {$n == 0} { - if {[string equal $namespace ::]} { + if {$namespace eq "::"} { # ( nocolons , :: ) -> nocolons return [list $cmd] } else { # ( nocolons , ::sub ) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } - } elseif {[string equal $namespace ::]} { + } elseif {$namespace eq "::"} { # ( foo::bar , :: ) -> ::foo::bar return [list ::$cmd] } else { @@ -554,7 +554,7 @@ proc auto_import {pattern} { # Arguments: # name - Name of a command. -if {[string equal windows $tcl_platform(platform)]} { +if {$tcl_platform(platform) eq "windows"} { # Windows version. # # Note that info executable doesn't work under Windows, so we have to @@ -572,7 +572,7 @@ proc auto_execok name { set shellBuiltins [list cls copy date del erase dir echo mkdir \ md rename ren rmdir rd time type ver vol] - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { # NT includes the 'start' built-in lappend shellBuiltins "start" } @@ -609,7 +609,7 @@ proc auto_execok name { set windir $env(WINDIR) } if {[info exists windir]} { - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { append path "$windir/system32;" } append path "$windir/system;$windir;" @@ -623,7 +623,7 @@ proc auto_execok name { foreach dir [split $path {;}] { # Skip already checked directories - if {[info exists checked($dir)] || [string equal {} $dir]} { continue } + if {[info exists checked($dir)] || $dir eq {}} { continue } set checked($dir) {} foreach ext $execExtensions { set file [file join $dir ${name}${ext}] @@ -652,7 +652,7 @@ proc auto_execok name { return $auto_execs($name) } foreach dir [split $env(PATH) :] { - if {[string equal $dir ""]} { + if {$dir eq ""} { set dir . } set file [file join $dir $name] @@ -683,7 +683,7 @@ proc auto_execok name { proc tcl::CopyDirectory {action src dest} { set nsrc [file normalize $src] set ndest [file normalize $dest] - if {[string equal $action "renaming"]} { + if {$action eq "renaming"} { # Can't rename volumes. We could give a more precise # error message here, but that would break the test suite. if {[lsearch -exact [file volumes] $nsrc] != -1} { @@ -693,12 +693,12 @@ 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" } - if {[string equal $action "copying"]} { + if {$action eq "copying"} { return -code error "error $action \"$src\" to\ \"$dest\": file already exists" } else { @@ -707,10 +707,11 @@ 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 * .*] + eval [linsert \ + [glob -nocomplain -directory $dest -type hidden * .*] 0 \ + lappend existing] 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" } @@ -720,7 +721,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" @@ -738,7 +739,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 $s [file join $dest [file tail $s]] } } diff --git a/library/package.tcl b/library/package.tcl index fa6f445..fa6b01c 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.23.2.2 2003/07/24 08:23:17 rmax Exp $ +# RCS: @(#) $Id: package.tcl,v 1.23.2.3 2005/07/22 21:59:41 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -33,8 +33,8 @@ namespace eval ::pkg { proc 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 @@ -42,7 +42,7 @@ proc 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 } @@ -140,7 +140,7 @@ proc pkg_mkIndex {args} { set oldDir [pwd] cd $dir - if {[catch {eval glob $patternList} fileList]} { + if {[catch {eval [linsert $patternList 0 glob --]} fileList]} { global errorCode errorInfo cd $oldDir return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList @@ -151,7 +151,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 } @@ -165,7 +165,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" @@ -191,7 +191,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 .] } @@ -206,7 +206,7 @@ proc pkg_mkIndex {args} { proc package {what args} { switch -- $what { require { return ; # ignore transitive requires } - default { eval __package_orig {$what} $args } + default { uplevel 1 [linsert $args 0 __package_orig $what] } } } proc tclPkgUnknown args {} @@ -261,7 +261,8 @@ proc pkg_mkIndex {args} { proc ::tcl::GetAllNamespaces {{root ::}} { set list $root foreach ns [namespace children $root] { - eval lappend list [::tcl::GetAllNamespaces $ns] + eval [linsert [::tcl::GetAllNamespaces $ns] 0 \ + lappend list] } return $list } @@ -272,7 +273,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 } } @@ -320,7 +321,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 @@ -333,7 +334,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 @@ -347,7 +348,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]] @@ -447,7 +448,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]] @@ -595,7 +596,7 @@ proc tcl::MacOSXPkgUnknown {original name version {exact {}}} { } } set use_path [lrange $use_path 0 end-1] - if {[string compare $old_path $auto_path]} { + if {$old_path ne $auto_path} { foreach dir $auto_path { lappend use_path $dir } @@ -640,7 +641,7 @@ proc tcl::MacPkgUnknown {original name version {exact {}}} { if {[file isfile $x]} { set res [resource open $x] foreach y [resource list TEXT $res] { - if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex} + if {$y eq "pkgIndex"} {source -rsrc pkgIndex} } catch {resource close $res} } @@ -649,7 +650,7 @@ proc tcl::MacPkgUnknown {original name version {exact {}}} { } } set use_path [lrange $use_path 0 end-1] - if {[string compare $old_path $auto_path]} { + if {$old_path ne $auto_path} { foreach dir $auto_path { lappend use_path $dir } diff --git a/library/safe.tcl b/library/safe.tcl index f34fea2..9c8aff5 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.9.2.2 2004/06/29 09:39:01 dkf Exp $ +# RCS: @(#) $Id: safe.tcl,v 1.9.2.3 2005/07/22 21:59:41 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) @@ -640,15 +640,15 @@ proc ::safe::setLogCmd {args} { } # set/get values proc Set {args} { - eval [list Toplevel set] $args + eval [linsert $args 0 Toplevel set] } # lappend on toplevel vars proc Lappend {args} { - eval [list Toplevel lappend] $args + eval [linsert $args 0 Toplevel lappend] } # unset a var/token (currently just an global level eval) proc Unset {args} { - eval [list Toplevel unset] $args + eval [linsert $args 0 Toplevel unset] } # test existance proc Exists {varname} { @@ -778,7 +778,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]} { @@ -790,9 +790,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 @@ -860,7 +860,7 @@ proc ::safe::setLogCmd {args} { proc Subset {slave command okpat args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { - return [eval [list $command $subcommand] [lrange $args 1 end]] + return [eval [linsert $args 0 $command]] } set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg @@ -895,11 +895,11 @@ proc ::safe::setLogCmd {args} { set subcommand [lindex $args 0] if {[regexp $okpat $subcommand]} { - return [eval ::interp invokehidden $slave encoding $subcommand \ - [lrange $args 1 end]] + return [eval [linsert $args 0 \ + ::interp invokehidden $slave encoding]] } - 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..c18c961 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.7.2.1 2005/07/22 21:59:41 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 \ -- cgit v0.12