Commit | Line | Data |
---|---|---|
e122534c TC |
1 | #!perl |
2 | ||
3 | # sanity tests for socket functions | |
4 | ||
5 | BEGIN { | |
6 | chdir 't' if -d 't'; | |
7 | @INC = '../lib' if -d '../lib' && -d '../ext'; | |
8 | ||
9 | require "./test.pl"; | |
10 | require Config; import Config; | |
11 | ||
12 | skip_all_if_miniperl(); | |
13 | for my $needed (qw(d_socket d_getpbyname)) { | |
14 | if ($Config{$needed} ne 'define') { | |
15 | skip_all("-- \$Config{$needed} undefined"); | |
16 | } | |
17 | } | |
18 | unless ($Config{extensions} =~ /\bSocket\b/) { | |
19 | skip_all('-- Socket not available'); | |
20 | } | |
21 | } | |
22 | ||
23 | use strict; | |
24 | use Socket; | |
25 | ||
26 | $| = 1; # ensure test output is synchronous so processes don't conflict | |
27 | ||
28 | my $tcp = getprotobyname('tcp') | |
29 | or skip_all("no tcp protocol available ($!)"); | |
30 | my $udp = getprotobyname('udp') | |
31 | or note "getprotobyname('udp') failed: $!"; | |
32 | ||
33 | my $local = gethostbyname('localhost') | |
34 | or note "gethostbyname('localhost') failed: $!"; | |
35 | ||
36 | my $fork = $Config{d_fork} || $Config{d_pseudofork}; | |
37 | ||
38 | { | |
39 | # basic socket creation | |
40 | socket(my $sock, PF_INET, SOCK_STREAM, $tcp) | |
41 | or skip_all('socket() for tcp failed ($!), nothing else will work'); | |
42 | ok(close($sock), "close the socket"); | |
43 | } | |
44 | ||
45 | SKIP: { | |
46 | # test it all in TCP | |
47 | $local or skip("No localhost", 2); | |
48 | ||
49 | ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket"); | |
50 | my $bind_at = pack_sockaddr_in(0, $local); | |
51 | ok(bind($serv, $bind_at), "bind works") | |
52 | or skip("Couldn't bind to localhost", 3); | |
53 | my $bind_name = getsockname($serv); | |
54 | ok($bind_name, "getsockname() on bound socket"); | |
55 | my ($bind_port) = unpack_sockaddr_in($bind_name); | |
56 | ||
57 | print "# port $bind_port\n"; | |
58 | ||
59 | SKIP: | |
60 | { | |
61 | ok(listen($serv, 5), "listen() works") | |
62 | or diag "listen error: $!"; | |
63 | ||
64 | $fork or skip("No fork", 1); | |
65 | my $pid = fork; | |
66 | my $send_data = "test" x 50_000; | |
67 | if ($pid) { | |
68 | # parent | |
69 | ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp), | |
70 | "make accept tcp socket"); | |
71 | ok(my $addr = accept($accept, $serv), "accept() works") | |
72 | or diag "accept error: $!"; | |
73 | ||
74 | my $sent_total = 0; | |
75 | while ($sent_total < length $send_data) { | |
76 | my $sent = send($accept, substr($send_data, $sent_total), 0); | |
77 | defined $sent or last; | |
78 | $sent_total += $sent; | |
79 | } | |
80 | my $shutdown = shutdown($accept, 1); | |
81 | ||
82 | # wait for the remote to close so data isn't lost in | |
83 | # transit on a certain broken implementation | |
84 | <$accept>; | |
85 | # child tests are printed once we hit eof | |
86 | curr_test(curr_test()+5); | |
87 | waitpid($pid, 0); | |
88 | ||
89 | ok($shutdown, "shutdown() works"); | |
90 | } | |
91 | elsif (defined $pid) { | |
92 | curr_test(curr_test()+2); | |
93 | #sleep 1; | |
94 | # child | |
95 | ok_child(close($serv), "close server socket in child"); | |
96 | ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp), | |
97 | "make child tcp socket"); | |
98 | ||
99 | ok_child(connect($child, $bind_name), "connect() works") | |
100 | or diag "connect error: $!"; | |
101 | ||
102 | my $buf; | |
103 | my $recv_peer = recv($child, $buf, 1000, 0); | |
3fdf66f3 TC |
104 | { |
105 | use vars '$TODO'; | |
106 | local $TODO; | |
107 | $TODO = "[perl #122657] Hurd doesn't populate sin_len correctly" | |
108 | if $^O eq "gnu"; | |
109 | # [perl #118843] | |
110 | ok_child($recv_peer eq '' || $recv_peer eq getpeername $child, | |
111 | "peer from recv() should be empty or the remote name"); | |
112 | } | |
e122534c TC |
113 | while(defined recv($child, my $tmp, 1000, 0)) { |
114 | last if length $tmp == 0; | |
115 | $buf .= $tmp; | |
116 | } | |
117 | is_child($buf, $send_data, "check we received the data"); | |
118 | close($child); | |
119 | end_child(); | |
120 | ||
121 | exit(0); | |
122 | } | |
123 | else { | |
124 | # failed to fork | |
125 | diag "fork() failed $!"; | |
126 | skip("fork() failed", 1); | |
127 | } | |
128 | } | |
129 | } | |
130 | ||
131 | done_testing(); | |
132 | ||
133 | my @child_tests; | |
134 | sub ok_child { | |
135 | my ($ok, $note) = @_; | |
3fdf66f3 TC |
136 | push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note " |
137 | . ( $TODO ? "# TODO $TODO" : "" ) . "\n"; | |
e122534c TC |
138 | curr_test(curr_test()+1); |
139 | } | |
140 | ||
141 | sub is_child { | |
142 | my ($got, $want, $note) = @_; | |
143 | ok_child($got eq $want, $note); | |
144 | } | |
145 | ||
146 | sub end_child { | |
147 | print @child_tests; | |
148 | } |