Missed some, cryptically.

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

diff --git a/perlio.c b/perlio.c
index d9cfc39..9cb12d0 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -666,8 +666,13 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
        } else {
            SV *pkgsv = newSVpvn("PerlIO", 6);
            SV *layer = newSVpvn(name, len);
-           ENTER;
+           CV *cv  = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+           ENTER;
            SAVEINT(PL_in_load_module);
+           if (cv) {
+               SAVESPTR(PL_warnhook);
+               PL_warnhook = (SV *) cv;
+           }
            PL_in_load_module++;
            /*
             * The two SVs are magically freed by load_module
@@ -770,6 +775,17 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
     return sv;
 }
 
+XS(XS_PerlIO__Layer__NoWarnings)
+{
+    /* This is used as a %SIG{__WARN__} handler to supress warnings 
+       during loading of layers.
+     */
+    dXSARGS;
+    if (items)
+       PerlIO_debug("warning:%s\n",SvPV_nolen(ST(0)));
+    XSRETURN(0);
+}
+
 XS(XS_PerlIO__Layer__find)
 {
     dXSARGS;
@@ -1012,6 +1028,7 @@ Perl_boot_core_PerlIO(pTHX)
          __FILE__);
 #endif
     newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
+    newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
 }
 
 PerlIO_funcs *
@@ -2719,7 +2736,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
        even if that would be treated as 0xFF - so will 
        a dup fail ...
      */
-    f->_file = PerlLIO_dup(fd);
+    f->_file = PerlLIO_dup(fileno(f));
 #    endif /* defined(_LP64) */
     return 1;
 #  elif defined(__hpux)
@@ -2778,7 +2795,7 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
         int fd = fileno(stdio);
        int socksfd = 0;
        int invalidate = 0;
-       IV result;
+       IV result = 0;
        int saveerr = 0;
        int dupfd = 0;
 #ifdef SOCKS5_VERSION_NAME
@@ -2813,6 +2830,7 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
               Use Sarathy's trick from maint-5.6 to invalidate the 
               fileno slot of the FILE * 
            */ 
+           result = PerlIO_flush(f);
            saveerr = errno;
            if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
                dupfd = PerlLIO_dup(fd);
@@ -2836,7 +2854,6 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
        }
        return result;
     } 
-
 }
 
 SSize_t
@@ -2844,20 +2861,26 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
     SSize_t got = 0;
-    if (count == 1) {
-       STDCHAR *buf = (STDCHAR *) vbuf;
-       /*
-        * Perl is expecting PerlIO_getc() to fill the buffer Linux's
-        * stdio does not do that for fread()
-        */
-       int ch = PerlSIO_fgetc(s);
-       if (ch != EOF) {
-           *buf = ch;
-           got = 1;
+    for (;;) {
+       if (count == 1) {
+           STDCHAR *buf = (STDCHAR *) vbuf;
+           /*
+            * Perl is expecting PerlIO_getc() to fill the buffer Linux's
+            * stdio does not do that for fread()
+            */
+           int ch = PerlSIO_fgetc(s);
+           if (ch != EOF) {
+               *buf = ch;
+               got = 1;
+           }
        }
+       else
+           got = PerlSIO_fread(vbuf, 1, count, s);
+       if (got || errno != EINTR)
+           break;
+       PERL_ASYNC_CHECK();
+       errno = 0;      /* just in case */
     }
-    else
-       got = PerlSIO_fread(vbuf, 1, count, s);
     return got;
 }
 
@@ -2922,8 +2945,16 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 SSize_t
 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
-    return PerlSIO_fwrite(vbuf, 1, count,
-                         PerlIOSelf(f, PerlIOStdio)->stdio);
+    SSize_t got;
+    for (;;) {
+       got = PerlSIO_fwrite(vbuf, 1, count,
+                             PerlIOSelf(f, PerlIOStdio)->stdio);
+       if (got || errno != EINTR)
+           break;
+       PERL_ASYNC_CHECK();
+       errno = 0;      /* just in case */
+    }
+    return got;
 }
 
 IV