Argh, cut-and-pasto.

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

diff --git a/perlio.c b/perlio.c
index 1067689..dfad448 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -640,6 +640,35 @@ PerlIO_pop(pTHX_ PerlIO *f)
     }
 }
 
+/* Return as an array the stack of layers on a filehandle.  Note that
+ * the stack is returned top-first in the array, and there are three
+ * times as many array elements as there are layers in the stack: the
+ * first element of a layer triplet is the name, the second one is the
+ * arguments, and the third one is the flags. */
+
+AV *
+PerlIO_get_layers(pTHX_ PerlIO *f)
+{
+     AV *av = newAV();
+
+     if (PerlIOValid(f)) {
+         PerlIOl *l = PerlIOBase(f);
+
+         while (l) {
+              SV *name = l->tab && l->tab->name ?
+                   newSVpv(l->tab->name, 0) : &PL_sv_undef;
+              SV *arg = l->tab && l->tab->Getarg ?
+                   (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
+              av_push(av, name);
+              av_push(av, arg);
+              av_push(av, newSViv((IV)l->flags));
+              l = l->next;
+         }
+     }
+
+     return av;
+}
+
 /*--------------------------------------------------------------------------------------*/
 /*
  * XS Interface for perl code
@@ -2736,7 +2765,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)
@@ -2768,6 +2797,10 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
 #  elif defined(WIN32)
 #    if defined(__BORLANDC__)
     f->fd = PerlLIO_dup(fileno(f));
+#    elif defined(UNDER_CE)
+    /* WIN_CE does not have access to FILE internals, it hardly has FILE
+       structure at all
+     */
 #    else
     f->_file = -1;
 #    endif
@@ -2795,7 +2828,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
@@ -2830,6 +2863,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);
@@ -2853,7 +2887,6 @@ PerlIOStdio_close(pTHX_ PerlIO *f)
        }
        return result;
     } 
-
 }
 
 SSize_t
@@ -2861,20 +2894,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;
 }
 
@@ -2939,8 +2978,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
@@ -3180,16 +3227,16 @@ PerlIO_funcs PerlIO_stdio = {
 #ifdef USE_STDIO_PTR
     PerlIOStdio_get_ptr,
     PerlIOStdio_get_cnt,
-#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
-    PerlIOStdio_set_ptrcnt
-#else                           /* STDIO_PTR_LVALUE */
-    NULL
-#endif                          /* STDIO_PTR_LVALUE */
-#else                           /* USE_STDIO_PTR */
+#   if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
+    PerlIOStdio_set_ptrcnt,
+#   else
+    NULL,
+#   endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
+#else
+    NULL,
     NULL,
     NULL,
-    NULL
-#endif                          /* USE_STDIO_PTR */
+#endif /* USE_STDIO_PTR */
 };
 
 /* Note that calls to PerlIO_exportFILE() are reversed using
@@ -3325,7 +3372,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 #ifdef PERLIO_USING_CRLF
 #  ifdef PERLIO_IS_BINMODE_FD
                if (PERLIO_IS_BINMODE_FD(fd))
-                   PerlIO_binmode(f,  '<'/*not used*/, O_BINARY, Nullch);
+                   PerlIO_binmode(aTHX_ f,  '<'/*not used*/, O_BINARY, Nullch);
                else
 #  endif
                /*