OS/2 socket fixes.

To: Mailing list Perl5 <perl5-porters@perl.org>
Subject: [PATCH 5.005_57] Teach Socket and io_unix.t the syntax of OS/2
Message-ID: <19990529201813.B9489@monk.mps.ohio-state.edu>

p4raw-id: //depot/cfgperl@3508

1 files changed, 25 insertions, 0 deletions

diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs
index b2b145577f..336e6c451a 100644
--- a/ext/Socket/Socket.xs
+++ b/ext/Socket/Socket.xs
@@ -929,12 +929,37 @@ pack_sockaddr_un(pathname)
 #ifdef I_SYS_UN
 	struct sockaddr_un sun_ad; /* fear using sun */
 	STRLEN len;
+
 	Zero( &sun_ad, sizeof sun_ad, char );
 	sun_ad.sun_family = AF_UNIX;
 	len = strlen(pathname);
 	if (len > sizeof(sun_ad.sun_path))
 	    len = sizeof(sun_ad.sun_path);
+#  ifdef OS2	/* Name should start with \socket\ and contain backslashes! */
+	{
+	    int off;
+	    char *s, *e;
+
+	    if (pathname[0] != '/' && pathname[0] != '\\')
+		croak("Relative UNIX domain socket name '%s' unsupported", pathname);
+	    else if (len < 8 
+		     || pathname[7] != '/' && pathname[7] != '\\'
+		     || !strnicmp(pathname + 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 );
+
+	    s = sun_ad.sun_path + off - 1;
+	    e = s + len + 1;
+	    while (++s < e)
+		if (*s = '/')
+		    *s = '\\';
+	}
+#  else	/* !( defined OS2 ) */ 
 	Copy( pathname, sun_ad.sun_path, len, char );
+#  endif
 	ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad));
 #else
 	ST(0) = (SV *) not_here("pack_sockaddr_un");