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
|
use strict;
use Test::More tests => 6;
use Test::TCP;
use t::Server;
test_tcp
client => sub {
my $port = shift;
my $pid = fork();
if (! ok defined $pid, "Successfully forked child $pid") {
return diag("Could not fork: $!");
}
if (! $pid) {
eval {
ok 1, "Successfully executed child $$";
};
my $e = $@;
if (! ok !$e, "child exited normally") {
diag( "Encountered an error $e" );
}
exit;
}
waitpid($pid, 0);
# after the child has exited, we need to make sure that
# the server hasn't gone away.
my $sock = IO::Socket::INET->new(
PeerPort => $port,
PeerAddr => '127.0.0.1',
Proto => 'tcp'
);
if (! ok $sock, "socket is connected") {
return diag("Cannot open client socket: $!");
}
print {$sock} "Hello server\n";
my $res = <$sock>;
is $res, "Hello server\n", "got expected reply";
},
server => sub {
my $port = shift;
t::Server->new($port)->run(sub {
note "new request";
my ($remote, $line, $sock) = @_;
print {$remote} $line;
});
}
;
if ($?) {
# It's maybe ActivePerl's bug.
# http://ppm4.activestate.com/MSWin32-x86/5.12/1200/T/TO/TOKUHIROM/Test-TCP-1.11.d/log-20101221T221845.txt
diag "test_tcp() leaks \$?. Maybe it's Perl bug?: $?";
$? = 0;
}
|
