Attachment "219366.diff" to
ticket [219366ffff]
added by
andreas_kupries
2001-08-25 04:53:21.
Index: doc/tcltest.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/tcltest.n,v
retrieving revision 1.11
diff -u -r1.11 tcltest.n
--- doc/tcltest.n 2001/03/30 00:56:16 1.11
+++ doc/tcltest.n 2001/08/24 21:49:53
@@ -535,10 +535,10 @@
\fIsingleTestInterp\fR
test can only be run if all test files are sourced into a single interpreter
.TP
-\fIunix\fR
+\fIunix[Only]\fR
test can only be run on any UNIX platform
.TP
-\fIwin\fR
+\fIwin[Only]\fR
test can only be run on any Windows platform
.TP
\fInt\fR
@@ -550,7 +550,7 @@
\fI98\fR
test can only be run on any Windows 98 platform
.TP
-\fImac\fR
+\fImac[Only]\fR
test can only be run on any Mac platform
.TP
\fIunixOrWin\fR
@@ -635,6 +635,12 @@
.TP
\fIstdio\fR
test can only be run if the current app can be spawned via a pipe
+.TP
+\fIsocket\fR
+test can only be run if the machine supports sockets
+.TP
+\fInetwork\fR
+test can only be run if the machine is connected to the network
.SH "RUNNING TEST FILES"
Use the following command to run a test file that uses package
tcltest:
Index: library/tcltest/tcltest.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/tcltest/tcltest.tcl,v
retrieving revision 1.32
diff -u -r1.32 tcltest.tcl
--- library/tcltest/tcltest.tcl 2001/08/22 23:55:45 1.32
+++ library/tcltest/tcltest.tcl 2001/08/24 21:49:53
@@ -1296,6 +1296,7 @@
proc tcltest::initConstraints {} {
global tcl_platform tcl_interactive tk_version
+ global errorCode
# Safely refer to non-existent members of the tcltest::testConstraints
# array without causing an error.
@@ -1515,6 +1516,25 @@
catch {socket} msg
tcltest::testConstraint socket \
[expr {$msg != "sockets are not available on this system"}]
+
+ # If sockets are supported check that the network is actually connected.
+
+ if { $::tcltest::testConstraints(socket) } {
+ # Assume that there is a network we are connected to
+ set ::tcltest::testConstraints(network) 1
+
+ set code [catch {socket [info hostname] 2000} sock]
+ if { $code } {
+ set msg [lindex $errorCode 2]
+ if { [string compare $msg "network is unreachable"] == 0 } {
+ set ::tcltest::testConstraints(network) 0
+ }
+ } else {
+ close $sock
+ }
+ } else {
+ set ::tcltest::testConstraints(network) 0
+ }
# Check for internationalization
Index: tests/http.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/http.test,v
retrieving revision 1.23
diff -u -r1.23 http.test
--- tests/http.test 2001/08/07 00:42:30 1.23
+++ tests/http.test 2001/08/24 21:49:53
@@ -116,7 +116,7 @@
set url [info hostname]:$port
set badurl www.scriptics.com:6666
-test http-3.3 {http::geturl} {
+test http-3.3 {http::geturl} {network} {
set token [http::geturl $url]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -130,7 +130,7 @@
set posturl [info hostname]:$port/post
set badposturl [info hostname]:$port/droppost
-test http-3.4 {http::geturl} {
+test http-3.4 {http::geturl} {network} {
set token [http::geturl $url]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -142,7 +142,7 @@
global port
return [list [info hostname] $port]
}
-test http-3.5 {http::geturl} {
+test http-3.5 {http::geturl} {network} {
http::config -proxyfilter selfproxy
set token [http::geturl $url]
http::config -proxyfilter http::ProxyRequired
@@ -152,7 +152,7 @@
<h2>GET http://$url</h2>
</body></html>"
-test http-3.6 {http::geturl} {
+test http-3.6 {http::geturl} {network} {
http::config -proxyfilter bogus
set token [http::geturl $url]
http::config -proxyfilter http::ProxyRequired
@@ -162,7 +162,7 @@
<h2>GET $tail</h2>
</body></html>"
-test http-3.7 {http::geturl} {
+test http-3.7 {http::geturl} {network} {
set token [http::geturl $url -headers {Pragma no-cache}]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -170,7 +170,7 @@
<h2>GET $tail</h2>
</body></html>"
-test http-3.8 {http::geturl} {
+test http-3.8 {http::geturl} {network} {
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -183,12 +183,12 @@
</dl>
</body></html>"
-test http-3.9 {http::geturl} {
+test http-3.9 {http::geturl} {network} {
set token [http::geturl $url -validate 1]
http::code $token
} "HTTP/1.0 200 OK"
-test http-3.10 {http::geturl queryprogress} {
+test http-3.10 {http::geturl queryprogress} {network} {
set query foo=bar
set sep ""
set i 0
@@ -210,7 +210,7 @@
list [http::status $t] [string length $query] $postProgress [http::data $t]
} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
-test http-3.11 {http::geturl querychannel with -command} {
+test http-3.11 {http::geturl querychannel with -command} {network} {
set query foo=bar
set sep ""
set i 0
@@ -298,26 +298,26 @@
expr {[llength [file channels]] == $chanCount}
} 1
-test http-4.1 {http::Event} {
+test http-4.1 {http::Event} {network} {
set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
-test http-4.2 {http::Event} {
+test http-4.2 {http::Event} {network} {
set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
-test http-4.3 {http::Event} {
+test http-4.3 {http::Event} {network} {
set token [http::geturl $url]
http::code $token
} {HTTP/1.0 200 Data follows}
-test http-4.4 {http::Event} {
+test http-4.4 {http::Event} {network} {
set out [open testfile w]
set token [http::geturl $url -channel $out]
close $out
@@ -331,7 +331,7 @@
<h2>GET $tail</h2>
</body></html>"
-test http-4.5 {http::Event} {
+test http-4.5 {http::Event} {network} {
set out [open testfile w]
set token [http::geturl $url -channel $out]
close $out
@@ -340,7 +340,7 @@
expr $data(currentsize) == $data(totalsize)
} 1
-test http-4.6 {http::Event} {
+test http-4.6 {http::Event} {network} {
set out [open testfile w]
set token [http::geturl $binurl -channel $out]
close $out
@@ -367,19 +367,19 @@
set progress
} {111 111}
}
-test http-4.7 {http::Event} {
+test http-4.7 {http::Event} {network} {
set token [http::geturl $url -progress myProgress]
set progress
} {111 111}
-test http-4.8 {http::Event} {
+test http-4.8 {http::Event} {network} {
set token [http::geturl $url]
http::status $token
} {ok}
-test http-4.9 {http::Event} {
+test http-4.9 {http::Event} {network} {
set token [http::geturl $url -progress myProgress]
http::code $token
} {HTTP/1.0 200 Data follows}
-test http-4.10 {http::Event} {
+test http-4.10 {http::Event} {network} {
set token [http::geturl $url -progress myProgress]
http::size $token
} {111}
@@ -389,7 +389,7 @@
# Short timeout to working server (the test server)
# This lets us try a reset during the connection
-test http-4.11 {http::Event} {
+test http-4.11 {http::Event} {network} {
set token [http::geturl $url -timeout 1 -command {#}]
http::reset $token
http::status $token
@@ -397,7 +397,7 @@
# Longer timeout with reset
-test http-4.12 {http::Event} {
+test http-4.12 {http::Event} {network} {
set token [http::geturl $url/?timeout=10 -command {#}]
http::reset $token
http::status $token
@@ -406,7 +406,7 @@
# Medium timeout to working server that waits even longer
# The timeout hits while waiting for a reply
-test http-4.13 {http::Event} {
+test http-4.13 {http::Event} {network} {
set token [http::geturl $url?timeout=30 -timeout 10 -command {#}]
http::wait $token
http::status $token
@@ -415,7 +415,7 @@
# Longer timeout to good host, bad port, gets an error
# after the connection "completes" but the socket is bad
-test http-4.14 {http::Event} {
+test http-4.14 {http::Event} {network} {
set code [catch {
set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]
if {[string length $token] == 0} {
@@ -452,7 +452,7 @@
http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
-test http-6.1 {http::ProxyRequired} {
+test http-6.1 {http::ProxyRequired} {network} {
http::config -proxyhost [info hostname] -proxyport $port
set token [http::geturl $url]
http::wait $token
Index: tests/httpold.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/httpold.test,v
retrieving revision 1.8
diff -u -r1.8 httpold.test
--- tests/httpold.test 2000/04/10 17:18:59 1.8
+++ tests/httpold.test 2001/08/24 21:49:53
@@ -87,7 +87,7 @@
} {Unsupported URL: http:junk}
set url [info hostname]:$port
-test http-3.3 {http_get} {
+test http-3.3 {http_get} {network} {
set token [http_get $url]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -99,7 +99,7 @@
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary
-test http-3.4 {http_get} {
+test http-3.4 {http_get} {network} {
set token [http_get $url]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -111,7 +111,7 @@
global port
return [list [info hostname] $port]
}
-test http-3.5 {http_get} {
+test http-3.5 {http_get} {network} {
http_config -proxyfilter selfproxy
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
@@ -121,7 +121,7 @@
<h2>GET http://$url</h2>
</body></html>"
-test http-3.6 {http_get} {
+test http-3.6 {http_get} {network} {
http_config -proxyfilter bogus
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
@@ -131,7 +131,7 @@
<h2>GET $tail</h2>
</body></html>"
-test http-3.7 {http_get} {
+test http-3.7 {http_get} {network} {
set token [http_get $url -headers {Pragma no-cache}]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -139,7 +139,7 @@
<h2>GET $tail</h2>
</body></html>"
-test http-3.8 {http_get} {
+test http-3.8 {http_get} {network} {
set token [http_get $url -query Name=Value&Foo=Bar]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
@@ -152,32 +152,32 @@
</dl>
</body></html>"
-test http-3.9 {http_get} {
+test http-3.9 {http_get} {network} {
set token [http_get $url -validate 1]
http_code $token
} "HTTP/1.0 200 OK"
-test http-4.1 {httpEvent} {
+test http-4.1 {httpEvent} {network} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
-test http-4.2 {httpEvent} {
+test http-4.2 {httpEvent} {network} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
-test http-4.3 {httpEvent} {
+test http-4.3 {httpEvent} {network} {
set token [http_get $url]
http_code $token
} {HTTP/1.0 200 Data follows}
-test http-4.4 {httpEvent} {
+test http-4.4 {httpEvent} {network} {
set out [open testfile w]
set token [http_get $url -channel $out]
close $out
@@ -191,7 +191,7 @@
<h2>GET $tail</h2>
</body></html>"
-test http-4.5 {httpEvent} {
+test http-4.5 {httpEvent} {network} {
set out [open testfile w]
set token [http_get $url -channel $out]
close $out
@@ -200,7 +200,7 @@
expr $data(currentsize) == $data(totalsize)
} 1
-test http-4.6 {httpEvent} {
+test http-4.6 {httpEvent} {network} {
set out [open testfile w]
set token [http_get $binurl -channel $out]
close $out
@@ -227,28 +227,28 @@
set progress
} {111 111}
}
-test http-4.7 {httpEvent} {
+test http-4.7 {httpEvent} {network} {
set token [http_get $url -progress myProgress]
set progress
} {111 111}
-test http-4.8 {httpEvent} {
+test http-4.8 {httpEvent} {network} {
set token [http_get $url]
http_status $token
} {ok}
-test http-4.9 {httpEvent} {
+test http-4.9 {httpEvent} {network} {
set token [http_get $url -progress myProgress]
http_code $token
} {HTTP/1.0 200 Data follows}
-test http-4.10 {httpEvent} {
+test http-4.10 {httpEvent} {network} {
set token [http_get $url -progress myProgress]
http_size $token
} {111}
-test http-4.11 {httpEvent} {
+test http-4.11 {httpEvent} {network} {
set token [http_get $url -timeout 1 -command {#}]
http_reset $token
http_status $token
} {reset}
-test http-4.12 {httpEvent} {
+test http-4.12 {httpEvent} {network} {
update
set x {}
after 500 {lappend x ok}
@@ -269,7 +269,7 @@
http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
-test http-6.1 {httpProxyRequired} {
+test http-6.1 {httpProxyRequired} {network} {
update
http_config -proxyhost [info hostname] -proxyport $port
set token [http_get $url]
Index: tests/io.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/io.test,v
retrieving revision 1.20
diff -u -r1.20 io.test
--- tests/io.test 2001/07/31 19:12:07 1.20
+++ tests/io.test 2001/08/24 21:49:53
@@ -2627,7 +2627,7 @@
close $f
set r
} "hello\nbye\nstrange\n"
-test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
+test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket network tempNotMac} {
set c 0
set x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
@@ -2663,7 +2663,7 @@
vwait x
set c
} 2000
-test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac} {
+test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket network tempNotMac} {
# On Mac, this test screws up sockets such that subsequent tests using port 2828
# either cause errors or panic().
@@ -6222,7 +6222,7 @@
{first after update}]
} 0
-test io-51.1 {Test old socket deletion on Macintosh} {socket} {
+test io-51.1 {Test old socket deletion on Macintosh} {socket network} {
set x 0
set result ""
proc accept {s a p} {
@@ -6610,7 +6610,7 @@
set fcopyTestDone ;# 0 for plain end of file
} {0}
-test io-54.1 {Recursive channel events} {socket} {
+test io-54.1 {Recursive channel events} {socket network} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
Index: tests/socket.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/socket.test,v
retrieving revision 1.16
diff -u -r1.16 socket.test
--- tests/socket.test 2000/09/21 00:58:30 1.16
+++ tests/socket.test 2001/08/24 21:49:53
@@ -346,7 +346,7 @@
close $f
set x
} {ready {hello 127.0.0.1}}
-test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
+test socket-2.4 {tcp connection with server interface specified} {socket network stdio} {
removeFile script
set f [open script w]
puts $f {
@@ -515,7 +515,7 @@
while executing
"socket -server accept 2828"
(file "script" line 1)}}
-test socket-2.10 {close on accept, accepted socket lives} {socket} {
+test socket-2.10 {close on accept, accepted socket lives} {socket network} {
set done 0
set timer [after 20000 "set done timed_out"]
set ss [socket -server accept 2830]
@@ -826,7 +826,7 @@
update
llength $l
} 12
-test socket-7.4 {testing socket specific options} {socket} {
+test socket-7.4 {testing socket specific options} {socket network} {
set s [socket -server accept 2823]
proc accept {s a p} {
global x
@@ -859,7 +859,7 @@
lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 2829 3}
-test socket-8.1 {testing -async flag on sockets} {socket} {
+test socket-8.1 {testing -async flag on sockets} {socket network} {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does,
# check that you have these patches installed (using showrev -p):
#
@@ -889,7 +889,7 @@
set z
} bye
-test socket-9.1 {testing spurious events} {socket} {
+test socket-9.1 {testing spurious events} {socket network} {
set len 0
set spurious 0
set done 0
@@ -921,7 +921,7 @@
close $s
list $spurious $len
} {0 50}
-test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
+test socket-9.2 {testing async write, fileevents, flush on close} {socket network} {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
set secondblock ""
@@ -969,7 +969,7 @@
close $l
set count
} 65566
-test socket-9.3 {testing EOF stickyness} {socket} {
+test socket-9.3 {testing EOF stickyness} {socket network} {
proc count_to_eof {s} {
global count done timer
set l [gets $s]
