aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/tests
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1996-09-18 14:12:34 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1996-09-18 14:12:34 +0000
commit8569730d6bc2e4cb5e784997313325b13518e066 (patch)
tree6030c8489bce8cf7333fc4d0b644065e106224b5 /contrib/tcl/tests
parent403acdc0da2969f284b74b720692585bfc676190 (diff)
downloadsrc-8569730d6bc2e4cb5e784997313325b13518e066.tar.gz
src-8569730d6bc2e4cb5e784997313325b13518e066.zip
Import tcl7.5p1
Notes
Notes: svn path=/vendor/tcl/dist/; revision=18351
Diffstat (limited to 'contrib/tcl/tests')
-rw-r--r--contrib/tcl/tests/clock.test11
-rw-r--r--contrib/tcl/tests/cmdAH.test14
-rw-r--r--contrib/tcl/tests/defs4
-rw-r--r--contrib/tcl/tests/fileName.test6
-rw-r--r--contrib/tcl/tests/format.test10
-rw-r--r--contrib/tcl/tests/io.test197
-rw-r--r--contrib/tcl/tests/license.terms15
-rw-r--r--contrib/tcl/tests/lrange.test5
-rw-r--r--contrib/tcl/tests/lreplace.test5
-rw-r--r--contrib/tcl/tests/socket.test168
10 files changed, 343 insertions, 92 deletions
diff --git a/contrib/tcl/tests/clock.test b/contrib/tcl/tests/clock.test
index a14f13a01012..cf8d94bfae6d 100644
--- a/contrib/tcl/tests/clock.test
+++ b/contrib/tcl/tests/clock.test
@@ -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: @(#) clock.test 1.5 96/04/05 15:30:36
+# SCCS: @(#) clock.test 1.6 96/07/23 16:16:43
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -46,10 +46,17 @@ test clock-3.2 {clock format tests} {
test clock-3.3 {clock format tests} {
list [catch {clock format foo} msg] $msg
} {1 {expected unsigned time but got "foo"}}
-test clock-3.4 {clock format tests} {unixOnly} {
+test clock-3.4 {clock format tests} {unixOrPc} {
set clockval 657687766
clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true
} "Sun Nov 04 03:02:46 AM 1990"
+test clock-3.5 {clock format tests} {
+ list [catch {clock format a b c d e g} msg] $msg
+} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}}
+test clock-3.6 {clock format tests} {unixOrPc} {
+ set clockval -1
+ clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true
+} "Wed Dec 31 11:59:59 PM 1969"
# clock scan
test clock-4.1 {clock scan tests} {
diff --git a/contrib/tcl/tests/cmdAH.test b/contrib/tcl/tests/cmdAH.test
index 058ee73f6b0d..97c5bddf7c1b 100644
--- a/contrib/tcl/tests/cmdAH.test
+++ b/contrib/tcl/tests/cmdAH.test
@@ -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: @(#) cmdah.test 1.7 96/04/12 10:49:01
+# SCCS: @(#) cmdAH.test 1.9 96/07/01 14:38:19
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -404,7 +404,7 @@ test cmdah-3.42 {Tcl_FileCmd: tail} {
set result [file tail ~]
set env(HOME) $temp
set result
-} {}
+} test
test cmdah-3.43 {Tcl_FileCmd: tail} {
global env
set temp $env(HOME)
@@ -422,7 +422,7 @@ test cmdah-3.44 {Tcl_FileCmd: tail} {
set result [file tail ~]
set env(HOME) $temp
set result
-} {}
+} test
test cmdah-3.45 {Tcl_FileCmd: tail} {
global env
set temp $env(HOME)
@@ -431,7 +431,7 @@ test cmdah-3.45 {Tcl_FileCmd: tail} {
set result [file tail ~]
set env(HOME) $temp
set result
-} {}
+} test
test cmdah-3.46 {Tcl_FileCmd: tail} {
testsetplatform unix
file tail {f.oo\bar/baz.bat}
@@ -1016,7 +1016,11 @@ test cmdah-19.3 {Tcl_FileCmd: readlink errors} {unixOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
-test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOrPc nonPortable} {
+test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOnly nonPortable} {
+ list [catch {file readlink _bogus_} msg] [string tolower $msg] \
+ [string tolower $errorCode]
+} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
+test cmdah-19.5 {Tcl_FileCmd: readlink errors} {pcOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}
diff --git a/contrib/tcl/tests/defs b/contrib/tcl/tests/defs
index aaf6cfc72cf4..62f1e4c6c646 100644
--- a/contrib/tcl/tests/defs
+++ b/contrib/tcl/tests/defs
@@ -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: @(#) defs 1.37 96/04/12 13:45:04
+# SCCS: @(#) defs 1.38 96/07/24 17:18:20
if ![info exists VERBOSE] {
set VERBOSE 0
@@ -55,6 +55,7 @@ if {[info commands memory] == ""} {
# run tests that only work on PCs.
# unixOrPc - 1 means this is a UNIX or PC platform.
# macOrPc - 1 means this is a Mac or PC platform.
+# macOrUnix - 1 means this is a Mac or UNIX platform.
# nonPortable - 1 means this the tests are being running in
# the master Tcl/Tk development environment;
# Some tests are inherently non-portable because
@@ -93,6 +94,7 @@ if {$tcl_platform(platform) == "windows"} {
}
set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
+set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
set testConfig(nonPortable) [file exists doAllTests]
set f [open defs r]
diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test
index 26e84d9ba013..abb3eb857d20 100644
--- a/contrib/tcl/tests/fileName.test
+++ b/contrib/tcl/tests/fileName.test
@@ -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: @(#) fileName.test 1.20 96/04/19 12:36:13
+# SCCS: @(#) fileName.test 1.23 96/07/31 11:46:11
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -1086,8 +1086,8 @@ test filename-11.12 {Tcl_GlobCmd} {
testsetplatform $platform
test filename-11.13 {Tcl_GlobCmd} {
- list [catch {glob ~} msg] $msg
-} [list 0 [list $env(HOME)]]
+ list [catch {file join [lindex [glob ~] 0]} msg] $msg
+} [list 0 [file join $env(HOME)]]
# The following tests will work on Windows platforms only if MKS
# toolkit is installed.
diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test
index 3fe4eb5a957b..e6764f3df4ac 100644
--- a/contrib/tcl/tests/format.test
+++ b/contrib/tcl/tests/format.test
@@ -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: @(#) format.test 1.22 96/02/16 08:55:56
+# SCCS: @(#) format.test 1.23 96/07/31 16:54:50
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -355,12 +355,6 @@ test format-10.12 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5 6} msg] $msg
} {0 { 6}}
-test format-11.1 {enormous width specifiers} {
- format "%077777777d" 77777777
-} {0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000077777777}
-test format-11.2 {enormous width specifiers} {
- format "%*d" 123456789 77777777
-} { 77777777}
-test format-11.3 {negative width specifiers} {
+test format-11.1 {negative width specifiers} {
format "%*d" -47 25
} {25}
diff --git a/contrib/tcl/tests/io.test b/contrib/tcl/tests/io.test
index 60b75cd42c1d..2c856246c089 100644
--- a/contrib/tcl/tests/io.test
+++ b/contrib/tcl/tests/io.test
@@ -11,13 +11,24 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# "@(#) io.test 1.75 96/04/18 09:58:51"
+# "@(#) io.test 1.87 96/07/30 11:59:00"
if {[string compare test [info procs test]] == 1} then {source defs}
removeFile test1
removeFile pipe
+# set up a long data file for some of the following tests
+
+set f [open longfile w]
+fconfigure $f -eofchar {} -translation lf
+for { set i 0 } { $i < 100 } { incr i} {
+ puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
+\#123456789abcdef01
+\#"
+ }
+close $f
+
# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.7 {unsupported0 command} {
@@ -339,14 +350,18 @@ test io-4.2 {Tcl_GetChannelType} {
string compare $t file
} 0
test io-4.3 {Tcl_GetChannelFile, input} {
- set f [open io.test r]
+ set f [open test1 w]
+ fconfigure $f -translation lf -eofchar {}
+ puts $f "1234567890\n098765432"
+ close $f
+ set f [open test1 r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
-} {4022 74}
+} {10 11}
test io-4.4 {Tcl_GetChannelFile, output} {
removeFile test1
set f [open test1 w]
@@ -678,39 +693,39 @@ test io-7.10 {Tcl_Write, looping and buffering} {
removeFile test1
set f1 [open test1 w]
fconfigure $f1 -translation lf -eofchar {}
- set f2 [open io.test r]
+ set f2 [open longfile r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
file size test1
-} 439
+} 387
test io-7.11 {Tcl_Write, no newline, implicit flush} {
removeFile test1
set f1 [open test1 w]
fconfigure $f1 -eofchar {}
- set f2 [open io.test r]
+ set f2 [open longfile r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size test1
-} 429
+} 377
test io-7.12 {Tcl_Write on a pipe} {unixOrPc} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
puts $f1 {
- set f1 [open io.test r]
+ set f1 [open longfile r]
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
}
close $f1
set f1 [open "|$tcltest pipe" r]
- set f2 [open io.test r]
+ set f2 [open longfile r]
set y ok
for {set x 0} {$x < 10} {incr x} {
set l1 [gets $f1]
@@ -735,7 +750,7 @@ test io-7.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} {
set y ok
set f1 [open "|$tcltest pipe" r+]
fconfigure $f1 -buffering line
- set f2 [open io.test r]
+ set f2 [open longfile r]
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
@@ -775,7 +790,7 @@ test io-7.15 {Tcl_Flush, channel not open for writing} {
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-7.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} {
- set fd [open "|cat io.test" r]
+ set fd [open "|cat longfile" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
@@ -1070,6 +1085,99 @@ test io-7.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo
set result ok
}
} ok
+test io-7.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} {
+ set f [open script w]
+ puts $f {
+ set f [open test1 w]
+ fconfigure $f -translation lf
+ puts $f hello
+ puts $f bye
+ puts $f strange
+ }
+ close $f
+ eval exec $tcltest script
+ set f [open test1 r]
+ set r [read $f]
+ close $f
+ set r
+} {hello
+bye
+strange
+}
+test io-7.34 {Tcl_Close, async flush on close, using sockets} {
+ set c 0
+ set x running
+ set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
+ proc writelots {s l} {
+ for {set i 0} {$i < 2000} {incr i} {
+ puts $s $l
+ }
+ }
+ proc accept {s a p} {
+ global x
+ fileevent $s readable [list readit $s]
+ fconfigure $s -blocking off
+ set x accepted
+ }
+ proc readit {s} {
+ global c x
+ set l [gets $s]
+
+ if {[eof $s]} {
+ close $s
+ set x done
+ } elseif {([string length $l] > 0) || ![fblocked $s]} {
+ incr c
+ }
+ }
+ set ss [socket -server accept 2828]
+ set cs [socket [info hostname] 2828]
+ vwait x
+ fconfigure $cs -blocking off
+ writelots $cs $l
+ close $cs
+ close $ss
+ vwait x
+ set c
+} 2000
+test io-7.35 {Tcl_Close vs fileevent vs multiple interpreters} {
+ catch {interp delete x}
+ catch {interp delete y}
+ interp create x
+ interp create y
+ set s [socket -server accept 2828]
+ proc accept {s a p} {
+ puts $s hello
+ close $s
+ }
+ set c [socket [info hostname] 2828]
+ interp share {} $c x
+ interp share {} $c y
+ close $c
+ x eval {
+ proc readit {s} {
+ gets $s
+ if {[eof $s]} {
+ close $s
+ }
+ }
+ }
+ y eval {
+ proc readit {s} {
+ gets $s
+ if {[eof $s]} {
+ close $s
+ }
+ }
+ }
+ x eval "fileevent $c readable \{readit $c\}"
+ y eval "fileevent $c readable \{readit $c\}"
+ y eval [list close $c]
+ update
+ close $s
+ interp delete x
+ interp delete y
+} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
@@ -2112,13 +2220,13 @@ test io-10.2 {Tcl_Read, zero byte count} {
read stdin 0
} ""
test io-10.3 {Tcl_Read, negative byte count} {
- set f [open io.test r]
+ set f [open longfile r]
set l [list [catch {read $f -1} msg] $msg]
close $f
set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-10.4 {Tcl_Read, positive byte count} {
- set f [open io.test r]
+ set f [open longfile r]
set x [read $f 1024]
set s [string length $x]
unset x
@@ -2126,7 +2234,7 @@ test io-10.4 {Tcl_Read, positive byte count} {
set s
} 1024
test io-10.5 {Tcl_Read, multiple buffers} {
- set f [open io.test r]
+ set f [open longfile r]
fconfigure $f -buffersize 100
set x [read $f 1024]
set s [string length $x]
@@ -2135,19 +2243,19 @@ test io-10.5 {Tcl_Read, multiple buffers} {
set s
} 1024
test io-10.6 {Tcl_Read, very large read} {
- set f1 [open io.test r]
+ set f1 [open longfile r]
set z [read $f1 1000000]
close $f1
set l [string length $z]
set x ok
- set z [file size io.test]
+ set z [file size longfile]
if {$z != $l} {
set x broken
}
set x
} ok
test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
- set f1 [open io.test r]
+ set f1 [open longfile r]
fconfigure $f1 -blocking off
set z [read $f1 20]
close $f1
@@ -2159,25 +2267,25 @@ test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set x
} ok
test io-10.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
- set f1 [open io.test r]
+ set f1 [open longfile r]
fconfigure $f1 -blocking off
set z [read $f1 1000000]
close $f1
set x ok
set l [string length $z]]
- set z [file size io.test]]
+ set z [file size longfile]]
if {$z != $l} {
set x broken
}
set x
} ok
test io-10.9 {Tcl_Read, read to end of file} {
- set f1 [open io.test r]
+ set f1 [open longfile r]
set z [read $f1]
close $f1
set l [string length $z]
set x ok
- set z [file size io.test]
+ set z [file size longfile]
if {$z != $l} {
set x broken
}
@@ -2295,7 +2403,7 @@ test io-11.1 {Tcl_Gets, reading what was written} {
set z
} ok
test io-11.2 {Tcl_Gets into variable} {
- set f1 [open io.test r]
+ set f1 [open longfile r]
set c [gets $f1 x]
set l [string length x]
set z ok
@@ -2412,7 +2520,7 @@ test io-11.10 {Tcl_Gets, exercising double buffering} {
# Test Tcl_Seek and Tcl_Tell.
test io-12.1 {Tcl_Seek to current position at start of file} {
- set f1 [open io.test r]
+ set f1 [open longfile r]
seek $f1 0 current
set c [tell $f1]
close $f1
@@ -3040,7 +3148,7 @@ test io-14.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} {
# Test Tcl_InputBuffered
test io-15.1 {Tcl_InputBuffered} {
- set f [open io.test r]
+ set f [open longfile r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
@@ -3050,7 +3158,7 @@ test io-15.1 {Tcl_InputBuffered} {
set l
} {4093 3}
test io-15.2 {Tcl_InputBuffered, test input flushing on seek} {
- set f [open io.test r]
+ set f [open longfile r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
@@ -3066,13 +3174,13 @@ test io-15.2 {Tcl_InputBuffered, test input flushing on seek} {
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
test io-16.1 {Tcl_GetChannelBufferSize, default buffer size} {
- set f [open io.test r]
+ set f [open longfile r]
set s [fconfigure $f -buffersize]
close $f
set s
} 4096
test io-16.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
- set f [open io.test r]
+ set f [open longfile r]
set l ""
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000
@@ -3360,7 +3468,7 @@ test io-18.8 {POSIX open access modes: TRUNC} {
close $f
set x
} abc
-test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable} {
+test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
removeFile test3
set f [open test3 {WRONLY NONBLOCK CREAT}]
puts $f "NONBLOCK test"
@@ -3511,9 +3619,8 @@ test io-22.1 {FileEventProc procedure: normal read event} {
set x [gets $f2]; fileevent $f2 readable {}
}
puts $f2 text; flush $f2
- after 200
set x initial
- update
+ vwait x
set x
} {text}
test io-22.2 {FileEventProc procedure: error in read event} {
@@ -3523,9 +3630,8 @@ test io-22.2 {FileEventProc procedure: error in read event} {
}
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
- after 200
set x initial
- update
+ vwait x
rename bgerror {}
list $x [fileevent $f2 readable]
} {bogus {}}
@@ -3539,7 +3645,9 @@ test io-22.3 {FileEventProc procedure: normal write event} {
}
set x initial
set count 3
- update
+ vwait x
+ vwait x
+ vwait x
set x
} {initial triggered triggered triggered}
test io-22.4 {FileEventProc procedure: eror in write event} {
@@ -3549,7 +3657,7 @@ test io-22.4 {FileEventProc procedure: eror in write event} {
}
fileevent $f2 writable {error bad-write}
set x initial
- update
+ vwait x
rename bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
@@ -3563,9 +3671,9 @@ test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} {
lappend x $line
}
}
- after 200
set x initial
- update
+ vwait x
+ vwait x
close $f4
set x
} {initial foo eof}
@@ -3573,7 +3681,8 @@ test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} {
catch {close $f2}
catch {close $f3}
-} # Closes if {($platform(platform) != "macintosh") && \
+}
+ # Closes if {($platform(platform) != "macintosh") && \
# ($testConfig(unixExecs) == 1)} clause
close $f
@@ -3602,11 +3711,10 @@ test io-23.2 {DeleteFileEvent, cleanup on close} {
}
close $f
set x initial
- update
+ vwait x
close $f2
set x
} {initial {f2 triggered: "foo bar"}}
-
test io-23.3 {DeleteFileEvent, cleanup on close} {
set f [open foo r]
set f2 [open foo r]
@@ -3629,9 +3737,9 @@ test io-23.3 {DeleteFileEvent, cleanup on close} {
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
-if {[info commands testfevent] == ""} {
- break
-}
+# Execute these tests only if the "testfevent" command is present.
+
+if {[info commands testfevent] == "testfevent"} {
test io-24.1 {Tcl event loop vs multiple interpreters} {
testfevent create
@@ -3774,6 +3882,10 @@ test io-25.6 {file events on shared files, deleting file events} {
set x
} {{script 1} {}}
+}
+
+# The above curly closes the test for presence of the "testfevent" command.
+
test io-26.1 {testing readability conditions} {
set f [open bar w]
puts $f abcdefg
@@ -4329,6 +4441,7 @@ test io-27.6 {testing handler deletion vs reentrant calls} {
{first after update}]
} 0
+removeFile longfile
removeFile script
removeFile output
removeFile test1
diff --git a/contrib/tcl/tests/license.terms b/contrib/tcl/tests/license.terms
index 3dcd816f4a3f..96ad96637376 100644
--- a/contrib/tcl/tests/license.terms
+++ b/contrib/tcl/tests/license.terms
@@ -26,7 +26,14 @@ IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
-RESTRICTED RIGHTS: Use, duplication or disclosure by the government
-is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
-of the Rights in Technical Data and Computer Software Clause as DFARS
-252.227-7013 and FAR 52.227-19.
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
diff --git a/contrib/tcl/tests/lrange.test b/contrib/tcl/tests/lrange.test
index 43d92e2700a4..91f443936bb8 100644
--- a/contrib/tcl/tests/lrange.test
+++ b/contrib/tcl/tests/lrange.test
@@ -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: @(#) lrange.test 1.5 96/02/16 08:56:13
+# SCCS: @(#) lrange.test 1.6 96/07/10 17:16:47
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -56,6 +56,9 @@ test lrange-1.13 {range of list elements} {
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
+test lrange-1.14 {range of list elements} {
+ concat \"[lrange {a b \{\ } 0 2]"
+} {"a b \{\ "}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
diff --git a/contrib/tcl/tests/lreplace.test b/contrib/tcl/tests/lreplace.test
index 95c14c0ad1e0..75cddb213418 100644
--- a/contrib/tcl/tests/lreplace.test
+++ b/contrib/tcl/tests/lreplace.test
@@ -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: @(#) lreplace.test 1.12 96/02/16 08:56:14
+# SCCS: @(#) lreplace.test 1.13 96/07/10 17:16:47
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -86,6 +86,9 @@ test lreplace-1.23 {lreplace command} {
test lreplace-1.24 {lreplace command} {
lreplace {1 2 3 4} end -1 z
} {1 2 3 z 4}
+test lreplace-1.25 {lreplace command} {
+ concat \"[lreplace {\}\ hello} end end]\"
+} {"\}\ "}
test lreplace-2.1 {lreplace errors} {
diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test
index a6c66428ea9e..8a356f600091 100644
--- a/contrib/tcl/tests/socket.test
+++ b/contrib/tcl/tests/socket.test
@@ -59,7 +59,7 @@
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
#
-# "@(#) socket.test 1.56 96/04/20 13:29:26"
+# SCCS: @(#) socket.test 1.62 96/08/01 15:57:49
if {[string compare test [info procs test]] == 1} then {source defs}
@@ -108,6 +108,7 @@ if {$doTestsWithRemoteServer == 1} {
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]}] != 0} {
if {[info commands exec] == ""} {
+ set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
} else {
set remoteServerIP localhost
@@ -118,23 +119,28 @@ if {$doTestsWithRemoteServer == 1} {
msg] == 0} {
after 1000
if {[catch {set commandSocket [socket $remoteServerIP \
- $remoteServerPort]}] == 0} {
+ $remoteServerPort]} msg] == 0} {
fconfigure $commandSocket -translation crlf -buffering line
} else {
+ set noRemoteTestReason $msg
set doTestsWithRemoteServer 0
}
} else {
+ set noRemoteTestReason "$msg $tcltest"
set doTestsWithRemoteServer 0
}
}
} else {
fconfigure $commandSocket -translation crlf -buffering line
- }
+ }
}
if {$doTestsWithRemoteServer == 0} {
- puts "Skipping tests with remote server. See tests/socket.test for"
- puts "information on how to run remote server."
+ puts "Skipping tests with remote server. See tests/socket.test for"
+ puts "information on how to run remote server."
+ if {[info exists VERBOSE] && ($VERBOSE != 0)} {
+ puts "Reason for not doing remote tests: $noRemoteTestReason"
+ }
}
#
@@ -481,6 +487,27 @@ test socket-2.9 {socket conflict} {unixOrPc} {
invoked from within
"set f [socket -server accept 2828]..."
(file "script" line 1)}}
+test socket-2.10 {close on accept, accepted socket lives} {
+ set done 0
+ set ss [socket -server accept 2828]
+ proc accept {s a p} {
+ global ss
+ close $ss
+ fileevent $s readable "readit $s"
+ fconfigure $s -trans lf
+ }
+ proc readit {s} {
+ global done
+ gets $s
+ close $s
+ set done 1
+ }
+ set cs [socket [info hostname] 2828]
+ puts $cs hello
+ close $cs
+ vwait done
+ set done
+} 1
test socket-3.1 {socket conflict} {unixOrPc} {
removeFile script
@@ -733,6 +760,20 @@ test socket-7.4 {testing socket specific options} {
set x [fconfigure $s -sockname]
close $s
}
+ set s1 [socket [info hostname] 2828]
+ vwait x
+ close $s
+ close $s1
+ set l ""
+ lappend l [lindex $x 2] [llength $x]
+} {2828 3}
+test socket-7.5 {testing socket specific options} {unixOrPc} {
+ set s [socket -server accept 2828]
+ proc accept {s a p} {
+ global x
+ set x [fconfigure $s -sockname]
+ close $s
+ }
set s1 [socket localhost 2828]
vwait x
close $s
@@ -763,7 +804,7 @@ test socket-8.1 {testing -async flag on sockets} {
close $s
set x done
}
- set s1 [socket -async localhost 2828]
+ set s1 [socket -async [info hostname] 2828]
vwait x
set z [gets $s1]
close $s
@@ -771,6 +812,83 @@ test socket-8.1 {testing -async flag on sockets} {
set z
} bye
+test socket-9.1 {testing spurious events} {
+ set len 0
+ set spurious 0
+ set done 0
+ proc readlittle {s} {
+ global spurious done len
+ set l [read $s 1]
+ if {[string length $l] == 0} {
+ if {![eof $s]} {
+ incr spurious
+ } else {
+ close $s
+ set done 1
+ }
+ } else {
+ incr len [string length $l]
+ }
+ }
+ proc accept {s a p} {
+ fconfigure $s -buffering none -blocking off
+ fileevent $s readable [list readlittle $s]
+ }
+ set s [socket -server accept 2828]
+ set c [socket [info hostname] 2828]
+ puts -nonewline $c 01234567890123456789012345678901234567890123456789
+ close $c
+ vwait done
+ close $s
+ list $spurious $len
+} {0 50}
+test socket-9.2 {testing async write, fileevents, flush on close} {
+ set firstblock ""
+ for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
+ set secondblock ""
+ for {set i 0} {$i < 16} {incr i} {
+ set secondblock "b$secondblock$secondblock"
+ }
+ set l [socket -server accept 8080]
+ proc accept {s a p} {
+ fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
+ -buffering line
+ fileevent $s readable "readable $s"
+ }
+ proc readable {s} {
+ set l [gets $s]
+ fileevent $s readable {}
+ after 1000 respond $s
+ }
+ proc respond {s} {
+ global firstblock
+ puts -nonewline $s $firstblock
+ after 1000 writedata $s
+ }
+ proc writedata {s} {
+ global secondblock
+ puts -nonewline $s $secondblock
+ close $s
+ }
+ set s [socket [info hostname] 8080]
+ fconfigure $s -blocking 0 -trans lf -buffering line
+ set count 0
+ puts $s hello
+ proc readit {s} {
+ global count done
+ set l [read $s]
+ incr count [string length $l]
+ if {[eof $s]} {
+ close $s
+ set done 1
+ }
+ }
+ fileevent $s readable "readit $s"
+ vwait done
+ close $l
+ set count
+} 65566
+
removeFile script
#
@@ -782,7 +900,7 @@ if {$doTestsWithRemoteServer == 0} {
return
}
-test socket-9.1 {tcp connection} {
+test socket-10.1 {tcp connection} {
sendCommand {
set socket9_1_test_server [socket -server accept 2828]
proc accept {s a p} {
@@ -796,7 +914,7 @@ test socket-9.1 {tcp connection} {
sendCommand {close $socket9_1_test_server}
set r
} done
-test socket-9.2 {client specifies its port} {
+test socket-10.2 {client specifies its port} {
if {[info exists port]} {
incr port
} else {
@@ -821,9 +939,9 @@ test socket-9.2 {client specifies its port} {
set result
} ok
#
-# Tests io-9.3, io-9.4 have been removed.
+# Tests io-10.3, io-10.4 have been removed.
#
-test socket-9.5 {trying to connect, no server} {
+test socket-10.5 {trying to connect, no server} {
set status ok
if {![catch {set s [socket $remoteServerIp 2828]}]} {
if {![catch {gets $s}]} {
@@ -833,9 +951,9 @@ test socket-9.5 {trying to connect, no server} {
}
set status
} ok
-test socket-9.6 {remote echo, one line} {
+test socket-10.6 {remote echo, one line} {
sendCommand {
- set socket9_6_test_server [socket -server accept 2828]
+ set socket10_6_test_server [socket -server accept 2828]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
@@ -854,12 +972,12 @@ test socket-9.6 {remote echo, one line} {
puts $f hello
set r [gets $f]
close $f
- sendCommand {close $socket9_6_test_server}
+ sendCommand {close $socket10_6_test_server}
set r
} hello
-test socket-9.7 {remote echo, 50 lines} {
+test socket-10.7 {remote echo, 50 lines} {
sendCommand {
- set socket9_7_test_server [socket -server accept 2828]
+ set socket10_7_test_server [socket -server accept 2828]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
@@ -882,7 +1000,7 @@ test socket-9.7 {remote echo, 50 lines} {
}
}
close $f
- sendCommand {close $socket9_7_test_server}
+ sendCommand {close $socket10_7_test_server}
set cnt
} 50
# Macintosh sockets can have more than one server per port
@@ -891,7 +1009,7 @@ if {$tcl_platform(platform) == "macintosh"} {
} else {
set conflictResult {1 {couldn't open socket: address already in use}}
}
-test socket-9.8 {socket conflict} {
+test socket-10.8 {socket conflict} {
set s1 [socket -server accept 2828]
if {[catch {set s2 [socket -server accept 2828]} msg]} {
set result [list 1 $msg]
@@ -902,9 +1020,9 @@ test socket-9.8 {socket conflict} {
close $s1
set result
} $conflictResult
-test socket-9.9 {server with several clients} {
+test socket-10.9 {server with several clients} {
sendCommand {
- set socket9_9_test_server [socket -server accept 2828]
+ set socket10_9_test_server [socket -server accept 2828]
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
@@ -935,10 +1053,10 @@ test socket-9.9 {server with several clients} {
close $s1
close $s2
close $s3
- sendCommand {close $socket9_9_test_server}
+ sendCommand {close $socket10_9_test_server}
set i
} 100
-test socket-9.10 {client with several servers} {
+test socket-10.10 {client with several servers} {
sendCommand {
set s1 [socket -server "accept 3000" 3000]
set s2 [socket -server "accept 3001" 3001]
@@ -964,7 +1082,7 @@ test socket-9.10 {client with several servers} {
}
set l
} {3000 {} 1 3001 {} 1 3002 {} 1}
-test socket-9.11 {accept callback error} {
+test socket-10.11 {accept callback error} {
set s [socket -server accept 2828]
proc accept {s a p} {expr 10 / 0}
proc bgerror args {
@@ -984,9 +1102,9 @@ test socket-9.11 {accept callback error} {
rename bgerror {}
set x
} {{divide by zero}}
-test socket-9.12 {testing socket specific options} {
+test socket-10.12 {testing socket specific options} {
sendCommand {
- set socket9_12_test_server [socket -server accept 2828]
+ set socket10_12_test_server [socket -server accept 2828]
proc accept {s a p} {close $s}
}
set s [socket $remoteServerIP 2828]
@@ -995,7 +1113,7 @@ test socket-9.12 {testing socket specific options} {
set l ""
lappend l [lindex $p 2] [llength $p] [llength $p]
close $s
- sendCommand {close $socket9_12_test_server}
+ sendCommand {close $socket10_12_test_server}
set l
} {2828 3 3}