Add support for Linux abstract unix domain sockets to Socket.pm.

Based on a idea by Alex Hudson. (Basically those are unix domain
sockets whose name has a '\0' as first character.)

p4raw-id: //depot/perl@21450

diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs
index 040dda4..d2c0ae5 100644 (file)
--- a/ext/Socket/Socket.xs
+++ b/ext/Socket/Socket.xs
@@ -298,16 +298,17 @@ sockaddr_family(sockaddr)
 
 void
 pack_sockaddr_un(pathname)
-       char *  pathname
+       SV *    pathname
        CODE:
        {
 #ifdef I_SYS_UN
        struct sockaddr_un sun_ad; /* fear using sun */
        STRLEN len;
+       char * pathname_pv;
 
        Zero( &sun_ad, sizeof sun_ad, char );
        sun_ad.sun_family = AF_UNIX;
-       len = strlen(pathname);
+       pathname_pv = SvPV(pathname,len);
        if (len > sizeof(sun_ad.sun_path))
            len = sizeof(sun_ad.sun_path);
 #  ifdef OS2   /* Name should start with \socket\ and contain backslashes! */
@@ -315,16 +316,17 @@ pack_sockaddr_un(pathname)
            int off;
            char *s, *e;
 
-           if (pathname[0] != '/' && pathname[0] != '\\')
-               croak("Relative UNIX domain socket name '%s' unsupported", pathname);
+           if (pathname_pv[0] != '/' && pathname_pv[0] != '\\')
+               croak("Relative UNIX domain socket name '%s' unsupported",
+                       pathname_pv);
            else if (len < 8
-                    || pathname[7] != '/' && pathname[7] != '\\'
-                    || !strnicmp(pathname + 1, "socket", 6))
+                    || pathname_pv[7] != '/' && pathname_pv[7] != '\\'
+                    || !strnicmp(pathname_pv + 1, "socket", 6))
                off = 7;
            else
                off = 0;                /* Preserve names starting with \socket\ */
            Copy( "\\socket", sun_ad.sun_path, off, char);
-           Copy( pathname, sun_ad.sun_path + off, len, char );
+           Copy( pathname_pv, sun_ad.sun_path + off, len, char );
 
            s = sun_ad.sun_path + off - 1;
            e = s + len + 1;
@@ -333,7 +335,7 @@ pack_sockaddr_un(pathname)
                    *s = '\\';
        }
 #  else        /* !( defined OS2 ) */
-       Copy( pathname, sun_ad.sun_path, len, char );
+       Copy( pathname_pv, sun_ad.sun_path, len, char );
 #  endif
        if (0) not_here("dummy");
        ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad));
@@ -372,7 +374,10 @@ unpack_sockaddr_un(sun_sv)
                        AF_UNIX);
        }
        e = (char*)addr.sun_path;
-       while (*e && e < (char*)addr.sun_path + sizeof addr.sun_path)
+       /* On Linux, the name of abstract unix domain sockets begins
+        * with a '\0', so allow this. */
+       while ((*e || e == addr.sun_path && e[1] && sockaddrlen > 1)
+               && e < (char*)addr.sun_path + sizeof addr.sun_path)
            ++e;
        ST(0) = sv_2mortal(newSVpvn(addr.sun_path, e - (char*)addr.sun_path));
 #else

diff --git a/ext/Socket/t/Socket.t b/ext/Socket/t/Socket.t
index dba6cf3..b8d6ab0 100755 (executable)
--- a/ext/Socket/t/Socket.t
+++ b/ext/Socket/t/Socket.t
@@ -14,7 +14,7 @@ BEGIN {
        
 use Socket;
 
-print "1..16\n";
+print "1..17\n";
 
 $has_echo = $^O ne 'MSWin32';
 $alarmed = 0;
@@ -149,3 +149,21 @@ if (sockaddr_family(pack_sockaddr_in(100,inet_aton("10.250.230.10"))) == AF_INET
 
 eval { sockaddr_family("") };
 print (($@ =~ /^Bad arg length for Socket::sockaddr_family, length is 0, should be at least \d+/) ? "ok 16\n" : "not ok 16\n");
+
+if ($^O eq 'linux') {
+    # see if we can handle abstract sockets
+    my $test_abstract_socket = chr(0) . '/tmp/test-perl-socket';
+    my $addr = sockaddr_un ($test_abstract_socket);
+    my ($path) = sockaddr_un ($addr);
+    if ($test_abstract_socket eq $path) {
+        print "ok 17\n";
+    }
+    else {
+       $path =~ s/\0/\\0/g;
+       print "# got <$path>\n";
+        print "not ok 17\n";
+    }
+} else {
+    # doesn't have abstract socket support
+    print "ok 17 - skipped on this platform\n";
+}