Mention Solaris x86 use64bitint troubles.

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

diff --git a/perlio.c b/perlio.c
index 23864b5..304107b 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -158,7 +158,11 @@ PerlIO_intmode2str(int rawmode, char *mode, int *writing)
 int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 {
-    if (!names || !*names || strEQ(names, ":crlf") || strEQ(names, ":raw")) {
+    if (!names || !*names
+        || strEQ(names, ":crlf")
+        || strEQ(names, ":raw")
+        || strEQ(names, ":bytes")
+       ) {
        return 0;
     }
     Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
@@ -1099,6 +1103,12 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
        return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
     }
     else {
+       if (*f) {
+           /* Turn off UTF-8-ness, to undo UTF-8 locale effects
+              This may be too simplistic!
+            */
+           PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+       }
        /* FIXME?: Looking down the layer stack seems wrong,
           but is a way of reaching past (say) an encoding layer
           to flip CRLF-ness of the layer(s) below
@@ -1686,7 +1696,7 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
 PerlIO_funcs PerlIO_utf8 = {
     "utf8",
     sizeof(PerlIOl),
-    PERLIO_K_DUMMY | PERLIO_F_UTF8,
+    PERLIO_K_DUMMY | PERLIO_K_UTF8,
     PerlIOUtf8_pushed,
     NULL,
     NULL,
@@ -2388,6 +2398,14 @@ PerlIO_funcs PerlIO_unix = {
  * stdio as a layer
  */
 
+#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
+/* perl5.8 - This ensures the last minute VMS ungetc fix is not
+   broken by the last second glibc 2.3 fix
+ */
+#define STDIO_BUFFER_WRITABLE
+#endif
+
+
 typedef struct {
     struct _PerlIO base;
     FILE *stdio;                /* The stream */
@@ -2446,21 +2464,25 @@ PerlIO_importFILE(FILE *stdio, int fl)
        /* We need to probe to see how we can open the stream
           so start with read/write and then try write and read
           we dup() so that we can fclose without loosing the fd.
+
+          Note that the errno value set by a failing fdopen
+          varies between stdio implementations.
         */
        int fd = PerlLIO_dup(fileno(stdio));
        char *mode = "r+";
        FILE *f2 = fdopen(fd, mode);
        PerlIOStdio *s;
-       if (!f2 && errno == EINVAL) {
+       if (!f2) {
            mode = "w";
            f2 = fdopen(fd, mode);
        }
-       if (!f2 && errno == EINVAL) {
+       if (!f2) {
            mode = "r";
            f2 = fdopen(fd, mode);
        }
        if (!f2) {
            /* Don't seem to be able to open */
+           PerlLIO_close(fd);
            return f;
        }
        fclose(f2);
@@ -2635,7 +2657,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
     SSize_t unread = 0;
     FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
 
-    if (PerlIO_fast_gets(f)) {
+#ifdef STDIO_BUFFER_WRITABLE
+    if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
        STDCHAR *buf = ((STDCHAR *) vbuf) + count;
        STDCHAR *base = PerlIO_get_base(f);
        SSize_t cnt   = PerlIO_get_cnt(f);
@@ -2650,14 +2673,39 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
            count -= avail;
            unread += avail;
            PerlIO_set_ptrcnt(f,ptr,cnt+avail);
+           if (PerlSIO_feof(s) && unread >= 0)
+               PerlSIO_clearerr(s);
+       }
+    }
+    else
+#endif
+    if (PerlIO_has_cntptr(f)) {
+       /* We can get pointer to buffer but not its base
+          Do ungetc() but check chars are ending up in the
+          buffer
+        */
+       STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
+       STDCHAR *buf = ((STDCHAR *) vbuf) + count;
+       while (count > 0) {
+           int ch = *--buf & 0xFF;
+           if (ungetc(ch,s) != ch) {
+               /* ungetc did not work */
+               break;
+           }
+           if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
+               /* Did not change pointer as expected */
+               fgetc(s);  /* get char back again */
+               break;
+           }
+           /* It worked ! */
+           count--;
+           unread++;
        }
     }
 
     if (count > 0) {
        unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
     }
-    if (PerlSIO_feof(s) && unread >= 0)
-       PerlSIO_clearerr(s);
     return unread;
 }
 
@@ -2825,7 +2873,9 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
        return EOF;
 
 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
-    if (PerlIO_fast_gets(f)) {
+
+#ifdef STDIO_BUFFER_WRITABLE
+    if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
        /* Fake ungetc() to the real buffer in case system's ungetc
           goes elsewhere
         */
@@ -2840,6 +2890,14 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
            return 0;
        }
     }
+    else
+#endif
+    if (PerlIO_has_cntptr(f)) {
+       STDCHAR ch = c;
+       if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
+           return 0;
+       }
+    }
 #endif
 
 #if defined(VMS)
@@ -2851,7 +2909,7 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
     (*stdio)->_cnt++;
 #else
     /* If buffer snoop scheme above fails fall back to
-       using ungetc (but why did "fill" get called?).
+       using ungetc().
      */
     if (PerlSIO_ungetc(c, stdio) != c)
        return EOF;
@@ -3075,6 +3133,9 @@ PerlIOBuf_flush(pTHX_ PerlIO *f)
                /* Reload n as some layers may pop themselves on seek */
                b->posn = PerlIO_tell(n = PerlIONext(f));
            }
+           else {
+               return code;
+           }
        }
     }
     b->ptr = b->end = b->buf;