diff options
author | dgp <dgp@users.sourceforge.net> | 2005-08-02 18:14:45 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2005-08-02 18:14:45 (GMT) |
commit | 9c039ecfcf11190f6a62a062ed4f6de869d7286a (patch) | |
tree | a63f128b8c93b9ab26ab3bbc3dd63d4e9de5a6a4 /library | |
parent | a92e5b36e3ea9b1d2480d54810fc432a0b6ce301 (diff) | |
download | tcl-9c039ecfcf11190f6a62a062ed4f6de869d7286a.zip tcl-9c039ecfcf11190f6a62a062ed4f6de869d7286a.tar.gz tcl-9c039ecfcf11190f6a62a062ed4f6de869d7286a.tar.bz2 |
merge updates from HEAD
Diffstat (limited to 'library')
-rw-r--r-- | library/auto.tcl | 28 | ||||
-rw-r--r-- | library/clock.tcl | 30 | ||||
-rw-r--r-- | library/history.tcl | 14 | ||||
-rw-r--r-- | library/init.tcl | 73 | ||||
-rw-r--r-- | library/ldAout.tcl | 233 | ||||
-rw-r--r-- | library/package.tcl | 26 | ||||
-rw-r--r-- | library/safe.tcl | 21 | ||||
-rw-r--r-- | library/word.tcl | 8 |
8 files changed, 113 insertions, 320 deletions
diff --git a/library/auto.tcl b/library/auto.tcl index 0a9029d..891c1e9 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.21.2.2 2005/07/12 20:37:04 kennykb Exp $ +# RCS: @(#) $Id: auto.tcl,v 1.21.2.3 2005/08/02 18:16:14 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/clock.tcl b/library/clock.tcl index 2d217d6..e65ebf3 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.tcl,v 1.12.2.2 2005/04/25 21:37:23 kennykb Exp $ +# RCS: @(#) $Id: clock.tcl,v 1.12.2.3 2005/08/02 18:16:14 dgp Exp $ # #---------------------------------------------------------------------- @@ -3356,6 +3356,7 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { variable WinZoneInfo variable NoRegistry + variable TimeZoneBad if { [info exists NoRegistry] } { return :localtime @@ -3389,9 +3390,20 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { return :localtime } - # Make up a Posix time zone specifier if we can't find one + # Make up a Posix time zone specifier if we can't find one. + # Check here that the tzdata file exists, in case we're running + # in an environment (e.g. starpack) where tzdata is incomplete. + # (Bug 1237907) - if { ! [dict exists $WinZoneInfo $data] } { + if { [dict exists $WinZoneInfo $data] } { + set tzname [dict get $WinZoneInfo $data] + if { ! [dict exists $TimeZoneBad $tzname] } { + dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}] + } + } else { + set tzname {} + } + if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } { foreach { bias stdBias dstBias stdYear stdMonth stdDayOfWeek stdDayOfMonth @@ -3404,24 +3416,29 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $stdDelta <= 0 } { set stdSignum + set stdDelta [expr { - $stdDelta }] + set dispStdSignum - } else { set stdSignum - + set dispStdSignum + } set hh [::format %02d [expr { $stdDelta / 3600 }]] set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $stdDelta % 60 }]] - append tzname < $stdSignum $hh $mm > $stdSignum $hh : $mm : $ss + set tzname {} + append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss if { $stdMonth >= 0 } { if { $dstDelta <= 0 } { set dstSignum + set dstDelta [expr { - $dstDelta }] + set dispDstSignum - } else { set dstSignum - + set dispDstSignum + } set hh [::format %02d [expr { $dstDelta / 3600 }]] set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $dstDelta % 60 }]] - append tzname < $dstSignum $hh $mm > $dstSignum $hh : $mm : $ss + append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { @@ -5052,7 +5069,7 @@ proc ::tcl::clock::ClearCaches {} { variable LocaleNumeralCache variable McLoaded variable CachedSystemTimeZone - variable TZData + variable TimeZoneBad foreach p [info procs [namespace current]::scanproc'*] { rename $p {} @@ -5061,6 +5078,7 @@ proc ::tcl::clock::ClearCaches {} { set LocaleNumeralCache {} set McLoaded {} catch {unset CachedSystemTimeZone} + set TimeZoneBad {} InitTZData } diff --git a/library/history.tcl b/library/history.tcl index 7304d2a..711db2d 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.6.4.1 2005/08/02 18:16:14 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 59ea9f2..33f3309 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.69.2.3 2005/07/12 20:37:05 kennykb Exp $ +# RCS: @(#) $Id: init.tcl,v 1.69.2.4 2005/08/02 18:16:14 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,26 +323,33 @@ 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]] + uplevel 1 [list ::catch \ + [concat exec $redir $new [lrange $args 1 end]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } } 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} } if {[info exists newcmd]} { tclLog $newcmd history change $newcmd 0 - return [uplevel 1 $newcmd] + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } set ret [catch {set candidates [info commands $name*]} msg] @@ -354,24 +361,30 @@ 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 } } if {[llength $cmds] == 1} { - return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]] + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } 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 +405,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 +493,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 +532,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 +748,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 +768,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 +781,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 +799,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/ldAout.tcl b/library/ldAout.tcl deleted file mode 100644 index c32f174..0000000 --- a/library/ldAout.tcl +++ /dev/null @@ -1,233 +0,0 @@ -# ldAout.tcl -- -# -# This "tclldAout" procedure in this script acts as a replacement -# for the "ld" command when linking an object file that will be -# loaded dynamically into Tcl or Tk using pseudo-static linking. -# -# Parameters: -# The arguments to the script are the command line options for -# an "ld" command. -# -# Results: -# The "ld" command is parsed, and the "-o" option determines the -# module name. ".a" and ".o" options are accumulated. -# The input archives and object files are examined with the "nm" -# command to determine whether the modules initialization -# entry and safe initialization entry are present. A trivial -# C function that locates the entries is composed, compiled, and -# its .o file placed before all others in the command; then -# "ld" is executed to bind the objects together. -# -# RCS: @(#) $Id: ldAout.tcl,v 1.6 2003/03/19 21:57:42 dgp Exp $ -# -# Copyright (c) 1995, by General Electric Company. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# This work was supported in part by the ARPA Manufacturing Automation -# and Design Engineering (MADE) Initiative through ARPA contract -# F33615-94-C-4400. - -proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} { - global env - global argv - - if {[string equal $cc ""]} { - set cc $env(CC) - } - - # if only two parameters are supplied there is assumed that the - # only shlib_suffix is missing. This parameter is anyway available - # as "info sharedlibextension" too, so there is no need to transfer - # 3 parameters to the function tclLdAout. For compatibility, this - # function now accepts both 2 and 3 parameters. - - if {[string equal $shlib_suffix ""]} { - set shlib_cflags $env(SHLIB_CFLAGS) - } elseif {[string equal $shlib_cflags "none"]} { - set shlib_cflags $shlib_suffix - } - - # seenDotO is nonzero if a .o or .a file has been seen - set seenDotO 0 - - # minusO is nonzero if the last command line argument was "-o". - set minusO 0 - - # head has command line arguments up to but not including the first - # .o or .a file. tail has the rest of the arguments. - set head {} - set tail {} - - # nmCommand is the "nm" command that lists global symbols from the - # object files. - set nmCommand {|nm -g} - - # entryProtos is the table of _Init and _SafeInit prototypes found in the - # module. - set entryProtos {} - - # entryPoints is the table of _Init and _SafeInit entries found in the - # module. - set entryPoints {} - - # libraries is the list of -L and -l flags to the linker. - set libraries {} - set libdirs {} - - # Process command line arguments - foreach a $argv { - if {!$minusO && [regexp {\.[ao]$} $a]} { - set seenDotO 1 - lappend nmCommand $a - } - if {$minusO} { - set outputFile $a - set minusO 0 - } elseif {![string compare $a -o]} { - set minusO 1 - } - if {[string match -nocase "-l*" $a]} { - lappend libraries $a - if {[string match "-L*" $a]} { - lappend libdirs [string range $a 2 end] - } - } elseif {$seenDotO} { - lappend tail $a - } else { - lappend head $a - } - } - lappend libdirs /lib /usr/lib - - # MIPS -- If there are corresponding G0 libraries, replace the - # ordinary ones with the G0 ones. - - set libs {} - foreach lib $libraries { - if {[string match "-l*" $lib]} { - set lname [string range $lib 2 end] - foreach dir $libdirs { - if {[file exists [file join $dir lib${lname}_G0.a]]} { - set lname ${lname}_G0 - break - } - } - lappend libs -l$lname - } else { - lappend libs $lib - } - } - set libraries $libs - - # Extract the module name from the "-o" option - - if {![info exists outputFile]} { - error "-o option must be supplied to link a Tcl load module" - } - set m [file tail $outputFile] - 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 $m 0 [expr {$l-1}]] - if {[string match "lib*" $modName]} { - set modName [string range $modName 3 end] - } - if {[regexp {[0-9\.]*(_g0)?$} $modName match]} { - set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]] - } - set modName [string totitle $modName] - - # Catalog initialization entry points found in the module - - set f [open $nmCommand r] - while {[gets $f l] >= 0} { - if {[regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} { - if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} { - set s $symbol - } - append entryProtos {extern int } $symbol { (); } \n - append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n - } - } - close $f - - if {[string equal $entryPoints ""]} { - error "No entry point found in objects" - } - - # Compose a C function that resolves the initialization entry points and - # embeds the required libraries in the object code. - - set C {#include <string.h>} - append C \n - append C {char TclLoadLibraries_} $modName { [] =} \n - append C { "@LIBS: } $libraries {";} \n - append C $entryProtos - append C {static struct } \{ \n - append C { char * name;} \n - append C { int (*value)();} \n - append C \} {dictionary [] = } \{ \n - append C $entryPoints - append C { 0, 0 } \n \} \; \n - append C {typedef struct Tcl_Interp Tcl_Interp;} \n - append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n - append C {Tcl_PackageInitProc *} \n - append C TclLoadDictionary_ $modName { (symbol)} \n - append C { CONST char * symbol;} \n - append C { - { - int i; - for (i = 0; dictionary [i] . name != 0; ++i) { - if (!strcmp (symbol, dictionary [i] . name)) { - return dictionary [i].value; - } - } - return 0; - } - } - append C \n - - - # Write the C module and compile it - - set cFile tcl$modName.c - set f [open $cFile w] - puts -nonewline $f $C - close $f - set ccCommand "$cc -c $shlib_cflags $cFile" - puts stderr $ccCommand - eval exec $ccCommand - - # Now compose and execute the ld command that packages the module - - if {[string equal $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 {[string equal $shlib_suffix ".a"]} { - exec ranlib $outputFile - } - - # Clean up working files - exec /bin/rm $cFile [file rootname $cFile].o -} diff --git a/library/package.tcl b/library/package.tcl index 7c4e4e9..3e0bba5 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.32.2.1 2005/08/02 18:16:15 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..6f970f1 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.14.2.1 2005/08/02 18:16:15 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..c439352 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.6.1 2005/08/02 18:16:15 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 \ |