@@ -8,11 +8,11 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tlsIO.test,v 1.18 2001/06/21 20:45:43 hobbs Exp $ +# RCS: @(#) $Id: tlsIO.test,v 1.19 2002/02/04 22:45:11 hobbs Exp $ # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to @@ -67,12 +67,13 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +# The build dir is added as the first element of $PATH +set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] # Load the tls package - package require tls 1.4 set tlsServerPort 8048 # Specify where the certificates are @@ -118,15 +119,15 @@ } elseif {[catch {tls::handshake $s} result]} { # Some errors are normal. dputs "handshake: $result" } elseif {$result == 1} { # Handshake complete - if {[llength $args]} { eval fconfigure $s $args } + if {[llength $args]} { eval [list fconfigure $s] $args } if {$cmd == ""} { fileevent $s $type "" } else { - fileevent $s $type "$cmd $s" + fileevent $s $type "$cmd [list $s]" } dputs "handshake: complete" set ::do_handshake "complete" } else { dputs "handshake: in progress" @@ -302,11 +303,12 @@ test tlsIO-2.1 {tcp connection} {socket stdio} { removeFile script set f [open script w] puts $f { - package require tls + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls set timer [after 2000 "set x timed_out"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" puts $f { proc accept {file addr port} { @@ -343,10 +345,11 @@ test tlsIO-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]" puts $f { @@ -382,10 +385,11 @@ test tlsIO-2.3 {tcp connection with client interface specified} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]" puts $f { @@ -419,10 +423,11 @@ test tlsIO-2.4 {tcp connection with server interface specified} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]" puts $f { @@ -455,10 +460,11 @@ test tlsIO-2.5 {tcp connection with redundant server port} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]" puts $f { @@ -501,10 +507,11 @@ test tlsIO-2.7 {echo server, one line} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834 \]" puts $f { @@ -544,10 +551,11 @@ } {{hello abcdefghijklmnop} done} test tlsIO-2.8 {echo server, loop 50 times, single connection} {socket stdio} { set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835 \]" puts $f { proc accept {s a p} { @@ -594,11 +602,15 @@ test tlsIO-2.9 {socket conflict} {socket stdio} { set s [tls::socket -server accept 8828] removeFile script set f [open script w] - puts -nonewline $f {package require tls; tls::socket -server accept 8828} + puts -nonewline $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls + tls::socket -server accept 8828 + } close $f set f [open "|[list $::tcltest::tcltest script]" r] gets $f after 100 set x [list [catch {close $f} msg] [string range $msg 0 43]] @@ -678,11 +690,12 @@ # There is a debug assertion on Windows/SSL that causes a crash when the # certificate isn't specified. removeFile script set f [open script w] puts $f { - package require tls + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls set timer [after 2000 "set x timed_out"] set f [tls::socket -server accept 8828] proc accept {file addr port} { global x set x done @@ -710,11 +723,12 @@ test tlsIO-3.1 {socket conflict} {socket stdio} { removeFile script set f [open script w] puts $f { - package require tls + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]" puts $f { puts ready gets stdin @@ -734,11 +748,12 @@ test tlsIO-3.2 {server with several clients} {socket stdio} { removeFile script set f [open script w] puts $f { - package require tls + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] set counter 0 } @@ -802,11 +817,12 @@ test tlsIO-4.1 {server with several clients} {socket stdio} { # have seen intermittent hangs on Windows removeFile script set f [open script w] puts $f { - package require tls + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls gets stdin } puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]" puts $f { fconfigure $s -buffering line @@ -909,10 +925,11 @@ # There is a debug assertion on Windows/SSL that causes a crash when the # certificate isn't specified. removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls gets stdin } puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848] close $f @@ -936,10 +953,11 @@ test tlsIO-7.1 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls } puts $f [list tls::socket -server accept \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820] puts $f { @@ -969,10 +987,11 @@ test tlsIO-7.2 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls } puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821" puts $f { proc accept args { @@ -1001,15 +1020,17 @@ test tlsIO-7.3 {testing socket specific options} {socket} { set s [tls::socket \ -certfile $serverCert -cafile $caCert -keyfile $serverKey \ -server accept 8822] - set l [fconfigure $s] + set l [llength [fconfigure $s]] close $s update - llength $l -} 12 + # A bug fixed in fconfigure for 8.3.4+ make this return 14 normally, + # but 12 in older versions. + expr {$l >= 12 && (($l % 2) == 0)} +} 1 # bug report #5812 fconfigure doesn't return value for '-sockname' test tlsIO-7.4 {testing socket specific options} {socket} { set s [tls::socket \ @@ -1272,11 +1293,11 @@ test tlsIO-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { if {[info exists port]} { incr port } else { - set port [expr $tlsServerPort + [pid]%1024] + set port [expr {$tlsServerPort + [pid]%1024}] } sendCertValues sendCommand { set socket9_2_test_server [tls::socket -server accept \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835] @@ -1692,10 +1713,34 @@ vwait done after cancel $timer sendCommand {close $l} set count } 65566 + +proc getdata {type file} { + # Read handler on the accepted socket. + global x + global failed + set status [catch {read $file} data] + if {$status != 0} { + set x "read failed, error was $data" + catch { close $file } + } elseif {[string compare {} $data]} { + } elseif {[fblocked $file]} { + } elseif {[eof $file]} { + if {$failed} { + set x "$type socket was inherited" + } else { + set x "$type socket was not inherited" + } + catch { close $file } + } else { + set x {impossible case} + catch { close $file } + } + return +} test tlsIO-12.1 {testing inheritance of server sockets} {socket exec} { makeFile {} script1 makeFile {} script2 @@ -1713,11 +1758,14 @@ # waits a second, and exits. The server socket will now # be closed unless script1 inherited it. set f [open script2 w] puts $f [list set tclsh $::tcltest::tcltest] - puts $f {package require tls} + puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls + } puts $f "set f \[tls::socket -server accept \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828\]" puts $f { proc accept { file addr port } { close $file @@ -1767,11 +1815,14 @@ # launches script1 and exits. If the child process inherited the # client socket, the socket will still be open. set f [open script2 w] puts $f [list set tclsh $::tcltest::tcltest] - puts $f {package require tls} + puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls + } puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert \ -keyfile $clientKey 127.0.0.1 8829\]" puts $f { exec $tclsh script1 & puts $f testing @@ -1789,35 +1840,12 @@ proc accept { file host port } { # When the client connects, establish the read handler global server close $server fconfigure $file -blocking 0 - fileevent $file readable [list do_handshake $file readable getdata \ - -buffering line] - return - } - proc getdata { file } { - # Read handler on the accepted socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x {client socket was inherited} - } else { - set x {client socket was not inherited} - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } + fileevent $file readable [list do_handshake $file readable \ + [list getdata client] -buffering line] return } # If the socket doesn't hit end-of-file in 5 seconds, the # script1 process must have inherited the client. @@ -1848,11 +1876,14 @@ } close $f set f [open script2 w] puts $f [list set tclsh $::tcltest::tcltest] - puts $f {package require tls} + puts $f { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] + package require tls + } puts $f "set f \[tls::socket -server accept \ -certfile $serverCert -cafile $caCert -keyfile $serverKey 8930\]" puts $f { proc accept { file host port } { global tclsh @@ -1878,42 +1909,18 @@ 127.0.0.1 8930] fconfigure $f -buffering full -blocking 0 # We need to put a byte into the read queue, otherwise the # TLS handshake doesn't finish puts $f a; flush $f - fileevent $f readable [list getdata $f] + fileevent $f readable [list getdata accepted $f] # If the socket is still open after 5 seconds, the script1 process # must have inherited the accepted socket. set failed 0 after 5000 set failed 1 - proc getdata { file } { - # Read handler on the client socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x "read failed, error was $data" - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x {accepted socket was inherited} - } else { - set x {accepted socket was not inherited} - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } - return - } - vwait x set x } {accepted socket was not inherited} test tlsIO-13.1 {Testing use of shared socket between two threads} \ @@ -1921,10 +1928,11 @@ # HOBBS: never tested removeFile script threadReap makeFile { + set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] package require tls set f [tls::socket -server accept 8828] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line