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