[text] modified nonblock.t with timestamps and debugging

Viewer

copydownloadembedprintName: modified nonblock.t with timestamps and debugging
  1. #!perl
  2. # Before `make install' is performed this script should be runnable with
  3. # `make test'. After `make install' it should work as `perl t/nonblock.t'
  4.  
  5.  
  6. use strict;
  7. use warnings;
  8. use Net::SSLeay;
  9. use Socket;
  10. use IO::Socket::SSL;
  11. use IO::Select;
  12. use Errno qw( EWOULDBLOCK EAGAIN EINPROGRESS);
  13. do './testlib.pl' || do './t/testlib.pl' || die "no testlib";
  14.  
  15. if ( ! eval "use 5.006; use IO::Select; return 1" ) {
  16.     print "1..0 # Skipped: no support for nonblocking sockets\n";
  17.     exit;
  18. }
  19.  
  20. $|=1;
  21. print "1..27\n";
  22.  
  23. my $START = time();
  24.  
  25. # first create simple non-blocking tcp-server
  26. my $ID = 'server';
  27. my $server = IO::Socket::INET->new(
  28.     Blocking => 0,
  29.     LocalAddr => '127.0.0.1',
  30.     LocalPort => 0,
  31.     Listen => 2,
  32. );
  33.  
  34. print "not ok: $!\n", exit if !$server; # Address in use?
  35. ok("Server Initialization");
  36.  
  37. my $saddr = $server->sockhost.':'.$server->sockport;
  38. my $ssock = $server->sockname;
  39.  
  40. defined( my $pid = fork() ) || die $!;
  41. if ( $pid == 0 ) {
  42.  
  43.     ############################################################
  44.     # CLIENT == child process
  45.     ############################################################
  46.  
  47.     close($server);
  48.     $ID = 'client';
  49.  
  50.     # fast: try connect_SSL immediately after sending plain text
  51.     #       connect_SSL should fail on the first attempt because server
  52.     #       is not ready yet
  53.     # slow: wait before calling connect_SSL
  54.     #       connect_SSL should succeed, because server was already waiting
  55.  
  56.     for my $test ( 'fast','slow' ) {
  57.  
  58.         # initial socket is unconnected, tcp, nonblocking
  59.         my $to_server = IO::Socket::INET->new( Proto => 'tcp', Blocking => 0 );
  60.  
  61.         # nonblocking connect of tcp socket
  62.         while (1) {
  63.             connect($to_server,$ssock ) && last;
  64.             if ( $!{EINPROGRESS} ) {
  65.                 diag( 'connect in progress' );
  66.                 IO::Select->new( $to_server )->can_write(30) && next;
  67.                 print "not ";
  68.                 last;
  69.             } elsif ( $!{EWOULDBLOCK} || $!{EAGAIN} ) {
  70.                 diag( 'connect not yet completed');
  71.                 # just wait
  72.                 select(undef,undef,undef,0.1);
  73.                 next;
  74.             } elsif ( $!{EISCONN} ) {
  75.                 diag('claims that socket is already connected');
  76.                 # found on Mac OS X, dunno why it does not tell me that
  77.                 # the connect succeeded before
  78.                 last;
  79.             }
  80.             diag( 'connect failed: '.$! );
  81.             print "not ";
  82.             last;
  83.         }
  84.         ok( "client tcp connect" );
  85.  
  86.         # work around (older?) systems where IO::Socket::INET
  87.         # cannot do non-blocking connect by forcing non-blocking
  88.         # again (we want to test non-blocking behavior of IO::Socket::SSL,
  89.         # not IO::Socket::INET)
  90.         $to_server->blocking(0);
  91.  
  92.         # send some plain text on non-ssl socket
  93.         my $pmsg = 'plaintext';
  94.         while ( $pmsg ne '' ) {
  95.             my $w = syswrite( $to_server,$pmsg );
  96.             if ( ! defined $w ) {
  97.                 if ( ! $!{EWOULDBLOCK} && ! $!{EAGAIN} ) {
  98.                     diag("syswrite failed with $!");
  99.                     print "not ";
  100.                     last;
  101.                 }
  102.                 IO::Select->new($to_server)->can_write(30) or do {
  103.                     diag("failed to get write ready");
  104.                     print "not ";
  105.                     last;
  106.                 };
  107.             } elsif ( $w>0 ) {
  108.                 diag("wrote $w bytes");
  109.                 substr($pmsg,0,$w,'');
  110.             } else {
  111.                 die "syswrite returned 0";
  112.             }
  113.         }
  114.         ok( "write plain text" );
  115.  
  116.         # let server catch up, so that it awaits my connection
  117.         # so that connect_SSL does not have to wait
  118.         sleep(5) if ( $test eq 'slow' );
  119.  
  120.         # upgrade to SSL socket w/o connection yet
  121.         if ( ! IO::Socket::SSL->start_SSL( $to_server,
  122.             SSL_startHandshake => 0,
  123.             SSL_verify_mode => 0,
  124.             SSL_key_file => "certs/server-key.enc",
  125.             SSL_passwd_cb => sub { return "bluebell" },
  126.         )) {
  127.             diag( 'start_SSL return undef' );
  128.             print "not ";
  129.         } elsif ( !UNIVERSAL::isa( $to_server,'IO::Socket::SSL' ) ) {
  130.             diag( 'failed to upgrade socket' );
  131.             print "not ";
  132.         }
  133.         ok( "upgrade client to IO::Socket::SSL" );
  134.  
  135.         # SSL handshake thru connect_SSL
  136.         # if $test eq 'fast' we expect one failed attempt because server
  137.         # did not call accept_SSL yet
  138.         my $attempts = 0;
  139.         while ( 1 ) {
  140.             $to_server->connect_SSL && last;
  141.             diag( $SSL_ERROR );
  142.             if ( $SSL_ERROR == SSL_WANT_READ ) {
  143.                 $attempts++;
  144.                 IO::Select->new($to_server)->can_read(30) && next; # retry if can read
  145.             } elsif ( $SSL_ERROR == SSL_WANT_WRITE ) {
  146.                 IO::Select->new($to_server)->can_write(30) && next; # retry if can write
  147.             }
  148.             diag( "failed to connect: $@" );
  149.             print "not ";
  150.             last;
  151.         }
  152.         ok( "connected" );
  153.  
  154.         if ( $test ne 'slow' ) {
  155.             print "not " if !$attempts;
  156.             ok( "nonblocking connect with $attempts attempts" );
  157.         }
  158.  
  159.         # send some data
  160.         # we send up to 500000 bytes, server reads first 10 bytes and then sleeps
  161.         # before reading more. In total server only reads 30000 bytes
  162.         # the sleep will cause the internal buffers to fill up so that the syswrite
  163.         # should return with EWOULDBLOCK+SSL_WANT_WRITE.
  164.         # the socket close should cause EPIPE or ECONNRESET
  165.  
  166.         my $msg = "1234567890";
  167.         $attempts = 0;
  168.         my $bytes_send = 0;
  169.  
  170.         # set send buffer to 8192 so it will definitely fail writing all 500000 bytes in it
  171.         # beware that linux allocates twice as much (see tcp(7))
  172.         # AIX seems to get very slow if you set the sndbuf on localhost, so don't to it
  173.         # https://rt.cpan.org/Public/Bug/Display.html?id=72305
  174.         if ( $^O !~m/aix/i ) {
  175.             eval q{
  176.                 setsockopt( $to_server, SOL_SOCKET, SO_SNDBUF, pack( "I",8192 ));
  177.                 diag( "sndbuf=".unpack( "I",getsockopt( $to_server, SOL_SOCKET, SO_SNDBUF )));
  178.             };
  179.         }
  180.  
  181.         my $test_might_fail;
  182.         if ( $@ ) {
  183.             # the next test might fail because setsockopt(... SO_SNDBUF...) failed
  184.             $test_might_fail = 1;
  185.         }
  186.  
  187.         my $can;
  188.         WRITE:
  189.         for( my $i=0;$i<50000;$i++ ) {
  190.             my $offset = 0;
  191.             my $sel_server = IO::Select->new($to_server);
  192.             while (1) {
  193.                 if ($can && !$sel_server->$can(15)) {
  194.                     if ( $bytes_send > 30000 ) {
  195.                         diag("fail $can, but limit reached. Assume connection closed");
  196.                     } else {
  197.                         diag("fail $can");
  198.                         print "not ";
  199.                     }
  200.                     last WRITE;
  201.                 }
  202.  
  203.                 my $n = syswrite( $to_server,$msg,length($msg)-$offset,$offset );
  204.                 if ( !defined($n) ) {
  205.                     diag( "\$!=$! \$SSL_ERROR=$SSL_ERROR send=$bytes_send" );
  206.                     if ( $! == EWOULDBLOCK || $! == EAGAIN ) {
  207.                         if ( $SSL_ERROR == SSL_WANT_WRITE ) {
  208.                             diag( 'wait for write' );
  209.                             $can = 'can_write';
  210.                             $attempts++;
  211.                         } elsif ( $SSL_ERROR == SSL_WANT_READ ) {
  212.                             diag( 'wait for read' );
  213.                             $can = 'can_read';
  214.                         } else {
  215.                             $can = 'can_write';
  216.                         }
  217.                     } elsif ( $bytes_send > 30000 ) {
  218.                         diag( "connection closed" );
  219.                         last WRITE;
  220.                     }
  221.                     next;
  222.                 } elsif ( $n == 0 ) {
  223.                     diag( "connection closed" );
  224.                     last WRITE;
  225.                 } elsif ( $n<0 ) {
  226.                     diag( "syswrite returned $n!" );
  227.                     print "not ";
  228.                     last WRITE;
  229.                 }
  230.  
  231.                 $bytes_send += $n;
  232.                 if ( $n + $offset == 10 ) {
  233.                     last
  234.                 } else {
  235.                     $offset += $n;
  236.                     diag( "partial write of $n new offset=$offset" );
  237.                 }
  238.             }
  239.         }
  240.         ok( "syswrite" );
  241.  
  242.         if ( ! $attempts && $test_might_fail ) {
  243.             ok( " write attempts failed, but OK nevertheless because setsockopt failed" );
  244.         } else {
  245.             print "not " if !$attempts;
  246.             ok( "multiple write attempts" );
  247.         }
  248.  
  249.         print "not " if $bytes_send < 30000;
  250.         ok( "30000 bytes send" );
  251.     }
  252.  
  253. } else {
  254.  
  255.     ############################################################
  256.     # SERVER == parent process
  257.     ############################################################
  258.  
  259.     # pendant to tests in client. Where client is slow (sleep
  260.     # between plain text sending and connect_SSL) I need to
  261.     # be fast and where client is fast I need to be slow (sleep
  262.     # between receiving plain text and accept_SSL)
  263.  
  264.     foreach my $test ( 'slow','fast' ) {
  265.  
  266.         # accept a connection
  267.         my $can_read = IO::Select->new( $server )->can_read(30);
  268.         diag("tcp server socket is ".($can_read? "ready" : "NOT ready"));
  269.         my $from_client = $server->accept or print "not ";
  270.         ok( "tcp accept" );
  271.         $from_client || do {
  272.             diag( "failed to tcp accept: $!" );
  273.             next;
  274.         };
  275.  
  276.         # make client non-blocking!
  277.         $from_client->blocking(0);
  278.  
  279.         # read plain text data
  280.         my $buf = '';
  281.         while ( length($buf) <9 ) {
  282.             sysread( $from_client, $buf,9-length($buf),length($buf) ) && next;
  283.             die "sysread failed: $!" if $! != EWOULDBLOCK && $! != EAGAIN;
  284.             IO::Select->new( $from_client )->can_read(30);
  285.         }
  286.         $buf eq 'plaintext' || print "not ";
  287.         ok( "received plain text" );
  288.  
  289.         # upgrade socket to IO::Socket::SSL
  290.         # no handshake yet
  291.         if ( ! IO::Socket::SSL->start_SSL( $from_client,
  292.             SSL_startHandshake => 0,
  293.             SSL_server => 1,
  294.             SSL_verify_mode => 0x00,
  295.             SSL_ca_file => "certs/test-ca.pem",
  296.             SSL_use_cert => 1,
  297.             SSL_cert_file => "certs/client-cert.pem",
  298.             SSL_key_file => "certs/client-key.enc",
  299.             SSL_passwd_cb => sub { return "opossum" },
  300.         )) {
  301.             diag( 'start_SSL return undef' );
  302.             print "not ";
  303.         } elsif ( !UNIVERSAL::isa( $from_client,'IO::Socket::SSL' ) ) {
  304.             diag( 'failed to upgrade socket' );
  305.             print "not ";
  306.         }
  307.         ok( "upgrade to_client to IO::Socket::SSL" );
  308.  
  309.         sleep(5) if $test eq 'slow'; # wait until client calls connect_SSL
  310.  
  311.         # SSL handshake  thru accept_SSL
  312.         # if test is 'fast' (e.g. client is 'slow') we expect the first
  313.         # accept_SSL attempt to fail because client did not call connect_SSL yet
  314.         my $attempts = 0;
  315.         while ( 1 ) {
  316.             $from_client->accept_SSL && last;
  317.             if ( $SSL_ERROR == SSL_WANT_READ ) {
  318.                 $attempts++;
  319.                 IO::Select->new($from_client)->can_read(30) && next; # retry if can read
  320.             } elsif ( $SSL_ERROR == SSL_WANT_WRITE ) {
  321.                 $attempts++;
  322.                 IO::Select->new($from_client)->can_write(30) && next; # retry if can write
  323.             } else {
  324.                 diag( "failed to ssl accept ($test): $@" );
  325.                 print "not ";
  326.                 last;
  327.             }
  328.         }
  329.         ok( "ssl accept handshake done" );
  330.  
  331.         if ( $test eq 'fast' ) {
  332.             print "not " if !$attempts;
  333.             ok( "nonblocking accept_SSL with $attempts attempts" );
  334.         }
  335.  
  336.         # reading 10 bytes
  337.         # then sleeping so that buffers from client to server gets
  338.         # filled up and clients receives EWOULDBLOCK+SSL_WANT_WRITE
  339.  
  340.         IO::Select->new( $from_client )->can_read(30);
  341.         ( sysread( $from_client, $buf,10 ) == 10 ) || print "not ";
  342.         #diag($buf);
  343.         ok( "received client message" );
  344.  
  345.         sleep(5);
  346.         my $bytes_received = 10;
  347.  
  348.         # read up to 30000 bytes from client, then close the socket
  349.         my $can;
  350.         READ:
  351.         while ( ( my $diff = 30000 - $bytes_received ) > 0 ) {
  352.             if ( $can && ! IO::Select->new($from_client)->$can(30)) {
  353.                 diag("failed $can");
  354.                 print "not ";
  355.                 last READ;
  356.             }
  357.             my $n = sysread( $from_client,my $buf,$diff );
  358.             if ( !defined($n) ) {
  359.                 diag( "\$!=$! \$SSL_ERROR=$SSL_ERROR" );
  360.                 if ( $! == EWOULDBLOCK || $! == EAGAIN ) {
  361.                     if ( $SSL_ERROR == SSL_WANT_READ ) {
  362.                         $attempts++;
  363.                         $can = 'can_read';
  364.                     } elsif ( $SSL_ERROR == SSL_WANT_WRITE ) {
  365.                         $attempts++;
  366.                         $can = 'can_write';
  367.                     } else {
  368.                         $can = 'can_read';
  369.                     }
  370.                 } else {
  371.                     print "not ";
  372.                     last READ;
  373.                 }
  374.                 next;
  375.             } elsif ( $n == 0 ) {
  376.                 diag( "connection closed" );
  377.                 last READ;
  378.             } elsif ( $n<0 ) {
  379.                 diag( "sysread returned $n!" );
  380.                 print "not ";
  381.                 last READ;
  382.             }
  383.  
  384.             $bytes_received += $n;
  385.             #diag( "read of $n bytes total $bytes_received" );
  386.         }
  387.  
  388.         diag( "read $bytes_received ($attempts r/w attempts)" );
  389.         close($from_client);
  390.     }
  391.  
  392.     # wait until client exits
  393.     wait;
  394. }
  395.  
  396. exit;
  397.  
  398.  
  399.  
  400. sub ok   { unshift @_, "ok # "; goto &_out }
  401. sub diag { unshift @_, "#    "; goto &_out }
  402. sub _out {
  403.     my $prefix = shift;
  404.     printf "%s [%04d.%s:%03d] %s\n",
  405.         $prefix,
  406.         time() - $START,
  407.         $ID,
  408.         (caller())[2],
  409.         "@_";
  410. }
  411.  

Editor

You can edit this paste and save as new:


File Description
  • modified nonblock.t with timestamps and debugging
  • Paste Code
  • 22 May-2021
  • 11.39 Kb
You can Share it: