| ︙ | | |
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
-
-
+
+
|
set caCert [file join $certsDir ca.pem]
set serverKey [file join $certsDir server.key]
set clientKey [file join $certsDir client.key]
# Some tests require the testthread and exec commands
set ::tcltest::testConstraints(testthread) \
[expr {[info commands testthread] != {}}]
set ::tcltest::testConstraints(exec) [expr {[info commands exec] != {}}]
[expr {[info commands testthread] ne {}}]
set ::tcltest::testConstraints(exec) [expr {[info commands exec] ne {}}]
#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#
if {![info exists remoteServerIP]} {
|
| ︙ | | |
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
-
+
-
+
-
+
|
set ::do_handshake "eof"
} elseif {[catch {tls::handshake $s} result]} {
# Some errors are normal.
dputs "handshake: $result"
} elseif {$result == 1} {
# Handshake complete
if {[llength $args]} { eval [list fconfigure $s] $args }
if {$cmd == ""} {
if {$cmd eq ""} {
fileevent $s $type ""
} else {
fileevent $s $type "$cmd [list $s]"
}
dputs "handshake: complete"
set ::do_handshake "complete"
} else {
dputs "handshake: in progress"
}
}
#
# Check if we're supposed to do tests against the remote server
#
set doTestsWithRemoteServer 1
if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} {
if {![info exists remoteServerIP] && ($tcl_platform(platform) ne "macintosh")} {
set remoteServerIP 127.0.0.1
}
if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
set remoteServerPort $tlsServerPort
}
# Attempt to connect to a remote server if one is already running. If it
# is not running or for some other reason the connect fails, attempt to
# start the remote server on the local host listening on port 8048. This
# is only done on platforms that support exec (i.e. not on the Mac). On
# platforms that do not support exec, the remote server must be started
# by the user before running the tests.
set remoteProcChan ""
set commandSocket ""
if {$doTestsWithRemoteServer} {
catch {close $commandSocket}
if {[catch {set commandSocket [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
$remoteServerIP $remoteServerPort]}] != 0} {
if {[info commands exec] == ""} {
if {[info commands exec] eq ""} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
} else {
set remoteServerIP 127.0.0.1
set remoteFile [file join [pwd] remote.tcl]
if {[catch {set remoteProcChan \
[open "|[list $::tcltest::tcltest $remoteFile \
|
| ︙ | | |
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
-
-
+
+
|
set resp ""
while {1} {
set line [gets $commandSocket]
if {[eof $commandSocket]} {
error "remote server disappeared"
}
if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
if {[string compare [lindex $resp 0] error] == 0} {
if {$line eq "--Marker--Marker--Marker--"} {
if {[lindex $resp 0] eq "error"} {
error [lindex $resp 1]
} else {
return [lindex $resp 1]
}
} else {
append resp $line "\n"
}
|
| ︙ | | |
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
|
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
|
-
+
-
+
|
}
set f [tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
$remoteServerIP 8836]
fconfigure $f -translation crlf -buffering line
for {set cnt 0} {$cnt < 50} {incr cnt} {
puts $f "hello, $cnt"
if {[string compare [gets $f] "hello, $cnt"] != 0} {
if {[gets $f] ne "hello, $cnt"} {
break
}
}
close $f
sendCommand {close $socket10_7_test_server}
set cnt
} 50
# Macintosh sockets can have more than one server per port
if {$tcl_platform(platform) == "macintosh"} {
if {$tcl_platform(platform) eq "macintosh"} {
set conflictResult {0 8836}
} else {
set conflictResult {1 {couldn't open socket: address already in use}}
}
test tlsIO-11.6 {socket conflict} {socket doTestsWithRemoteServer} {
set s1 [tls::socket \
|
| ︙ | | |
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
|
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
|
-
+
|
# 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 {$data ne {}} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
if {$failed} {
set x "$type socket was inherited"
} else {
set x "$type socket was not inherited"
}
|
| ︙ | | |