TclTLS
Check-in [79208b498d]
Login
HomeTimelineDownloadBrowse SourceBranchesTagsTicketsWiki
Overview
Comment:Add remote server for tls testing.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 79208b498d3993924b2f2465b91e70f96d0a06eb
User & Date: awb on 2000-06-03 00:20:02
Other Links: manifest | tags
Context
2000-06-03
02:30
*** empty log message *** check-in: 4bf039c9a5 user: awb tags: trunk
00:20
Add remote server for tls testing. check-in: 79208b498d user: awb tags: trunk
2000-06-02
22:26
Fix some more tests. check-in: f1e28695f2 user: awb tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added tests/remote.tcl version [b409bf0b71]. 






















































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
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
170
171
172
173
174
175
176
177
178
179
180

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# This file contains Tcl code to implement a remote server that can be
# used during testing of Tcl socket code. This server is used by some
# of the tests in socket.test.
#
# Source this file in the remote server you are using to test Tcl against.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: remote.tcl,v 1.1 2000/06/03 00:20:02 awb Exp $

# load tls package
package require tls

# Initialize message delimitor

# Initialize command array
catch {unset command}
set command(0) ""
set callerSocket ""

# Detect whether we should print out connection messages etc.
set VERBOSE 1
if {![info exists VERBOSE]} {
    set VERBOSE 0
}

proc __doCommands__ {l s} {
    global callerSocket VERBOSE

    if {$VERBOSE} {
	puts "--- Server executing the following for socket $s:"
	puts $l
	puts "---"
    }
    set callerSocket $s
    if {[catch {uplevel #0 $l} msg]} {
	list error $msg
    } else {
	list success $msg
    }
}

proc __readAndExecute__ {s} {
    global command VERBOSE

    set l [gets $s]
    if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
	if {[info exists command($s)]} {
	    puts $s [list error incomplete_command]
	}
	puts $s "--Marker--Marker--Marker--"
	return
    }
    if {[string compare $l ""] == 0} {
	if {[eof $s]} {
	    if {$VERBOSE} {
		puts "Server closing $s, eof from client"
	    }
	    close $s
	}
	return
    }
    append command($s) $l "\n"
    if {[info complete $command($s)]} {
	set cmds $command($s)
	unset command($s)
	puts $s [__doCommands__ $cmds $s]
    }
    if {[eof $s]} {
	if {$VERBOSE} {
	    puts "Server closing $s, eof from client"
	}
	close $s
    }
}

proc __accept__ {s a p} {
    global VERBOSE

    if {$VERBOSE} {
	puts "Server accepts new connection from $a:$p on $s"
    }
    fileevent $s readable [list __readAndExecute__ $s]
    fconfigure $s -buffering line -translation crlf
}

set serverIsSilent 0
for {set i 0} {$i < $argc} {incr i} {
    if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
	set serverIsSilent 1
	break
    }
}
if {![info exists serverPort]} {
    if {[info exists env(serverPort)]} {
	set serverPort $env(serverPort)
    }
}
if {![info exists serverPort]} {
    for {set i 0} {$i < $argc} {incr i} {
	if {[string compare -port [lindex $argv $i]] == 0} {
	    if {$i < [expr $argc - 1]} {
		set serverPort [lindex $argv [expr $i + 1]]
	    }
	    break
	}
    }
}
if {![info exists serverPort]} {
    set serverPort 2048
}

if {![info exists serverAddress]} {
    if {[info exists env(serverAddress)]} {
	set serverAddress $env(serverAddress)
    }
}
if {![info exists serverAddress]} {
    for {set i 0} {$i < $argc} {incr i} {
	if {[string compare -address [lindex $argv $i]] == 0} {
	    if {$i < [expr $argc - 1]} {
		set serverAddress [lindex $argv [expr $i + 1]]
	    }
	    break
	}
    }
}
if {![info exists serverAddress]} {
    set serverAddress 0.0.0.0
}

if {$serverIsSilent == 0} {
    set l "Remote server listening on port $serverPort, IP $serverAddress."
    puts ""
    puts $l
    for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
    puts ""
    puts ""
    puts "You have set the Tcl variables serverAddress to $serverAddress and"
    puts "serverPort to $serverPort. You can set these with the -address and"
    puts "-port command line options, or as environment variables in your"
    puts "shell."
    puts ""
    puts "NOTE: The tests will not work properly if serverAddress is set to"
    puts "\"localhost\" or 127.0.0.1."
    puts ""
    puts "When you invoke tcltest to run the tests, set the variables"
    puts "remoteServerPort to $serverPort and remoteServerIP to"
    puts "[info hostname]. You can set these as environment variables"
    puts "from the shell. The tests will not work properly if you set"
    puts "remoteServerIP to \"localhost\" or 127.0.0.1."
    puts ""
    puts -nonewline "Type Ctrl-C to terminate--> "
    flush stdout
}

if {[catch {set serverSocket \
    [tls::socket -myaddr $serverAddress -server __accept__ \
    	-cafile [file join [pwd] certs cacert.pem] \
    	-certfile [file join [pwd] certs server.pem] \
    	-keyfile [file join [pwd] certs skey.pem] \
	$serverPort]} msg]} {
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
    vwait __server_wait_variable__
}



















Modified tests/tlsIo.test
from [0c7ac98f84]
to [5049a14c6a].



1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20













-
+








# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# 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.6 2000/06/02 22:26:12 awb Exp $
# RCS: @(#) $Id: tlsIo.test,v 1.7 2000/06/03 00:20:02 awb Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You




︙


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

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
170








-
-
+
+
+
+














-
+
+
+















+








# 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 $remoteServerIP \
						$remoteServerPort]}] != 0} {
    if {[catch {set commandSocket [tls::socket \
	    -certfile $clientCert -cafile $caCert -keyfile $clientKey \
	    $remoteServerIP \
	    $remoteServerPort]}] != 0} {
	if {[info commands exec] == ""} {
	    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 \
					-serverIsSilent \
					-port $remoteServerPort \
					-address $remoteServerIP]" \
					w+]} \
		   msg] == 0} {
		after 1000
		if {[catch {set commandSocket [tls::socket $remoteServerIP \
		if {[catch {set commandSocket [tls::socket \
		    -certfile $clientCert -cafile $caCert -keyfile $clientKey \
				$remoteServerIP \
				$remoteServerPort]} msg] == 0} {
		    fconfigure $commandSocket -translation crlf -buffering line
		} else {
		    set noRemoteTestReason $msg
		    set doTestsWithRemoteServer 0
		}
	    } else {
		set noRemoteTestReason "$msg $::tcltest::tcltest"
		set doTestsWithRemoteServer 0
	    }
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}
puts stdout "commandSocket: $commandSocket"

# Some tests are run only if we are doing testing against a remote server.
set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer
if {$doTestsWithRemoteServer == 0} {
    if {[string first s $::tcltest::verbose] != -1} {
    	puts "Skipping tests with remote server. See tests/socket.test for"
	puts "information on how to run remote server."




︙


187
188
189
190
191
192
193
194

195
196
197
198
199
200
201

192
193
194
195
196
197
198

199
200
201
202
203
204
205
206








-
+








	    error "remote server disappeared: $msg"
	}

	set resp ""
	while {1} {
	    set line [gets $commandSocket]
	    if {[eof $commandSocket]} {
		error "remote server disappaered"
		error "remote server disappeared"
	    }
	    if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
		if {[string compare [lindex $resp 0] error] == 0} {
		    error [lindex $resp 1]
		} else {
		    return [lindex $resp 1]
		}




︙


565
566
567
568
569
570
571
572

573
574
575


576
577
578
579
580
581
582
583
584
585
586
587

588

589
590

591
592
593
594

595

596
597
598





599
600
601


602
603


604
605
606
607
608
609
610

570
571
572
573
574
575
576

577
578
579

580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

595

596
597
598
599
600
601
602

603
604
605
606
607
608
609
610
611
612
613

614
615
616

617
618
619
620
621
622
623
624
625








-
+


-
+
+












+
-
+
-

+




+
-
+



+
+
+
+
+


-
+
+

-
+
+








    invoked from within
"eval ::socket $sopts"
    (procedure "tls::socket" line 62)
    invoked from within
"tls::socket -server accept 2828"
    (file "script" line 1)}}

test socket-2.10 {close on accept, accepted socket lives} {socket pcCrash} {
test socket-2.10 {close on accept, accepted socket lives} {socket knownBug} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [tls::socket -server accept 2830]
    set ss [tls::socket -server accept -certfile $serverCert -cafile $caCert \
	-keyfile $serverKey 2830]
    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 [tls::socket -certfile $clientCert -cafile $caCert \
    set cs [tls::socket [info hostname] 2830]
	-keyfile $clientKey [info hostname] 2830]
    puts $cs hello
    close $cs

    vwait done
    after cancel $timer
    set done
} 1

test socket-2.11 {detecting new data} {socket pcCrash} {
test socket-2.11 {detecting new data} {socket knownBug} {
    proc accept {s a p} {
	global sock
	set sock $s
	set f [open awb.log w]
	puts $f [catch {tls::handshake $sock} err]
	puts $f "err: $err"
	puts $f "[tls::status $sock]"
	close $s
    }

    set s [tls::socket -server accept 2400]
    set s [tls::socket -require 0 -request 0 -server accept -certfile $serverCert -cafile $caCert \
	-keyfile $serverKey 2400]
    set sock ""
    set s2 [tls::socket 127.0.0.1 2400]
    set s2 [tls::socket -certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 2400]
    vwait sock
    puts $s2 one
    flush $s2
    after 500
    fconfigure $sock -blocking 0
    set result [gets $sock]
    lappend result [gets $sock]




︙


1120
1121
1122
1123
1124
1125
1126
1127





1128
1129

1130
1131
1132
1133



1134
1135
1136
1137
1138

1139
1140
1141
1142
1143
1144
1145
1146





1147
1148
1149
1150
1151


1152

1153
1154
1155
1156
1157
1158
1159

1135
1136
1137
1138
1139
1140
1141

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152

1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168

1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180

1181
1182
1183
1184
1185
1186
1187
1188








-
+
+
+
+
+


+



-
+
+
+





+







-
+
+
+
+
+





+
+
-
+








    close $s
    close $c
    set goterror
} 1

test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
    sendCommand {
	set socket9_1_test_server [tls::socket -server accept 2834]
	set socket9_1_test_server [tls::socket -server accept \
		-certfile [file join [pwd] certs server.pem] \
		-cafile [file join [pwd] certs caFile.pem] \
		-keyfile [file join [pwd] certs skey.pem] \
		2834]
	proc accept {s a p} {
	    puts $s done
	    tls::handshake $s
	    close $s
	}
    }
    set s [tls::socket $remoteServerIP 2834]
    set s [tls::socket \
	    -certfile $clientCert -cafile $caCert -keyfile $clientKey \
	    $remoteServerIP 2834]
    set r [gets $s]
    close $s
    sendCommand {close $socket9_1_test_server}
    set r
} done

test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} {
    if {[info exists port]} {
	incr port
    } else {
	set port [expr 2048 + [pid]%1024]
    }
    sendCommand {
	set socket9_2_test_server [tls::socket -server accept 2835]
	set socket9_2_test_server [tls::socket -server accept \
		-certfile [file join [pwd] certs server.pem] \
		-cafile [file join [pwd] certs caFile.pem] \
		-keyfile [file join [pwd] certs skey.pem] \
	    2835]
	proc accept {s a p} {
	    puts $s $p
	    close $s
	}
    }
    set s [tls::socket \
	    -certfile $clientCert -cafile $caCert -keyfile $clientKey \
    set s [tls::socket -myport $port $remoteServerIP 2835]
	    -myport $port $remoteServerIP 2835]
    set r [gets $s]
    close $s
    sendCommand {close $socket9_2_test_server}
    if {$r == $port} {
	set result ok
    } else {
	set result broken




︙
















Powered by Fossil · RSS