1package NetServerTest; 2 3use strict; 4use IO::Socket; 5use Exporter; 6@NetServerTest::ISA = qw(Exporter); 7@NetServerTest::EXPORT_OK = qw(prepare_test client_connect ok is like use_ok skip diag); 8my %env; 9use constant debug => $ENV{'NS_DEBUG'} ? 1 : 0; 10 11END { 12 warn "# number of tests ran ".($env{'_ok_n'} || 0)." did not match number of specified tests ".($env{'_ok_N'} || 0)."\n" 13 if ($env{'_ok_N'} || 0) ne ($env{'_ok_n'} || 0) && ($env{'_ok_pid'} || 0) == $$; 14} 15 16sub client_connect { 17 shift if $_[0] && $_[0] eq __PACKAGE__; 18 if ($env{'ipv'} && $env{'ipv'} ne 4) { 19 require IO::Socket::INET6; 20 return IO::Socket::INET6->new(@_); 21 } else { 22 return IO::Socket::INET->new(@_); 23 } 24} 25 26# most of our tests need forking, a certain number of ports, and some pipes 27sub prepare_test { 28 my $args = shift || {}; 29 my $N = $args->{'n_tests'} || die "Missing n_tests"; 30 print "1..$N\n"; 31 %env = map {/NET_SERVER_TEST_(\w+)/; lc($1) => $ENV{$_}} grep {/^NET_SERVER_TEST_\w+$/} keys %ENV; 32 $env{'_ok_N'} = $N; 33 $env{'_ok_pid'} = $$; 34 return if $args->{'plan_only'}; 35 36 $env{'_ok_n'} = 0; 37 $env{'timeout'} ||= 5; 38 39 # allow for finding a hostname that we can use in our tests that appears to be valid 40 if (!$env{'hostname'}) { 41 eval { require Net::Server::Proto } || do { SKIP: { skip("Could not load Net::Server::Proto to lookup host: $@", $N - 1) }; exit; }; 42 foreach my $host (qw(localhost localhost.localdomain localhost6 * ::1)) { # try local bindings first to avoid opening external ports during testing 43 my @info = eval { Net::Server::Proto->get_addr_info($host) }; 44 next if ! @info; 45 @info = sort {$a->[2] <=> $b->[2]} @info; # try IPv4 first in the name of consistency, but let IPv6 work too 46 $env{'hostname'} = $info[0]->[0]; 47 $env{'ipv'} = $info[0]->[2]; 48 last; 49 } 50 die "Could not find a hostname to test connections with (tried localhost, *, ::1)" if ! $env{'hostname'}; 51 } 52 53 if ($args->{'threads'}) { 54 warn "# Checking can_thread\n" if debug; 55 ok(can_thread(), "Can thread on this platform".($@ ? " ($@)" : '')) || do { SKIP: { skip("Threads don't work on this platform", $N - 1) }; exit; }; 56 warn "# Checked can_thread\n" if debug; 57 } else { 58 warn "# Checking can_fork\n" if debug; 59 ok(can_fork(), "Can fork on this platform") || do { SKIP: { skip("Fork doesn't work on this platform", $N - 1) }; exit; }; 60 warn "# Checked can_fork\n" if debug; 61 } 62 63 warn "# Getting ports\n" if debug; 64 my $ports = $env{'ports'} = get_ports($args); 65 ok(scalar(@$ports), "Got needed ports (@$ports)") || do { SKIP: { skip("Couldn't get the needed ports for testing", $N - 2) }; exit }; 66 warn "# Got ports\n" if debug; 67 68 69 warn "# Checking pipe serialization\n" if debug; 70 pipe(NST_READ, NST_WRITE); 71 NST_READ->autoflush(1); 72 NST_WRITE->autoflush(1); 73 print NST_WRITE "22"; 74 is(read(NST_READ, my $buf, 2), 2, "Pipe works") || do { SKIP: { skip ("Couldn't use working pipe", $N - 3) }; exit }; 75 warn "# Checked pipe serialization\n" if debug; 76 $env{'block_until_ready_to_test'} = sub { read(NST_READ, my $buf, 1) }; 77 $env{'signal_ready_to_test'} = sub { print NST_WRITE "1"; NST_WRITE->flush; }; 78 79 return \%env; 80} 81 82 83sub can_fork { 84 return eval { 85 my $pid = fork; 86 die "Trouble while forking" unless defined $pid; # can't fork 87 exit unless $pid; # can fork, exit child 88 1; 89 } || 0; 90} 91 92sub can_thread { 93 return eval { 94 require threads; 95 my $n = 2; 96 my @thr = map { scalar threads->new(sub { return 3 }) } 1..$n; 97 die "Did not create correct number of threads" if threads->list() != $n; 98 my $sum = 0; 99 $sum += $_->join() for @thr; 100 die "Return did not match" if $sum ne $n * 3; 101 1; 102 } || 0; 103} 104 105sub get_ports { 106 my $args = shift; 107 my $start_port = $args->{'start_port'} || die "Missing start_port"; 108 my $n = $args->{'n_ports'} || die "Missing n_ports"; 109 my @ports; 110 eval { 111 local $SIG{'ALRM'} = sub { die }; 112 alarm $env{'timeout'}; 113 for my $port ($start_port .. $start_port + 99){ 114 my $serv = client_connect( 115 LocalAddr => $env{'hostname'}, 116 LocalPort => $port, 117 Timeout => 2, 118 Listen => 1, 119 ReuseAddr => 1, Reuse => 1, 120 ) || do { warn "Couldn't open server socket on port $port: $!\n" if $env{'trace'}; next }; 121 my $client = client_connect( 122 PeerAddr => $env{'hostname'}, 123 PeerPort => $port, 124 Timeout => 2, 125 ) || do { warn "Couldn't open client socket on port $port: $!\n" if $env{'trace'}; next }; 126 my $sock = $serv->accept || do { warn "Didn't accept properly on server: $!" if $env{'trace'}; next }; 127 $sock->autoflush(1); 128 print $sock "hi from server\n"; 129 $client->autoflush(1); 130 print $client "hi from client\n"; 131 next if <$sock> !~ /^hi from client/; 132 next if <$client> !~ /^hi from server/; 133 $client->close; 134 $sock->close; 135 push @ports, $port; 136 last if @ports == $n; 137 } 138 alarm(0); 139 }; 140 die "Number of ports didn't match (@ports) != $n ($@)" if @ports < $n; 141 return \@ports; 142} 143 144###----------------------------------------------------------------### 145 146sub ok { 147 my ($ok, $msg, $level) = @_; 148 my $n = ++$env{'_ok_n'}; 149 print "".($ok ? "" : "not ")."ok $n"; 150 print " - $msg" if defined $msg; 151 print "\n" if $msg !~ /\n\Z/; 152 if (! $ok) { 153 my ($pkg, $file, $line) = caller($level || 0); 154 print "# failed at $file line $line\n"; 155 } 156 return $ok; 157} 158 159sub is { 160 my ($a, $b, $msg) = @_; 161 if (! ok($a eq $b, $msg, 1)) { 162 print "# got: $a\n"; 163 print "# expected: $b\n"; 164 return; 165 } 166 return 1; 167} 168 169sub like { 170 my ($a, $b, $msg) = @_; 171 if (! ok($a =~ $b, $msg, 1)) { 172 print "# got: $a\n"; 173 print "# expected: $b\n"; 174 return; 175 } 176 return 1; 177} 178 179sub use_ok { 180 my $pkg = shift; 181 my $ok = eval("require $pkg") && eval {$pkg->import(@_);1}; 182 ok($ok, "use $pkg", 1) || do { print "# failed to import $pkg: $@\n"; return 0 }; 183} 184 185sub skip { 186 my ($msg, $n) = @_; 187 print "ok ".(++$env{'_ok_n'})." # skip $msg\n" for 1 .. $n; 188 no warnings 'exiting'; 189 last SKIP; 190} 191 192sub diag { 193 for my $line (@_) { 194 chomp $line; 195 print "# $line\n"; 196 } 197} 198 1991; 200