Fix for ungetc() issues flagged by ext/Encode/t/perlio.t on VMS.

[perl5.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index 78d6380..8cfd02f 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -805,6 +805,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
                        Perl_warner(aTHX_ packWARN(WARN_LAYER),
                              "perlio: invalid separator character %c%c%c in layer specification list %s",
                              q, *s, q, s);
+                   SETERRNO(EINVAL, LIB$_INVARG);
                    return -1;
                }
                do {
@@ -1287,8 +1288,13 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
        else {
            av = def;
        }
-       PerlIO_parse_layers(aTHX_ av, layers);
-       return av;
+       if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
+            return av;
+       }
+       else {
+           PerlIO_list_free(aTHX_ av);
+           return (PerlIO_list_t *) NULL;
+       }
     }
     else {
        if (incdef)
@@ -1330,6 +1336,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
        }
        else {
            layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
+           if (!layera) {
+               return NULL;
+           }
        }
        /*
         * Start at "top" of layer stack
@@ -2350,7 +2359,7 @@ PerlIO_funcs PerlIO_unix = {
     sizeof(PerlIOUnix),
     PERLIO_K_RAW,
     PerlIOUnix_pushed,
-    PerlIOBase_noop_ok,
+    PerlIOBase_popped,
     PerlIOUnix_open,
     NULL,
     PerlIOUnix_fileno,
@@ -2623,16 +2632,32 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 SSize_t
 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
-    FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
-    STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
     SSize_t unread = 0;
-    while (count > 0) {
-       int ch = *buf-- & 0xff;
-       if (PerlSIO_ungetc(ch, s) != ch)
-           break;
-       unread++;
-       count--;
+    FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
+
+    if (PerlIO_fast_gets(f)) {
+       STDCHAR *buf = ((STDCHAR *) vbuf) + count;
+       STDCHAR *base = PerlIO_get_base(f);
+       SSize_t cnt   = PerlIO_get_cnt(f);
+       STDCHAR *ptr  = PerlIO_get_ptr(f);
+       SSize_t avail = ptr - base;
+       if (avail > 0) {
+           if (avail > count) {
+               avail = count;
+           }
+           ptr -= avail;
+           Move(buf-avail,ptr,avail,STDCHAR);
+           count -= avail;
+           unread += avail;
+           PerlIO_set_ptrcnt(f,ptr,cnt+avail);
+       }
     }
+
+    if (count > 0) {
+       unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
+    }
+    if (PerlSIO_feof(s) && unread >= 0)
+       PerlSIO_clearerr(s);
     return unread;
 }
 
@@ -2684,24 +2709,6 @@ PerlIOStdio_flush(pTHX_ PerlIO *f)
 }
 
 IV
-PerlIOStdio_fill(pTHX_ PerlIO *f)
-{
-    FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
-    int c;
-    /*
-     * fflush()ing read-only streams can cause trouble on some stdio-s
-     */
-    if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
-       if (PerlSIO_fflush(stdio) != 0)
-           return EOF;
-    }
-    c = PerlSIO_fgetc(stdio);
-    if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
-       return EOF;
-    return 0;
-}
-
-IV
 PerlIOStdio_eof(pTHX_ PerlIO *f)
 {
     return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
@@ -2798,14 +2805,68 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 #endif                          /* STDIO_CNT_LVALUE */
 }
 
+
+#endif
+
+IV
+PerlIOStdio_fill(pTHX_ PerlIO *f)
+{
+    FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+    int c;
+    /*
+     * fflush()ing read-only streams can cause trouble on some stdio-s
+     */
+    if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
+       if (PerlSIO_fflush(stdio) != 0)
+           return EOF;
+    }
+    c = PerlSIO_fgetc(stdio);
+    if (c == EOF)
+       return EOF;
+
+#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
+    if (PerlIO_fast_gets(f)) {
+       /* Fake ungetc() to the real buffer in case system's ungetc
+          goes elsewhere
+        */
+       STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
+       SSize_t cnt   = PerlSIO_get_cnt(stdio);
+       STDCHAR *ptr  = (STDCHAR*)PerlSIO_get_ptr(stdio);
+       if (ptr == base+1) {
+           *--ptr = (STDCHAR) c;
+           PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
+           if (PerlSIO_feof(stdio))
+               PerlSIO_clearerr(stdio);
+           return 0;
+       }
+    }
 #endif
 
+#if defined(VMS)
+    /* An ungetc()d char is handled separately from the regular
+     * buffer, so we stuff it in the buffer ourselves.
+     * Should never get called as should hit code above
+     */
+    *(--((*fp)->_ptr)) = (unsigned char) c;
+    (*fp)->_cnt++;
+#else
+    /* If buffer snoop scheme above fails fall back to
+       using ungetc (but why did "fill" get called?).
+     */
+    if (PerlSIO_ungetc(c, stdio) != c)
+       return EOF;
+#endif
+    return 0;
+}
+
+
+
 PerlIO_funcs PerlIO_stdio = {
     "stdio",
     sizeof(PerlIOStdio),
     PERLIO_K_BUFFERED,
     PerlIOBase_pushed,
-    PerlIOBase_noop_ok,
+    PerlIOBase_popped,
     PerlIOStdio_open,
     NULL,
     PerlIOStdio_fileno,
@@ -3153,6 +3214,9 @@ PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
            PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
        }
     }
+    if (count > 0) {
+       unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
+    }
     return unread;
 }
 
@@ -3234,6 +3298,20 @@ PerlIOBuf_tell(pTHX_ PerlIO *f)
 }
 
 IV
+PerlIOBuf_popped(pTHX_ PerlIO *f)
+{
+    IV code = PerlIOBase_popped(aTHX_ f);
+    PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
+    if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
+       Safefree(b->buf);
+    }
+    b->buf = NULL;
+    b->ptr = b->end = b->buf;
+    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
+    return code;
+}
+
+IV
 PerlIOBuf_close(pTHX_ PerlIO *f)
 {
     IV code = PerlIOBase_close(aTHX_ f);
@@ -3322,7 +3400,7 @@ PerlIO_funcs PerlIO_perlio = {
     sizeof(PerlIOBuf),
     PERLIO_K_BUFFERED,
     PerlIOBuf_pushed,
-    PerlIOBase_noop_ok,
+    PerlIOBuf_popped,
     PerlIOBuf_open,
     NULL,
     PerlIOBase_fileno,
@@ -3443,7 +3521,7 @@ PerlIO_funcs PerlIO_pending = {
     sizeof(PerlIOBuf),
     PERLIO_K_BUFFERED,
     PerlIOPending_pushed,
-    PerlIOBase_noop_ok,
+    PerlIOBuf_popped,
     NULL,
     NULL,
     PerlIOBase_fileno,
@@ -3736,7 +3814,7 @@ PerlIO_funcs PerlIO_crlf = {
     sizeof(PerlIOCrlf),
     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
     PerlIOCrlf_pushed,
-    PerlIOBase_noop_ok,         /* popped */
+    PerlIOBuf_popped,         /* popped */
     PerlIOBuf_open,
     NULL,
     PerlIOBase_fileno,
@@ -4051,7 +4129,7 @@ PerlIO_funcs PerlIO_mmap = {
     sizeof(PerlIOMmap),
     PERLIO_K_BUFFERED,
     PerlIOBuf_pushed,
-    PerlIOBase_noop_ok,
+    PerlIOBuf_popped,
     PerlIOBuf_open,
     NULL,
     PerlIOBase_fileno,