1#!perl -w
2# Before `make install' is performed this script should be runnable with
3# `make test'. After `make install' it should work as `perl t/core.t'
4
5
6use Net::SSLeay;
7use Socket;
8use IO::Socket::SSL;
9use Errno 'EAGAIN';
10eval {require "t/ssl_settings.req";} ||
11eval {require "ssl_settings.req";};
12
13$GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS = eval "use 5.006; use IO::Select; return 1";
14$GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS = 0 if $^O =~m{mswin32}i;
15$NET_SSLEAY_VERSION = $Net::SSLeay::VERSION;
16$OPENSSL_VERSION = 0;
17$OPENSSL_VERSION = &Net::SSLeay::OPENSSL_VERSION_NUMBER if ($NET_SSLEAY_VERSION>=1.19);
18$CAN_PEEK = ($OPENSSL_VERSION >= 0x0090601f) ? 1 : 0;
19
20$numtests = 36;
21$|=1;
22
23foreach ($^O) {
24	if (/MacOS/ or /VOS/ or /vmesa/ or /riscos/ or /amigaos/) {
25		print "1..0 # Skipped: fork not implemented on this platform\n";
26		exit;
27	}
28}
29
30if ($GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS) {
31	$numtests+=5;
32	$numtests+=4 if ($NET_SSLEAY_VERSION>=1.16)
33}
34
35if ($NET_SSLEAY_VERSION>=1.16) {
36	$numtests+=4;
37}
38
39#We can only test SSL_peek if OpenSSL is v0.9.6a or better
40if ($CAN_PEEK) {
41	$numtests+=3;
42}
43
44print "1..$numtests\n";
45
46%extra_options = ($Net::SSLeay::VERSION>=1.16) ?
47	(SSL_key_file => "certs/client-key.enc", SSL_passwd_cb => sub { return "opossum" }) :
48	(SSL_key_file => "certs/client-key.pem");
49
50
51my $server = IO::Socket::SSL->new(
52	LocalAddr => $SSL_SERVER_ADDR,
53	Listen => 2,
54	Timeout => 30,
55	ReuseAddr => 1,
56	SSL_verify_mode => 0x00,
57	SSL_ca_file => "certs/test-ca.pem",
58	SSL_use_cert => 1,
59	SSL_cert_file => "certs/client-cert.pem",
60	SSL_version => 'TLSv1',
61	SSL_cipher_list => 'HIGH',
62	SSL_error_trap => \&error_trap,
63	%extra_options
64);
65
66if (!$server) {
67	print "not ok\n";
68	exit;
69}
70&ok("Server Initialization");
71
72print "not " if (!defined fileno($server));
73&ok("Server Fileno Check");
74
75my ($SSL_SERVER_PORT) = unpack_sockaddr_in( $server->sockname );
76
77
78
79unless (fork) {
80	close $server;
81	%extra_options = ($Net::SSLeay::VERSION>=1.16) ?
82		(SSL_key_file => "certs/server-key.enc", SSL_passwd_cb => sub { return "bluebell" },
83		 SSL_verify_callback => \&verify_sub) :
84		(SSL_key_file => "certs/server-key.pem");
85
86
87	my $client = new IO::Socket::INET(PeerAddr => $SSL_SERVER_ADDR,
88									  PeerPort => $SSL_SERVER_PORT);
89
90	print $client "Test\n";
91	(<$client> eq "This server is SSL only") || print "not ";
92	&ok("Client non-SSL connection");
93	close $client;
94
95	$client = new IO::Socket::SSL(PeerAddr => $SSL_SERVER_ADDR,
96								  PeerPort => $SSL_SERVER_PORT,
97								  SSL_verify_mode => 0x01,
98								  SSL_ca_file => "certs/test-ca.pem",
99								  SSL_use_cert => 1,
100								  SSL_cert_file => "certs/server-cert.pem",
101								  SSL_version => 'TLSv1',
102								  SSL_cipher_list => 'HIGH',
103								  %extra_options);
104	
105	
106	sub verify_sub {
107		my ($ok, $ctx_store, $cert, $error) = @_;
108		unless ($ok && $ctx_store && $cert && !$error) 
109		{ print("not ok #client failure\n") && exit; }
110		($cert =~ /IO::Socket::SSL Demo CA/) || print "not";
111		&ok("Client Verify-sub Check");
112		return 1;
113	}
114
115
116	$client || (print("not ok #client failure\n") && exit);
117	&ok("Client Initialization");
118
119	$client->fileno() || print "not ";
120	&ok("Client Fileno Check");
121
122#    $client->untaint() if ($HAVE_SCALAR_UTIL);  # In the future...
123
124	$client->dump_peer_certificate() || print "not ";
125	&ok("Client Peer Certificate Check");
126
127	$client->peer_certificate("issuer") || print "not ";
128	&ok("Client Peer Certificate Issuer Check");
129
130	$client->get_cipher() || print "not ";
131	&ok("Client Cipher Check");
132
133	$client->syswrite('00waaaanf00', 7, 2);
134
135	if ($CAN_PEEK) {
136		my $buffer;
137		$client->read($buffer,2);
138		print "not " if ($buffer ne 'ok');
139		&ok("Client Peek Check");
140	}
141
142	$client->print("Test\n");
143	$client->printf("\$%.2f\n%d\n%c\n%s", 1.0444442342, 4.0, ord("y"), "Test\nBeaver\nBeaver\n");
144	shutdown($client, 1);
145
146	my $buffer="\0\0aaaaaaaaaaaaaaaaaaaa";
147	$client->sysread($buffer, 7, 2);
148	print "not " if ($buffer ne "\0\0waaaanf");
149	&ok("Client Sysread Check");
150
151
152## The future...
153#    if ($HAVE_SCALAR_UTIL) {
154#       print "not " if (is_tainted($buffer));
155#       &ok("client");
156#    }
157
158	my @array = $client->getline();
159	print "not "  if (@array != 1 or $array[0] ne "Test\n");
160	&ok("Client Getline Check");
161
162	print "not " if ($client->getc ne "\$");
163	&ok("Client Getc Check");
164
165	@array = $client->getlines;
166	print "not " if (@array != 6);
167	&ok("Client Getlines Check 1");
168
169	print "not " if ($array[0] != "1.04\n");
170	&ok("Client Getlines Check 2");
171
172	print "not " if ($array[1] ne "4\n");
173	&ok("Client Getlines Check 3");
174
175	print "not " if ($array[2] ne "y\n");
176	&ok("Client Getlines Check 4");
177
178	print "not " if (join("", @array[3..5]) ne "Test\nBeaver\nBeaver\n");
179	&ok("Client Getlines Check 5");
180
181	print "not " if (defined(<$client>));
182	&ok("Client Finished Reading Check");
183
184	$client->close(SSL_no_shutdown => 1);
185
186	my $client_2 = new IO::Socket::INET(PeerAddr => $SSL_SERVER_ADDR,
187										PeerPort => $SSL_SERVER_PORT);
188	
189	print "not " if (!$client_2);
190	&ok("Second Client Initialization");
191
192	$client_2 = IO::Socket::SSL->new_from_fd($client_2->fileno, '+<>',
193											 SSL_reuse_ctx => $client,
194											 SSL_cipher_list => 'HIGH');
195	print "not " if (!$client_2);
196	&ok("Client Init from Fileno Check");
197	$buffer = <$client_2>;
198
199	print "not " unless ($buffer eq "Boojums\n");
200	&ok("Client (fileno) Readline Check");
201
202	$client_2->close(SSL_ctx_free => 1);
203
204	if ($GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS) {
205		my $client_3 = new IO::Socket::SSL(PeerAddr => $SSL_SERVER_ADDR,
206										   PeerPort => $SSL_SERVER_PORT,
207										   SSL_verify_mode => 0x01,
208										   SSL_ca_file => "certs/test-ca.pem",
209										   SSL_use_cert => 1,
210										   SSL_cert_file => "certs/server-cert.pem",
211										   SSL_version => 'TLSv1',
212										   SSL_cipher_list => 'HIGH',
213										   Blocking => 0,
214										   %extra_options);
215		
216		print "not " if (!$client_3);
217		&ok("Client Nonblocking Check 1");
218		close $client_3;
219
220		my $client_4 = new IO::Socket::SSL(PeerAddr => $SSL_SERVER_ADDR,
221										   PeerPort => $SSL_SERVER_PORT,
222										   SSL_reuse_ctx => $client_3,
223										   Blocking => 0,
224										   SSL_cipher_list => 'HIGH');
225		print "not " if (!$client_4);
226		&ok("Client Nonblocking Check 2");
227		$client_3->close(SSL_ctx_free => 1);
228	}
229
230	exit(0);
231}
232
233my $client = $server->accept;
234
235sub error_trap {
236	my $self = shift;
237	print $self "This server is SSL only";
238	$error_trapped = 1;
239	$self->close;
240}
241
242$error_trapped or print "not ";
243&ok("Server non-SSL Client Check");
244
245if ($client && $client->opened) {
246	print "not ok # client stayed alive!\n";
247	exit;
248}
249&ok("Server Kill-client Check");
250
251($client, $peer) = $server->accept;
252
253if (!$client) {
254	print "not ok # no client\n";
255	exit;
256}
257&ok("Server Client Accept Check");
258
259print "not " unless defined $peer;
260&ok("Accept returning peer address check.");
261
262
263fileno($client) || print "not ";
264&ok("Server Client Fileno Check");
265
266my $buffer;
267
268if ($CAN_PEEK) {
269	$client->peek($buffer, 7, 2);
270	print "not " if ($buffer ne "\0\0waaaanf");
271	&ok("Server Peek Check");
272
273	print "not " if ($client->pending() != 7);
274	&ok("Server Pending Check");
275
276	print $client "ok";
277}
278
279
280
281
282
283sysread($client, $buffer, 7, 2);
284print "not " if ($buffer ne "\0\0waaaanf");
285&ok("Server Sysread Check");
286
287
288my @array = scalar <$client>;
289print "not "  if ($array[0] ne "Test\n");
290&ok("Server Getline Check");
291
292
293print "not " if (getc($client) ne "\$");
294&ok("Server Getc Check");
295
296
297@array = <$client>;
298print "not " if (@array != 6);
299&ok("Server Getlines Check 1");
300
301print "not " if ($array[0] != "1.04\n");
302&ok("Server Getlines Check 2");
303
304print "not " if ($array[1] ne "4\n");
305&ok("Server Getlines Check 3");
306
307print "not " if ($array[2] ne "y\n");
308&ok("Server Getlines Check 4");
309
310print "not " if (join("", @array[3..5]) ne "Test\nBeaver\nBeaver\n");
311&ok("Server Getlines Check 5");
312
313
314syswrite($client, '00waaaanf00', 7, 2);
315print($client "Test\n");
316printf $client "\$%.2f\n%d\n%c\n%s", (1.0444442342, 4.0, ord("y"), "Test\nBeaver\nBeaver\n");
317
318close $client;
319
320($client, $packed) = $server->accept;
321&bail unless $client;
322print "not " unless (inet_ntoa((unpack_sockaddr_in($packed))[1]) eq "127.0.0.1");
323&ok("Peer address check");
324
325if ($GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS) {
326	$client->blocking(0);
327	$client->read($buffer, 20, 0);
328	print "not " if $SSL_ERROR != SSL_WANT_READ;
329	&ok("Server Nonblocking Check 1");
330}
331
332print "not " unless ($client->opened);
333&ok("Server Client Opened Check 1");
334
335print $client "Boojums\n";
336
337close($client);
338
339${*$client}{'_SSL_opened'} = 1;
340print "not " if ($client->opened);
341&ok("Server Client Opened Check 2");
342${*$client}{'_SSL_opened'} = 0;
343
344
345if ($GUARANTEED_TO_HAVE_NONBLOCKING_SOCKETS) {
346	$client = $server->accept;
347	print "not " if (!$client->opened);
348	&ok("Server Nonblocking Check 2");
349	close $client;
350
351	$server->blocking(0);
352	IO::Select->new($server)->can_read(30);
353	$client = $server->accept;
354	while ( ! $client ) {
355		#DEBUG( "$!,$SSL_ERROR" );
356		if ( $! == EAGAIN ) {
357			if ( $SSL_ERROR == SSL_WANT_WRITE ) {
358				IO::Select->new( $server->opening )->can_write(30);
359			} else {
360				IO::Select->new( $server->opening )->can_read(30);
361			}
362		} else {
363			last
364		}
365		$client = $server->accept;
366	}
367		
368	print "not " unless ($client && $client->opened);
369	&ok("Server Nonblocking Check 3");
370	close $client;
371}
372
373$server->close(SSL_ctx_free => 1);
374wait;
375
376sub ok {
377	print "ok #$_[0]\n"; 
378}
379
380sub bail {
381		print "Bail Out! $IO::Socket::SSL::ERROR";
382}
383
384## The future....
385#sub is_tainted {
386#    my $arg = shift;
387#    my $nada = substr($arg, 0, 0);
388#    local $@;
389#    eval {eval "# $nada"};
390#    return length($@);
391#}
392