This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
(perl #128095) check pack_sockaddr_un()'s return value
[perl5.git] / dist / IO / t / cachepropagate-unix.t
1 #!/usr/bin/perl
2
3 use warnings;
4 use strict;
5
6 use File::Temp qw(tempdir);
7 use File::Spec::Functions;
8 use IO::Socket;
9 use IO::Socket::UNIX;
10 use Socket;
11 use Config;
12 use Test::More;
13
14 plan skip_all => "UNIX domain sockets not implemented on $^O"
15   if ($^O =~ m/^(?:qnx|nto|vos|MSWin32|VMS)$/);
16
17 my $socketpath = catfile(tempdir( CLEANUP => 1 ), 'testsock');
18
19 # check the socketpath fits in sun_path.
20 #
21 # pack_sockaddr_un() just truncates the path, this may change, but how
22 # it will handle such a condition is undetermined (and we might need
23 # to work with older versions of Socket outside of a perl build)
24 # https://rt.cpan.org/Ticket/Display.html?id=116819
25
26 my $name = eval { pack_sockaddr_un($socketpath) };
27 defined $name && (unpack_sockaddr_un($name))[0] eq $socketpath
28   or plan skip_all => "socketpath too long for sockaddr_un";
29
30 plan tests => 15;
31
32 # start testing stream sockets:
33 my $listener = IO::Socket::UNIX->new(Type => SOCK_STREAM,
34                                      Listen => 1,
35                                      Local => $socketpath);
36 ok(defined($listener), 'stream socket created');
37
38 my $p = $listener->protocol();
39 ok(defined($p), 'protocol defined');
40 my $d = $listener->sockdomain();
41 ok(defined($d), 'domain defined');
42 my $s = $listener->socktype();
43 ok(defined($s), 'type defined');
44
45 SKIP: {
46     skip "fork not available", 4
47         unless $Config{d_fork} || $Config{d_pseudofork};
48
49     my $cpid = fork();
50     if (0 == $cpid) {
51         # the child:
52         sleep(1);
53         my $connector = IO::Socket::UNIX->new(Peer => $socketpath);
54         exit(0);
55     } else {
56         ok(defined($cpid), 'spawned a child');
57     }
58
59     my $new = $listener->accept();
60
61     is($new->sockdomain(), $d, 'domain match');
62   SKIP: {
63       skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL });
64       skip "SO_PROTOCOL defined but not implemented", 1
65          if !defined $new->sockopt(Socket::SO_PROTOCOL);
66       is($new->protocol(), $p, 'protocol match');
67     }
68   SKIP: {
69       skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE });
70       skip "SO_TYPE defined but not implemented", 1
71          if !defined $new->sockopt(Socket::SO_TYPE);
72       is($new->socktype(), $s, 'type match');
73     }
74
75     unlink($socketpath);
76     wait();
77 }
78
79 undef $TODO;
80 SKIP: {
81     skip "datagram unix sockets not supported on $^O", 7
82       if $^O eq "haiku";
83     # now test datagram sockets:
84     $listener = IO::Socket::UNIX->new(Type => SOCK_DGRAM,
85                                       Local => $socketpath);
86     ok(defined($listener), 'datagram socket created');
87
88     $p = $listener->protocol();
89     ok(defined($p), 'protocol defined');
90     $d = $listener->sockdomain();
91     ok(defined($d), 'domain defined');
92     $s = $listener->socktype();
93     ok(defined($s), 'type defined');
94
95     my $new = IO::Socket::UNIX->new_from_fd($listener->fileno(), 'r+');
96
97     is($new->sockdomain(), $d, 'domain match');
98     SKIP: {
99       skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL });
100       skip "SO_PROTOCOL defined but not implemented", 1
101          if !defined $new->sockopt(Socket::SO_PROTOCOL);
102       is($new->protocol(), $p, 'protocol match');
103     }
104     SKIP: {
105       skip "AIX: getsockopt(SO_TYPE) is badly broken on UDP/UNIX sockets", 1
106          if $^O eq "aix";
107       skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE });
108       skip "SO_TYPE defined but not implemented", 1
109          if !defined $new->sockopt(Socket::SO_TYPE);
110       is($new->socktype(), $s, 'type match');
111     }
112 }
113 unlink($socketpath);