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
|
#!perl
# sanity tests for socket functions
BEGIN {
chdir 't' if -d 't';
@INC = '../lib' if -d '../lib' && -d '../ext';
require "./test.pl";
require Config; import Config;
skip_all_if_miniperl();
for my $needed (qw(d_socket d_getpbyname)) {
if ($Config{$needed} ne 'define') {
skip_all("-- \$Config{$needed} undefined");
}
}
unless ($Config{extensions} =~ /\bSocket\b/) {
skip_all('-- Socket not available');
}
}
use strict;
use Socket;
$| = 1; # ensure test output is synchronous so processes don't conflict
my $tcp = getprotobyname('tcp')
or skip_all("no tcp protocol available ($!)");
my $udp = getprotobyname('udp')
or note "getprotobyname('udp') failed: $!";
my $local = gethostbyname('localhost')
or note "gethostbyname('localhost') failed: $!";
my $fork = $Config{d_fork} || $Config{d_pseudofork};
{
# basic socket creation
socket(my $sock, PF_INET, SOCK_STREAM, $tcp)
or skip_all('socket() for tcp failed ($!), nothing else will work');
ok(close($sock), "close the socket");
}
SKIP: {
# test it all in TCP
$local or skip("No localhost", 2);
ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket");
my $bind_at = pack_sockaddr_in(0, $local);
ok(bind($serv, $bind_at), "bind works")
or skip("Couldn't bind to localhost", 3);
my $bind_name = getsockname($serv);
ok($bind_name, "getsockname() on bound socket");
my ($bind_port) = unpack_sockaddr_in($bind_name);
print "# port $bind_port\n";
SKIP:
{
ok(listen($serv, 5), "listen() works")
or diag "listen error: $!";
$fork or skip("No fork", 1);
my $pid = fork;
my $send_data = "test" x 50_000;
if ($pid) {
# parent
ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp),
"make accept tcp socket");
ok(my $addr = accept($accept, $serv), "accept() works")
or diag "accept error: $!";
my $sent_total = 0;
while ($sent_total < length $send_data) {
my $sent = send($accept, substr($send_data, $sent_total), 0);
defined $sent or last;
$sent_total += $sent;
}
my $shutdown = shutdown($accept, 1);
# wait for the remote to close so data isn't lost in
# transit on a certain broken implementation
<$accept>;
# child tests are printed once we hit eof
curr_test(curr_test()+5);
waitpid($pid, 0);
ok($shutdown, "shutdown() works");
}
elsif (defined $pid) {
curr_test(curr_test()+2);
#sleep 1;
# child
ok_child(close($serv), "close server socket in child");
ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp),
"make child tcp socket");
ok_child(connect($child, $bind_name), "connect() works")
or diag "connect error: $!";
my $buf;
my $recv_peer = recv($child, $buf, 1000, 0);
# [perl #118843]
ok_child($recv_peer eq '' || $recv_peer eq $bind_name,
"peer from recv() should be empty or the remote name");
while(defined recv($child, my $tmp, 1000, 0)) {
last if length $tmp == 0;
$buf .= $tmp;
}
is_child($buf, $send_data, "check we received the data");
close($child);
end_child();
exit(0);
}
else {
# failed to fork
diag "fork() failed $!";
skip("fork() failed", 1);
}
}
}
done_testing();
my @child_tests;
sub ok_child {
my ($ok, $note) = @_;
push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note\n";
curr_test(curr_test()+1);
}
sub is_child {
my ($got, $want, $note) = @_;
ok_child($got eq $want, $note);
}
sub end_child {
print @child_tests;
}
|
