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