Re: When Storable and Devel::DProf mix, core dump [perl #19385]

[p5sagit/p5-mst-13.2.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index e645f84..de6950b 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -660,15 +660,23 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
     }
     if (load && PL_subname && PL_def_layerlist
        && PL_def_layerlist->cur >= 2) {
-       SV *pkgsv = newSVpvn("PerlIO", 6);
-       SV *layer = newSVpvn(name, len);
-       ENTER;
-       /*
-        * The two SVs are magically freed by load_module
-        */
-       Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
-       LEAVE;
-       return PerlIO_find_layer(aTHX_ name, len, 0);
+       if (PL_in_load_module) {
+           Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
+           return NULL;
+       } else {
+           SV *pkgsv = newSVpvn("PerlIO", 6);
+           SV *layer = newSVpvn(name, len);
+           ENTER;
+           SAVEINT(PL_in_load_module);
+           PL_in_load_module++;
+           /*
+            * The two SVs are magically freed by load_module
+            */
+           Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
+           PL_in_load_module--;
+           LEAVE;
+           return PerlIO_find_layer(aTHX_ name, len, 0);
+       }
     }
     PerlIO_debug("Cannot find %.*s\n", (int) len, name);
     return NULL;
@@ -2654,11 +2662,13 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
      */
     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
        FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
+       int fd = fileno(stdio);
+       char mode[8];
        if (flags & PERLIO_DUP_FD) {
-           int fd = PerlLIO_dup(fileno(stdio));
-           if (fd >= 0) {
-               char mode[8];
-               stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
+           int dfd = PerlLIO_dup(fileno(stdio));
+           if (dfd >= 0) {
+               stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
+               goto set_this;
            }
            else {
                /* FIXME: To avoid messy error recovery if dup fails
@@ -2666,6 +2676,8 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
                 */
            }
        }
+       stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
+    set_this:
        PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
        PerlIOUnix_refcnt_inc(fileno(stdio));
     }
@@ -2684,11 +2696,22 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
        errno = EBADF;
        return -1;
     }
-    if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
-       /* Do not close it but do flush any buffers */
-       return PerlIO_flush(f);
-    }
-    return (
+    else {
+        int fd = fileno(stdio);
+       int dupfd = -1;
+       IV result;
+       if (PerlIOUnix_refcnt_dec(fd) > 0) {
+           /* File descriptor still in use */
+           if (fd < 3) {
+               /* For STD* handles don't close the stdio at all */
+               return PerlIO_flush(f);
+           }
+           else {
+               /* Tricky - must fclose(stdio) to free memory but not close(fd) */ 
+               dupfd = PerlLIO_dup(fd);
+           }
+       }    
+        result = (
 #ifdef SOCKS5_VERSION_NAME
               (getsockopt
                (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
@@ -2698,6 +2721,15 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
               PerlSIO_fclose(stdio)
 #endif
        );
+       if (dupfd >= 0) {
+           /* We need to restore fd from the saved copy */
+           if (PerlLIO_dup2(dupfd,fd) != fd)
+             result = -1;
+           if (PerlLIO_close(dupfd) != 0)
+             result = -1; 
+       }
+       return result;
+    } 
 
 }
 
@@ -3395,6 +3427,11 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
        PerlIO_get_base(f);
     if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
        return 0;
+    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
+       if (PerlIO_flush(f) != 0) {
+           return 0;
+       }
+    }  
     while (count > 0) {
        SSize_t avail = b->bufsiz - (b->ptr - b->buf);
        if ((SSize_t) count < avail)
@@ -3453,6 +3490,19 @@ PerlIOBuf_tell(pTHX_ PerlIO *f)
      * b->posn is file position where b->buf was read, or will be written
      */
     Off_t posn = b->posn;
+    if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && 
+        (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
+#if 1
+       /* As O_APPEND files are normally shared in some sense it is better
+          to flush :
+        */     
+       PerlIO_flush(f);
+#else  
+        /* when file is NOT shared then this is sufficient */ 
+       PerlIO_seek(PerlIONext(f),0, SEEK_END);
+#endif
+       posn = b->posn = PerlIO_tell(PerlIONext(f));
+    }
     if (b->buf) {
        /*
         * If buffer is valid adjust position by amount in buffer
@@ -3839,13 +3889,16 @@ PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
                        b->ptr++;       /* say we have read it as far as
                                         * flush() is concerned */
                        b->buf++;       /* Leave space in front of buffer */
+                       /* Note as we have moved buf up flush's
+                          posn += ptr-buf
+                          will naturally make posn point at CR
+                        */
                        b->bufsiz--;    /* Buffer is thus smaller */
                        code = PerlIO_fill(f);  /* Fetch some more */
                        b->bufsiz++;    /* Restore size for next time */
                        b->buf--;       /* Point at space */
                        b->ptr = nl = b->buf;   /* Which is what we hand
                                                 * off */
-                       b->posn--;      /* Buffer starts here */
                        *nl = 0xd;      /* Fill in the CR */
                        if (code == 0)
                            goto test;  /* fill() call worked */