#!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);
{
use vars '$TODO';
local $TODO;
$TODO = "[perl #122657] Hurd doesn't populate sin_len correctly"
if $^O eq "gnu";
# [perl #118843]
ok_child($recv_peer eq '' || $recv_peer eq getpeername $child,
"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 "
. ( $TODO ? "# TODO $TODO" : "" ) . "\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;
}