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/readline.t' 4 5# This tests the behavior of readline with the variety of 6# cases with $/: 7# $/ undef - read all 8# $/ '' - read up to next nonempty line: .*?\n\n+ 9# $/ s - read up to string s 10# $/ \$num - read $num bytes 11# scalar context - get first match 12# array context - get all matches 13 14use Net::SSLeay; 15use Socket; 16use IO::Socket::SSL; 17use strict; 18 19if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) { 20 print "1..0 # Skipped: fork not implemented on this platform\n"; 21 exit 22} 23 24my @tests; 25push @tests, [ 26 "multi\nple\n\n1234567890line\n\n\n\nbla\n\nblubb\n\nblip", 27 sub { 28 my $c = shift; 29 local $/ = "\n\n"; 30 my $b; 31 ($b=<$c>) eq "multi\nple\n\n" || die "LFLF failed ($b)"; 32 $/ = \"10"; 33 ($b=<$c>) eq "1234567890" || die "\\size failed ($b)"; 34 $/ = ''; 35 ($b=<$c>) eq "line\n\n\n\n" || die "'' failed ($b)"; 36 my @c = <$c>; 37 die "'' @ failed: @c" unless $c[0] eq "bla\n\n" && 38 $c[1] eq "blubb\n\n" && 39 $c[2] eq "blip" && @c == 3; 40 }, 41]; 42 43push @tests, [ 44 "some\nstring\nwith\nsome\nlines\nwhatever", 45 sub { 46 my $c = shift; 47 local $/ = "\n"; 48 my $b; 49 ($b=<$c>) eq "some\n" || die "LF failed ($b)"; 50 $/ = undef; 51 ($b=<$c>) eq "string\nwith\nsome\nlines\nwhatever" || die "undef failed ($b)"; 52 }, 53]; 54 55push @tests, [ 56 "some\nstring\nwith\nsome\nlines\nwhatever", 57 sub { 58 my $c = shift; 59 local $/ = "\n"; 60 my @c = <$c>; 61 die "LF @ failed: @c" unless $c[0] eq "some\n" && 62 $c[1] eq "string\n" && $c[2] eq "with\n" && $c[3] eq "some\n" && 63 $c[4] eq "lines\n" && $c[5] eq "whatever" && @c == 6; 64 65 }, 66]; 67 68push @tests, [ 69 "some\nstring\nwith\nsome\nlines\nwhatever", 70 sub { 71 my $c = shift; 72 local $/; 73 my @c = <$c>; 74 die "undef @ failed: @c" unless 75 $c[0] eq "some\nstring\nwith\nsome\nlines\nwhatever" 76 && @c == 1; 77 78 }, 79]; 80 81push @tests, [ 82 "1234567890", 83 sub { 84 my $c = shift; 85 local $/ = \2; 86 my @c = <$c>; 87 die "\\2 @ failed: @c" unless 88 $c[0] eq '12' && $c[1] eq '34' && $c[2] eq '56' && 89 $c[3] eq '78' && $c[4] eq '90' && @c == 5; 90 91 }, 92]; 93 94push @tests, [ 95 [ "bla\n","0","blubb\n","no newline" ], 96 sub { 97 my $c = shift; 98 my $l = <$c>; 99 $l eq "bla\n" or die "'bla\\n' failed"; 100 $l = <$c>; 101 $l eq "0blubb\n" or die "'0blubb\\n' failed"; 102 $l = <$c>; 103 $l eq "no newline" or die "'no newline' failed"; 104 }, 105]; 106 107$|=1; 108print "1..".(1+3*@tests)."\n"; 109 110 111# first create simple ssl-server 112my $ID = 'server'; 113my $addr = '127.0.0.1'; 114my $server = IO::Socket::SSL->new( 115 LocalAddr => $addr, 116 Listen => 2, 117 ReuseAddr => 1, 118 SSL_cert_file => "certs/server-cert.pem", 119 SSL_key_file => "certs/server-key.pem", 120) || do { 121 notok($!); 122 exit 123}; 124ok("Server Initialization"); 125 126# add server port to addr 127$addr.= ':'.(sockaddr_in( getsockname( $server )))[0]; 128 129my $pid = fork(); 130if ( !defined $pid ) { 131 die $!; # fork failed 132 133} elsif ( $pid ) { ###### Server 134 135 foreach my $test (@tests) { 136 my $to_client = $server->accept || do { 137 notok( "accept failed: ".$server->errstr() ); 138 kill(9,$pid); 139 exit; 140 }; 141 ok( "Server accepted" ); 142 $to_client->autoflush; 143 my $t = $test->[0]; 144 $t = [$t] if ! ref($t); 145 for(@$t) { 146 $to_client->print($_); 147 select(undef,undef,undef,0.1); 148 } 149 } 150 wait; 151 exit; 152} 153 154$ID = 'client'; 155close($server); 156my $testid = "Test00"; 157foreach my $test (@tests) { 158 my $to_server = IO::Socket::SSL->new( $addr ) || do { 159 notok( "connect failed: ".IO::Socket::SSL->errstr() ); 160 exit 161 }; 162 ok( "client connected" ); 163 eval { $test->[1]( $to_server ) }; 164 $@ ? notok( "$testid $@" ) : ok( $testid ); 165 $testid++ 166} 167 168 169 170sub ok { print "ok # [$ID] @_\n"; } 171sub notok { print "not ok # [$ID] @_\n"; } 172