X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=304107bcd3f728291020d39b13ec90366a8161dd;hb=9adaed53e8c5c02c21962f77d92b04411cd1a8b5;hp=23864b56e9e246c4f87583da13aef2e563bb8d2d;hpb=bad9695d2c27e100ff7ed9ad887696aa6f3d6b62;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index 23864b5..304107b 100644
--- 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;