Work-in-progress - do not integrate yet

Experimental PerlIO_syslayer() [or sysread only at this point]
3 fails on a UNIX :perlio stack
 - warnings misses Filehandle F opened only for output (weird)
 - socketpair discovers that Unix_read() restarts on EINTR (gotcha)
 - lib/open fails to sysread() chars (a feature?)

p4raw-id: //depot/perlio@19587

diff --git a/makedef.pl b/makedef.pl
index 74773fb..1a6f571 100644 (file)
--- a/makedef.pl
+++ b/makedef.pl
@@ -812,6 +812,7 @@ my @layer_syms = qw(
                         PerlIO_pop
                         PerlIO_sv_dup
                         PerlIO_perlio
+                        PerlIO_syslayer
 
 Perl_PerlIO_clearerr
 Perl_PerlIO_close

diff --git a/perlio.c b/perlio.c
index 765882e..d0ed97a 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -430,14 +430,6 @@ PerlIO_findFILE(PerlIO *pio)
 #include <sys/mman.h>
 #endif
 
-/*
- * Why is this here - not in perlio.h?  RMB
- */
-void PerlIO_debug(const char *fmt, ...)
-#ifdef CHECK_FORMAT
-    __attribute__ ((__format__(__printf__, 1, 2)))
-#endif
-;
 
 void
 PerlIO_debug(const char *fmt, ...)
@@ -1025,6 +1017,27 @@ PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
     return def;
 }
 
+PerlIO *
+PerlIO_syslayer(pTHX_ PerlIO *f)
+{
+     if (PerlIOValid(f)) {
+       PerlIOl *l;
+       while (*PerlIONext(f)) {
+          f = PerlIONext(f);
+       }
+       l = *f;
+#if 0
+       Perl_warn(aTHX_ "syslayer %s",l->tab->name);
+#endif
+       return f;
+     }
+     else {
+       SETERRNO(EBADF, SS_IVCHAN);
+       return NULL;
+     }
+}
+
+
 IV
 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
@@ -2008,6 +2021,10 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
                 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
                 l->flags, PerlIO_modestr(f, temp));
 #endif
+    if (l->next) {
+       l->flags |= l->next->flags &
+               (PERLIO_F_TTY | PERLIO_F_NOTREG | PERLIO_F_SOCKET);
+    }
     return 0;
 }
 
@@ -2338,9 +2355,16 @@ static void
 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
 {
     PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
-#if defined(WIN32)
+
+#if 1 || defined(WIN32) || defined(HAS_SOCKET) && \
+    (defined(PERL_SOCK_SYSREAD_IS_RECV) || \
+     defined(PERL_SOCK_SYSWRITE_IS_SEND))
     Stat_t st;
     if (PerlLIO_fstat(fd, &st) == 0) {
+#if defined(WIN32)
+       /* WIN32 needs to know about non-regular files
+          as only regular files can be lseek()ed
+         */
        if (!S_ISREG(st.st_mode)) {
            PerlIO_debug("%d is not regular file\n",fd);
            PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
@@ -2348,8 +2372,32 @@ PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
        else {
            PerlIO_debug("%d _is_ a regular file\n",fd);
        }
-    }
 #endif
+       /* If read/write are to be mapped to recv/send we need
+          to know this is a socket.
+          Lifted from code in doio.c that handles socket detection on dup
+        */
+#ifndef PERL_MICRO
+       if (S_ISSOCK(st.st_mode))
+           PerlIOBase(f)->flags |= PERLIO_F_SOCKET;
+       else if (
+#ifdef S_IFMT
+           !(st.st_mode & S_IFMT)
+#else
+           !st.st_mode
+#endif
+       ) {
+            char tmpbuf[256];
+            Sock_size_t buflen = sizeof tmpbuf;
+            if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
+                     || errno != ENOTSOCK)
+                   PerlIOBase(f)->flags |= PERLIO_F_SOCKET; /* some OS's return 0 on fstat()ed socket */
+                                               /* but some return 0 for streams too, sigh */
+       }
+#endif /* !PERL_MICRO */
+    }
+#endif /* HAS_SOCKET ... */
+
     s->fd = fd;
     s->oflags = imode;
     PerlIOUnix_refcnt_inc(fd);
@@ -2450,7 +2498,16 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
        return 0;
     }
     while (1) {
-       SSize_t len = PerlLIO_read(fd, vbuf, count);
+       SSize_t len;
+#ifdef PERL_SOCK_SYSREAD_IS_RECV
+       if (PerlIOBase(f)->flags & PERLIO_F_SOCKET) {
+           len = PerlSock_recv(fd, vbuf, count, 0);
+       }
+       else
+#endif
+       {
+           len = PerlLIO_read(fd, vbuf, count);
+       }
        if (len >= 0 || errno != EINTR) {
            if (len < 0) {
                if (errno != EAGAIN) {

diff --git a/perlio.h b/perlio.h
index 4d88439..1b7ac36 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -371,9 +371,15 @@ extern int PerlIO_intmode2str(int rawmode, char *mode, int *writing);
 #ifdef PERLIO_LAYERS
 extern void PerlIO_cleanup(pTHX);
 
-extern void PerlIO_debug(const char *fmt, ...);
+extern void PerlIO_debug(const char *fmt, ...)
+#ifdef CHECK_FORMAT
+    __attribute__ ((__format__(__printf__, 1, 2)))
+#endif
+;
+
 typedef struct PerlIO_list_s PerlIO_list_t;
 
+extern PerlIO *PerlIO_syslayer(pTHX_ PerlIO *);
 
 #endif
 

diff --git a/perliol.h b/perliol.h
index 47fe6fc..9833492 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -88,7 +88,8 @@ struct _PerlIO {
 #define PERLIO_F_OPEN          0x00200000
 #define PERLIO_F_FASTGETS      0x00400000
 #define PERLIO_F_TTY           0x00800000
-#define PERLIO_F_NOTREG         0x01000000   
+#define PERLIO_F_NOTREG         0x01000000
+#define PERLIO_F_SOCKET                0x02000000
 
 #define PerlIOBase(f)      (*(f))
 #define PerlIOSelf(f,type) ((type *)PerlIOBase(f))

diff --git a/pp_sys.c b/pp_sys.c
index ae6d986..c1ff341 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1527,6 +1527,7 @@ PP(pp_sysread)
     bool charstart = FALSE;
     STRLEN charskip = 0;
     STRLEN skip = 0;
+    PerlIO *pio;
 
     gv = (GV*)*++MARK;
     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
@@ -1565,7 +1566,19 @@ PP(pp_sysread)
        SETERRNO(EBADF,RMS_IFI);
        goto say_undef;
     }
-    if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
+    pio = IoIFP(io);
+#ifdef PERLIO_LAYERS
+    if (PL_op->op_type == OP_SYSREAD) {
+       /* sysread happens further down the stack
+          and we need isutf8 of that layer
+        */
+       pio = PerlIO_syslayer(aTHX_ pio);
+       if (!pio) {
+           goto say_undef;
+       }
+    }
+#endif
+    if ((fp_utf8 = PerlIO_isutf8(pio)) && !IN_BYTES) {
        buffer = SvPVutf8_force(bufsv, blen);
        /* UTF8 may not have been set if they are all low bytes */
        SvUTF8_on(bufsv);
@@ -1595,7 +1608,7 @@ PP(pp_sysread)
 #endif
        buffer = SvGROW(bufsv, (STRLEN)(length+1));
        /* 'offset' means 'flags' here */
-       count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+       count = PerlSock_recvfrom(PerlIO_fileno(pio), buffer, length, offset,
                          (struct sockaddr *)namebuf, &bufsize);
        if (count < 0)
            RETPUSHUNDEF;
@@ -1642,20 +1655,22 @@ PP(pp_sysread)
     }
     buffer = buffer + offset;
 
+#ifndef PERLIO_LAYERS
     if (PL_op->op_type == OP_SYSREAD) {
 #ifdef PERL_SOCK_SYSREAD_IS_RECV
        if (IoTYPE(io) == IoTYPE_SOCKET) {
-           count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
+           count = PerlSock_recv(PerlIO_fileno(pio),
                                   buffer, length, 0);
        }
        else
 #endif
        {
-           count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
+           count = PerlLIO_read(PerlIO_fileno(pio),
                                  buffer, length);
        }
     }
     else
+#endif
 #ifdef HAS_SOCKET__bad_code_maybe
     if (IoTYPE(io) == IoTYPE_SOCKET) {
        char namebuf[MAXPATHLEN];
@@ -1664,15 +1679,15 @@ PP(pp_sysread)
 #else
        bufsize = sizeof namebuf;
 #endif
-       count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
+       count = PerlSock_recvfrom(PerlIO_fileno(pio), buffer, length, 0,
                          (struct sockaddr *)namebuf, &bufsize);
     }
     else
 #endif
     {
-       count = PerlIO_read(IoIFP(io), buffer, length);
+       count = PerlIO_read(pio, buffer, length);
        /* PerlIO_read() - like fread() returns 0 on both error and EOF */
-       if (count == 0 && PerlIO_error(IoIFP(io)))
+       if (count == 0 && PerlIO_error(pio))
            count = -1;
     }
     if (count < 0) {