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