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 if (defined $name) {
  28     my ($packed_name) = eval { unpack_sockaddr_un($name) };
  29     if (!defined $packed_name || $packed_name ne $socketpath) {
  30         plan skip_all => "socketpath too long for sockaddr_un";
  31     }
  32 }
  33
  34 plan tests => 15;
  35
  36 # start testing stream sockets:
  37 my $listener = IO::Socket::UNIX->new(Type => SOCK_STREAM,
  38                                      Listen => 1,
  39                                      Local => $socketpath);
  40 ok(defined($listener), 'stream socket created');
  41
  42 my $p = $listener->protocol();
  43 ok(defined($p), 'protocol defined');
  44 my $d = $listener->sockdomain();
  45 ok(defined($d), 'domain defined');
  46 my $s = $listener->socktype();
  47 ok(defined($s), 'type defined');
  48
  49 SKIP: {
  50     skip "fork not available", 4
  51         unless $Config{d_fork} || $Config{d_pseudofork};
  52
  53     my $cpid = fork();
  54     if (0 == $cpid) {
  55         # the child:
  56         sleep(1);
  57         my $connector = IO::Socket::UNIX->new(Peer => $socketpath);
  58         exit(0);
  59     } else {
  60         ok(defined($cpid), 'spawned a child');
  61     }
  62
  63     my $new = $listener->accept();
  64
  65     is($new->sockdomain(), $d, 'domain match');
  66   SKIP: {
  67       skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL });
  68       skip "SO_PROTOCOL defined but not implemented", 1
  69          if !defined $new->sockopt(Socket::SO_PROTOCOL);
  70       is($new->protocol(), $p, 'protocol match');
  71     }
  72   SKIP: {
  73       skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE });
  74       skip "SO_TYPE defined but not implemented", 1
  75          if !defined $new->sockopt(Socket::SO_TYPE);
  76       is($new->socktype(), $s, 'type match');
  77     }
  78
  79     unlink($socketpath);
  80     wait();
  81 }
  82
  83 undef $TODO;
  84 SKIP: {
  85     skip "datagram unix sockets not supported on $^O", 7
  86       if $^O eq "haiku";
  87     # now test datagram sockets:
  88     $listener = IO::Socket::UNIX->new(Type => SOCK_DGRAM,
  89                                       Local => $socketpath);
  90     ok(defined($listener), 'datagram socket created');
  91
  92     $p = $listener->protocol();
  93     ok(defined($p), 'protocol defined');
  94     $d = $listener->sockdomain();
  95     ok(defined($d), 'domain defined');
  96     $s = $listener->socktype();
  97     ok(defined($s), 'type defined');
  98
  99     my $new = IO::Socket::UNIX->new_from_fd($listener->fileno(), 'r+');
 100
 101     is($new->sockdomain(), $d, 'domain match');
 102     SKIP: {
 103       skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL });
 104       skip "SO_PROTOCOL defined but not implemented", 1
 105          if !defined $new->sockopt(Socket::SO_PROTOCOL);
 106       is($new->protocol(), $p, 'protocol match');
 107     }
 108     SKIP: {
 109       skip "AIX: getsockopt(SO_TYPE) is badly broken on UDP/UNIX sockets", 1
 110          if $^O eq "aix";
 111       skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE });
 112       skip "SO_TYPE defined but not implemented", 1
 113          if !defined $new->sockopt(Socket::SO_TYPE);
 114       is($new->socktype(), $s, 'type match');
 115     }
 116 }
 117 unlink($socketpath);