diff options
| -rw-r--r-- | changes | 29 | ||||
| -rw-r--r-- | generic/tclIO.c | 19 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 16 | ||||
| -rw-r--r-- | library/history.tcl | 18 | ||||
| -rw-r--r-- | library/init.tcl | 91 | ||||
| -rw-r--r-- | library/parray.tcl | 4 | ||||
| -rw-r--r-- | library/safe.tcl | 8 | ||||
| -rw-r--r-- | library/word.tcl | 24 | ||||
| -rw-r--r-- | mac/tclMacAlloc.c | 14 | ||||
| -rw-r--r-- | tests/opt.test | 22 | ||||
| -rw-r--r-- | tests/socket.test | 41 | ||||
| -rw-r--r-- | unix/tclUnixInit.c | 50 | ||||
| -rw-r--r-- | win/tclWinInit.c | 78 |
13 files changed, 216 insertions, 198 deletions
@@ -3452,6 +3452,35 @@ Universal Headers V.3.0, so that Tcl will compile with CW Pro 2. ----------------- Released 8.0p2, 11/25/97 ----------------------- +12/3/97 (bug fix/optimization) Removed uneeded and potentially dangerous +instances of double evaluations if "if" and "expr" statements from +the library files. It is recommended that unless you need a double +evaluation you always use "expr {...}" instead of "expr ..." and +"if {...} ..." instead of "if ... ...". It will also be faster +thanks to the byte compiler. (DL) + +---- Shipped as part of the plugin2.0b5 as 8.0p2Plugin1, Dec 8th 97 ---- + +12/8/97 (bug fix) Need to protect the newly accepted channel in an +accept callback on a socket, otherwise the callback may close it and +cause an error, which would cause the C code to attempt to close the +now deleted channel. Bumping the refcount assures that the channel sticks +around to be really closed in this case. (JL) + +12/8/97 (bug fix) Need to protect the channel in a fileevent so that it +is not deleted before the fileevent handler returns. (CS, JL) + +12/18/97 (bug fix) In the opt argument parsing package: if the description +had only flags, the "too many arguments" case was not detected. The default +value was not used for the special "args" ending argument. (DL) + +1/15/98 (improvement) Moved common part of initScript in common file. +Moved windows specific initialization to init.tcl so you can initialize +Tcl in windows without having to call Tcl_Init which is now only +searching for init.tcl {back ported from 8.1}. (DL) + +---- Shipped as part of the plugin as 8.0p2Plugin2, Jan 15th 98 ---- + 5/27/98 (bug fix) Windows socket driver did not notice new data arriving on nonblocking sockets until the event loop was entered. (SS) diff --git a/generic/tclIO.c b/generic/tclIO.c index 534060b..f198474 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: %Z% $Id: tclIO.c,v 1.2 1998/06/09 13:08:16 stanton Exp $ + * SCCS: %Z% $Id: tclIO.c,v 1.3 1998/06/27 18:10:15 welch Exp $ */ #include "tclInt.h" @@ -4519,7 +4519,14 @@ Tcl_NotifyChannel(channel, mask) ChannelHandler *chPtr; NextChannelHandler nh; - Tcl_Preserve((ClientData)chanPtr); + /* + * Prevent the event handler from deleting the channel by incrementing + * the channel's ref count. Case in point: ChannelEventScriptInvoker() + * was evaling a script (owned by the channel) which caused the channel + * to be closed and then the byte codes no longer existed. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, channel); /* * If we are flushing in the background, be sure to call FlushChannel @@ -4566,7 +4573,13 @@ Tcl_NotifyChannel(channel, mask) if (chanPtr->typePtr != NULL) { UpdateInterest(chanPtr); } - Tcl_Release((ClientData)chanPtr); + + /* + * No longer need to protect the channel from being deleted. + * After this point it is unsafe to use the value of "channel". + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, channel); nestedHandlerPtr = nh.nestedHandlerPtr; } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 5640b47..88a299a 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1238,12 +1238,28 @@ AcceptCallbackProc(callbackData, chan, address, port) TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from + * being deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), " ", address, " ", portBuf, (char *) NULL); if (result != TCL_OK) { Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); } + + /* + * Decrement the artificially bumped refcount. After this it is + * not safe anymore to use "chan", because it may now be deleted. + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + Tcl_Release((ClientData) interp); Tcl_Release((ClientData) script); } else { diff --git a/library/history.tcl b/library/history.tcl index a6beb43..f1516f3 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -19,7 +19,7 @@ namespace eval tcl { variable history - if ![info exists history] { + if {![info exists history]} { array set history { nextid 0 keep 20 @@ -118,7 +118,7 @@ proc history {args} { return [tcl::HistKeep] } else { set limit [lindex $args 1] - if {[catch {expr $limit}] || ($limit < 0)} { + if {[catch {expr {~$limit}}] || ($limit < 0)} { return -code error "illegal keep count \"$limit\"" } return [tcl::HistKeep $limit] @@ -132,7 +132,7 @@ proc history {args} { if {![string match $key* nextid]} { return -code error "bad option \"$key\": must be $options" } - return [expr $tcl::history(nextid) + 1] + return [expr {$tcl::history(nextid) + 1}] } r* { # history redo @@ -196,7 +196,7 @@ proc history {args} { return $history(keep) } else { set oldold $history(oldest) - set history(oldest) [expr $history(nextid) - $limit] + set history(oldest) [expr {$history(nextid) - $limit}] for {} {$oldold <= $history(oldest)} {incr oldold} { if {[info exists history($oldold)]} {unset history($oldold)} } @@ -241,13 +241,13 @@ proc history {args} { proc tcl::HistInfo {{num {}}} { variable history if {$num == {}} { - set num [expr $history(keep) + 1] + set num [expr {$history(keep) + 1}] } set result {} set newline "" - for {set i [expr $history(nextid) - $num + 1]} \ + for {set i [expr {$history(nextid) - $num + 1}]} \ {$i <= $history(nextid)} {incr i} { - if ![info exists history($i)] { + if {![info exists history($i)]} { continue } set cmd [string trimright $history($i) \ \n] @@ -304,7 +304,7 @@ proc history {args} { proc tcl::HistIndex {event} { variable history - if {[catch {expr $event}]} { + if {[catch {expr {~$event}}]} { for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} { if {[string match $event* $history($i)]} { return $i; @@ -315,7 +315,7 @@ proc history {args} { } return -code error "no event matches \"$event\"" } elseif {$event <= 0} { - set i [expr $history(nextid) + $event] + set i [expr {$history(nextid) + $event}] } else { set i $event } diff --git a/library/init.tcl b/library/init.tcl index ebf1913..76cec74 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. # -# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34 +# SCCS: %Z% $Id: init.tcl,v 1.2 1998/06/27 18:11:24 welch Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -21,7 +21,7 @@ package require -exact Tcl 8.0 # (auto_path could be already set, in safe interps for instance) if {![info exists auto_path]} { - if [catch {set auto_path $env(TCLLIBPATH)}] { + if {[catch {set auto_path $env(TCLLIBPATH)}]} { set auto_path "" } } @@ -37,6 +37,41 @@ catch { unset __dir } +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} { + namespace eval tcl { + proc envTraceProc {lo n1 n2 op} { + set x $::env($n2) + set ::env($lo) $x + set ::env([string toupper $lo]) $x + } + } + foreach p [array names env] { + set u [string toupper $p] + if {$u != $p} { + switch -- $u { + COMSPEC - + PATH { + if {![info exists env($u)]} { + set env($u) $env($p) + } + trace variable env($p) w [list tcl::envTraceProc $p] + trace variable env($u) w [list tcl::envTraceProc $p] + } + } + } + } + if {![info exists env(COMSPEC)]} { + if {$tcl_platform(os) == {Windows NT}} { + set env(COMSPEC) cmd.exe + } else { + set env(COMSPEC) command.com + } + } +} + + # Setup the unknown package handler package unknown tclPkgUnknown @@ -98,11 +133,11 @@ if {[info commands tclLog] == ""} { set savedErrorCode $errorCode set savedErrorInfo $errorInfo set name [lindex $args 0] - if ![info exists auto_noload] { + if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # - if [info exists unknown_pending($name)] { + if {[info exists unknown_pending($name)]} { return -code error "self-referential recursion in \"unknown\" for command \"$name\""; } set unknown_pending($name) pending; @@ -112,10 +147,10 @@ if {[info commands tclLog] == ""} { return -code $ret -errorcode $errorCode \ "error while autoloading \"$name\": $msg" } - if ![array size unknown_pending] { + if {![array size unknown_pending]} { unset unknown_pending } - if $msg { + if {$msg} { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set code [catch {uplevel 1 $args} msg] @@ -126,7 +161,7 @@ if {[info commands tclLog] == ""} { # set new [split $errorInfo \n] - set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n] return -code error -errorcode $errorCode \ -errorinfo $new $msg } else { @@ -137,7 +172,7 @@ if {[info commands tclLog] == ""} { if {([info level] == 1) && ([info script] == "") \ && [info exists tcl_interactive] && $tcl_interactive} { - if ![info exists auto_noexec] { + if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new != ""} { set errorCode $savedErrorCode @@ -159,7 +194,7 @@ if {[info commands tclLog] == ""} { set newcmd [history event -1] catch {regsub -all -- $old $newcmd $new newcmd} } - if [info exists newcmd] { + if {[info exists newcmd]} { tclLog $newcmd history change $newcmd 0 return [uplevel $newcmd] @@ -211,15 +246,15 @@ if {[info commands tclLog] == ""} { # from older auto_mkindex versions lappend nameList $cmd foreach name $nameList { - if [info exists auto_index($name)] { + if {[info exists auto_index($name)]} { uplevel #0 $auto_index($name) return [expr {[info commands $name] != ""}] } } - if ![info exists auto_path] { + if {![info exists auto_path]} { return 0 } - if [info exists auto_oldpath] { + if {[info exists auto_oldpath]} { if {$auto_oldpath == $auto_path} { return 0 } @@ -230,12 +265,12 @@ if {[info commands tclLog] == ""} { # newer format tclIndex files. set issafe [interp issafe] - for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { set dir [lindex $auto_path $i] set f "" if {$issafe} { catch {source [file join $dir tclIndex]} - } elseif [catch {set f [open [file join $dir tclIndex]]}] { + } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { continue } else { set error [catch { @@ -261,13 +296,13 @@ if {[info commands tclLog] == ""} { if {$f != ""} { close $f } - if $error { + if {$error} { error $msg $errorInfo $errorCode } } } foreach name $nameList { - if [info exists auto_index($name)] { + if {[info exists auto_index($name)]} { uplevel #0 $auto_index($name) if {[info commands $name] != ""} { return 1 @@ -359,7 +394,7 @@ if {[string compare $tcl_platform(platform) windows] == 0} { proc auto_execok name { global auto_execs env tcl_platform - if [info exists auto_execs($name)] { + if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" @@ -425,7 +460,7 @@ proc auto_execok name { proc auto_execok name { global auto_execs env - if [info exists auto_execs($name)] { + if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" @@ -506,7 +541,7 @@ proc auto_mkindex {dir args} { set error [catch { set f [open $file] while {[gets $f line] >= 0} { - if [regexp {^proc[ ]+([^ ]*)} $line match procName] { + if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] append index "set [list auto_index($procName)]" append index " \[list source \[file join \$dir [list $file]\]\]\n" @@ -514,7 +549,7 @@ proc auto_mkindex {dir args} { } close $f } msg] - if $error { + if {$error} { set code $errorCode set info $errorInfo catch {close $f} @@ -529,7 +564,7 @@ proc auto_mkindex {dir args} { close $f cd $oldDir } msg] - if $error { + if {$error} { set code $errorCode set info $errorInfo catch {close $f} @@ -589,7 +624,7 @@ proc pkg_mkIndex {dir args} { } } $c eval [list set file $file] - if [catch { + if {[catch { $c eval { proc dummy args {} rename package package-orig @@ -657,7 +692,7 @@ proc pkg_mkIndex {dir args} { } } } - } msg] { + } msg]} { tclLog "error while loading or sourcing $file: $msg" } foreach pkg [$c eval set pkgs] { @@ -719,7 +754,7 @@ proc tclPkgSetup {dir pkg version files} { proc tclMacPkgSearch {dir} { foreach x [glob -nocomplain [file join $dir *.shlb]] { - if [file isfile $x] { + if {[file isfile $x]} { set res [resource open $x] foreach y [resource list TEXT $res] { if {$y == "pkgIndex"} {source -rsrc pkgIndex} @@ -745,17 +780,17 @@ proc tclMacPkgSearch {dir} { proc tclPkgUnknown {name version {exact {}}} { global auto_path tcl_platform env - if ![info exists auto_path] { + if {![info exists auto_path]} { return } - for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { # we can't use glob in safe interps, so enclose the following # in a catch statement catch { foreach file [glob -nocomplain [file join [lindex $auto_path $i] \ * pkgIndex.tcl]] { set dir [file dirname $file] - if [catch {source $file} msg] { + if {[catch {source $file} msg]} { tclLog "error reading package index file $file: $msg" } } @@ -775,7 +810,7 @@ proc tclPkgUnknown {name version {exact {}}} { set dir [lindex $auto_path $i] tclMacPkgSearch $dir foreach x [glob -nocomplain [file join $dir *]] { - if [file isdirectory $x] { + if {[file isdirectory $x]} { set dir $x tclMacPkgSearch $dir } diff --git a/library/parray.tcl b/library/parray.tcl index 430e7ff..d80ad8d 100644 --- a/library/parray.tcl +++ b/library/parray.tcl @@ -1,7 +1,7 @@ # parray: # Print the contents of a global array on stdout. # -# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44 +# SCCS: %Z% $Id: parray.tcl,v 1.2 1998/06/27 18:11:25 welch Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. @@ -12,7 +12,7 @@ proc parray {a {pattern *}} { upvar 1 $a array - if ![array exists array] { + if {![array exists array]} { error "\"$a\" isn't an array" } set maxl 0 diff --git a/library/safe.tcl b/library/safe.tcl index 9b93523..9eb9a3f 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. # -# SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20 +# SCCS: %Z% $Id: safe.tcl,v 1.2 1998/06/27 18:11:25 welch Exp $ # # The implementation is based on namespaces. These naming conventions @@ -417,7 +417,7 @@ proc ::safe::interpAddToAccessPath {slave path} { Lappend [VirtualPathListName $slave] $token; Lappend [PathListName $slave] $path; - Set $nname [expr $n+1]; + Set $nname [expr {$n+1}]; SyncAccessPath $slave; @@ -528,7 +528,7 @@ proc ::safe::interpDelete {slave} { # remove the hook now, otherwise if the hook # calls us somehow, we'll loop Unset $hookname; - if {[catch {eval $hook $slave} err]} { + if {[catch {eval $hook [list $slave]} err]} { Log $slave "Delete hook error ($err)"; } } @@ -681,7 +681,7 @@ proc ::safe::setLogCmd {args} { if {[regexp {(::)|(\.\.)} $path]} { error "invalid characters in path $path"; } - set n [expr [Set [PathNumberName $slave]]-1]; + set n [expr {[Set [PathNumberName $slave]]-1}]; for {} {$n>=0} {incr n -1} { # fill the token virtual names with their real value set [PathToken $n] [Set [PathToken $n $slave]]; diff --git a/library/word.tcl b/library/word.tcl index 64639f2..56fca90 100644 --- a/library/word.tcl +++ b/library/word.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) word.tcl 1.2 96/11/20 14:07:22 +# SCCS: %Z% $Id: word.tcl,v 1.2 1998/06/27 18:11:26 welch Exp $ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -42,8 +42,8 @@ if {$tcl_platform(platform) == "windows"} { proc tcl_wordBreakAfter {str start} { global tcl_nonwordchars tcl_wordchars set str [string range $str $start end] - if [regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result] { - return [expr [lindex $result 1] + $start] + if {[regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result]} { + return [expr {[lindex $result 1] + $start}] } return -1 } @@ -64,7 +64,7 @@ proc tcl_wordBreakBefore {str start} { if {[string compare $start end] == 0} { set start [string length $str] } - if [regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result] { + if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} { return [lindex $result 1] } return -1 @@ -84,9 +84,9 @@ proc tcl_wordBreakBefore {str start} { proc tcl_endOfWord {str start} { global tcl_nonwordchars tcl_wordchars - if [regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \ - [string range $str $start end] result] { - return [expr [lindex $result 1] + $start] + if {[regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \ + [string range $str $start end] result]} { + return [expr {[lindex $result 1] + $start}] } return -1 } @@ -105,9 +105,9 @@ proc tcl_endOfWord {str start} { proc tcl_startOfNextWord {str start} { global tcl_nonwordchars tcl_wordchars - if [regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \ - [string range $str $start end] result] { - return [expr [lindex $result 1] + $start] + if {[regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \ + [string range $str $start end] result]} { + return [expr {[lindex $result 1] + $start}] } return -1 } @@ -126,9 +126,9 @@ proc tcl_startOfPreviousWord {str start} { if {[string compare $start end] == 0} { set start [string length $str] } - if [regexp -indices \ + if {[regexp -indices \ "$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \ - [string range $str 0 [expr $start - 1]] result word] { + [string range $str 0 [expr {$start - 1}]] result word]} { return [lindex $word 0] } return -1 diff --git a/mac/tclMacAlloc.c b/mac/tclMacAlloc.c index 59d1417..6736675 100644 --- a/mac/tclMacAlloc.c +++ b/mac/tclMacAlloc.c @@ -23,6 +23,7 @@ #include <stdlib.h> #include <string.h> + /* * Flags that are used by ConfigureMemory to define how the allocator * should work. They can be or'd together. @@ -242,6 +243,7 @@ TclpSysFree( hand = * (Handle *) ((Ptr) ptr - sizeof(Handle)); DisposeHandle(hand); + *hand = NULL; err = MemError(); } @@ -272,7 +274,9 @@ CleanUpExitProc() while (systemMemory != NULL) { memRecord = systemMemory; systemMemory = memRecord->next; - DisposeHandle(memRecord->memoryHandle); + if (*(memRecord->memoryHandle) != NULL) { + DisposeHandle(memRecord->memoryHandle); + } DisposePtr((void *) memRecord); } } @@ -303,13 +307,17 @@ FreeAllMemory() while (systemMemory != NULL) { memRecord = systemMemory; systemMemory = memRecord->next; - DisposeHandle(memRecord->memoryHandle); + if (*(memRecord->memoryHandle) != NULL) { + DisposeHandle(memRecord->memoryHandle); + } DisposePtr((void *) memRecord); } while (appMemory != NULL) { memRecord = appMemory; appMemory = memRecord->next; - DisposeHandle(memRecord->memoryHandle); + if (*(memRecord->memoryHandle) != NULL) { + DisposeHandle(memRecord->memoryHandle); + } DisposePtr((void *) memRecord); } } diff --git a/tests/opt.test b/tests/opt.test index 0b35b76..69d981c 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -253,3 +253,25 @@ test opt-10.10 {medium size overall test} { list [catch {optTest save tst foo} msg] [lindex [split $msg "\n"] 0] } {1 {too many arguments (unexpected argument(s): foo), usage:}} + +test opt-11.1 {too many args test 2} { + set key [::tcl::OptKeyRegister {-foo}] + list [catch {::tcl::OptKeyParse $key {-foo blah}} msg] $msg\ + [::tcl::OptKeyDelete $key] +} {1 {too many arguments (unexpected argument(s): blah), usage: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + ( -help gives this help ) + -foo boolflag (false) } {}} + + + +test opt-11.2 {default value for args} { + set args {} + set key [::tcl::OptKeyRegister {{args -list {a b c} "args..."}}] + ::tcl::OptKeyParse $key {} + ::tcl::OptKeyDelete $key + set args +} {a b c} + + diff --git a/tests/socket.test b/tests/socket.test index 24f9e2a..e2697c2 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -981,6 +981,18 @@ test socket-9.3 {testing EOF stickyness} { } } } +test socket-10.1 {testing socket accept callback error handling} { + set goterror 0 + proc bgerror args {global goterror; set goterror 1} + set s [socket -server accept 2898] + proc accept {s a p} {close $s; error} + set c [socket localhost 2898] + vwait goterror + close $s + close $c + set goterror +} 1 + proc timerproc {} { global done count c set done true @@ -1018,7 +1030,7 @@ if {$doTestsWithRemoteServer == 0} { return } -test socket-10.1 {tcp connection} { +test socket-11.1 {tcp connection} { sendCommand { set socket9_1_test_server [socket -server accept 2834] proc accept {s a p} { @@ -1032,7 +1044,7 @@ test socket-10.1 {tcp connection} { sendCommand {close $socket9_1_test_server} set r } done -test socket-10.2 {client specifies its port} { +test socket-11.2 {client specifies its port} { if {[info exists port]} { incr port } else { @@ -1056,10 +1068,7 @@ test socket-10.2 {client specifies its port} { } set result } ok -# -# Tests io-10.3, io-10.4 have been removed. -# -test socket-10.3 {trying to connect, no server} { +test socket-11.3 {trying to connect, no server} { set status ok if {![catch {set s [socket $remoteServerIp 2836]}]} { if {![catch {gets $s}]} { @@ -1069,7 +1078,7 @@ test socket-10.3 {trying to connect, no server} { } set status } ok -test socket-10.4 {remote echo, one line} { +test socket-11.4 {remote echo, one line} { sendCommand { set socket10_6_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1093,7 +1102,7 @@ test socket-10.4 {remote echo, one line} { sendCommand {close $socket10_6_test_server} set r } hello -test socket-10.5 {remote echo, 50 lines} { +test socket-11.5 {remote echo, 50 lines} { sendCommand { set socket10_7_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1127,7 +1136,7 @@ if {$tcl_platform(platform) == "macintosh"} { } else { set conflictResult {1 {couldn't open socket: address already in use}} } -test socket-10.6 {socket conflict} { +test socket-11.6 {socket conflict} { set s1 [socket -server accept 2836] if {[catch {set s2 [socket -server accept 2836]} msg]} { set result [list 1 $msg] @@ -1138,7 +1147,7 @@ test socket-10.6 {socket conflict} { close $s1 set result } $conflictResult -test socket-10.7 {server with several clients} { +test socket-11.7 {server with several clients} { sendCommand { set socket10_9_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1174,7 +1183,7 @@ test socket-10.7 {server with several clients} { sendCommand {close $socket10_9_test_server} set i } 100 -test socket-10.8 {client with several servers} { +test socket-11.8 {client with several servers} { sendCommand { set s1 [socket -server "accept 4003" 4003] set s2 [socket -server "accept 4004" 4004] @@ -1200,7 +1209,7 @@ test socket-10.8 {client with several servers} { } set l } {4003 {} 1 4004 {} 1 4005 {} 1} -test socket-10.9 {accept callback error} { +test socket-11.9 {accept callback error} { set s [socket -server accept 2836] proc accept {s a p} {expr 10 / 0} proc bgerror args { @@ -1222,7 +1231,7 @@ test socket-10.9 {accept callback error} { rename bgerror {} set x } {{divide by zero}} -test socket-10.10 {testing socket specific options} { +test socket-11.10 {testing socket specific options} { sendCommand { set socket10_12_test_server [socket -server accept 2836] proc accept {s a p} {close $s} @@ -1236,7 +1245,7 @@ test socket-10.10 {testing socket specific options} { sendCommand {close $socket10_12_test_server} set l } {2836 3 3} -test socket-10.11 {testing spurious events} { +test socket-11.11 {testing spurious events} { sendCommand { set socket10_13_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1275,7 +1284,7 @@ test socket-10.11 {testing spurious events} { sendCommand {close $socket10_13_test_server} list $spurious $len } {0 2690} -test socket-10.12 {testing EOF stickyness} { +test socket-11.12 {testing EOF stickyness} { set counter 0 set done 0 proc count_up {s} { @@ -1308,7 +1317,7 @@ test socket-10.12 {testing EOF stickyness} { sendCommand {close $socket10_14_test_server} set done } {EOF is sticky} -test socket-10.13 {testing async write, async flush, async close} { +test socket-11.13 {testing async write, async flush, async close} { proc readit {s} { global count done set l [read $s] diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 56df95d..baff098 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -45,55 +45,11 @@ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; static int initialized = 0; /* - * The following string is the startup script executed in new - * interpreters. It looks on disk in several different directories - * for a script "init.tcl" that is compatible with this version - * of Tcl. The init.tcl script does all of the real work of - * initialization. + * The Init script (common to Windows and Unix platforms) is + * defined in tclInitScript.h */ -static char initScript[] = -"proc tclInit {} {\n\ - global tcl_library tcl_version tcl_patchLevel env errorInfo\n\ - global tcl_pkgPath\n\ - rename tclInit {}\n\ - set errors {}\n\ - set dirs {}\n\ - if {[info exists env(tcl_pkgLibrary)]} {\n\ - lappend dirs $env(tcl_pkgLibrary)\n\ - }\n\ - if [info exists env(TCL_LIBRARY)] {\n\ - lappend dirs $env(TCL_LIBRARY)\n\ - }\n\ - lappend dirs [info library]\n\ - set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ - lappend dirs $parentDir/lib/tcl$tcl_version\n\ - if [string match {*[ab]*} $tcl_patchLevel] {\n\ - set lib tcl$tcl_patchLevel\n\ - } else {\n\ - set lib tcl$tcl_version\n\ - }\n\ - lappend dirs [file dirname $parentDir]/$lib/library\n\ - lappend dirs $parentDir/library\n\ - foreach i $dirs {\n\ - set tcl_library $i\n\ - set tclfile [file join $i init.tcl]\n\ - if {[file exists $tclfile]} {\n\ - lappend tcl_pkgPath [file dirname $i]\n\ - if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\ - return\n\ - } else {\n\ - append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ - }\n\ - }\n\ - }\n\ - set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ - append msg \" $dirs\n\n\"\n\ - append msg \"$errors\n\n\"\n\ - append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ - error $msg\n\ -}\n\ -tclInit"; +#include "tclInitScript.h" /* * Static routines in this file: diff --git a/win/tclWinInit.c b/win/tclWinInit.c index fee2aa7..6f7425c 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -66,82 +66,12 @@ static char* processors[NUMPROCESSORS] = { }; /* - * The following string is the startup script executed in new - * interpreters. It looks on disk in several different directories - * for a script "init.tcl" that is compatible with this version - * of Tcl. The init.tcl script does all of the real work of - * initialization. + * The Init script (common to Windows and Unix platforms) is + * defined in tclInitScript.h */ -static char *initScript = -"proc init {} {\n\ - global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\ - global tcl_pkgPath\n\ - rename init {}\n\ - set errors {}\n\ - proc tcl_envTraceProc {lo n1 n2 op} {\n\ - global env\n\ - set x $env($n2)\n\ - set env($lo) $x\n\ - set env([string toupper $lo]) $x\n\ - }\n\ - foreach p [array names env] {\n\ - set u [string toupper $p]\n\ - if {$u != $p} {\n\ - switch -- $u {\n\ - COMSPEC -\n\ - PATH {\n\ - if {![info exists env($u)]} {\n\ - set env($u) $env($p)\n\ - }\n\ - trace variable env($p) w [list tcl_envTraceProc $p]\n\ - trace variable env($u) w [list tcl_envTraceProc $p]\n\ - }\n\ - }\n\ - }\n\ - }\n\ - if {![info exists env(COMSPEC)]} {\n\ - if {$tcl_platform(os) == {Windows NT}} {\n\ - set env(COMSPEC) cmd.exe\n\ - } else {\n\ - set env(COMSPEC) command.com\n\ - }\n\ - } \n\ - set dirs {}\n\ - if {[info exists env(tcl_pkgLibrary)]} {\n\ - lappend dirs $env(tcl_pkgLibrary)\n\ - }\n\ - if {[info exists env(TCL_LIBRARY)]} {\n\ - lappend dirs $env(TCL_LIBRARY)\n\ - }\n\ - lappend dirs $tcl_library\n\ - lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\ - if [string match {*[ab]*} $tcl_patchLevel] {\n\ - set lib tcl$tcl_patchLevel\n\ - } else {\n\ - set lib tcl$tcl_version\n\ - }\n\ - lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\ - lappend dirs [file join [file dirname [pwd]] library]\n\ - foreach i $dirs {\n\ - set tcl_library $i\n\ - set tclfile [file join $i init.tcl]\n\ - if {[file exists $tclfile]} {\n\ - lappend tcl_pkgPath [file dirname $i]\n\ - if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\ - return\n\ - } else {\n\ - append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ - }\n\ - }\n\ - }\n\ - set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ - append msg \" $dirs\n\n\"\n\ - append msg \"$errors\n\n\"\n\ - append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ - error $msg\n\ -}\n\ -init\n"; +#include "tclInitScript.h" + /* *---------------------------------------------------------------------- |