X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=bbb12db702195fe6d7e7a7d9c81ec28b4e792054;hb=fbf638cb2f3422c34f7602c75927b8364ccf21ee;hp=ce20542899ca89f40a8f17877dce0d4febe4ca5b;hpb=a951d81d1408c83245c2beba7e057583534f618e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index ce20542..bbb12db 100644
--- a/perlio.c
+++ b/perlio.c
@@ -1,7 +1,10 @@
 /*
- * perlio.c Copyright (c) 1996-2006, Nick Ing-Simmons You may distribute
- * under the terms of either the GNU General Public License or the
- * Artistic License, as specified in the README file.
+ * perlio.c
+ * Copyright (c) 1996-2006, Nick Ing-Simmons
+ * Copyright (c) 2006, 2007, Larry Wall and others
+ *
+ * You may distribute under the terms of either the GNU General Public License
+ * or the Artistic License, as specified in the README file.
  */
 
 /*
@@ -131,6 +134,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
      */
 #ifdef DOSISH
 #  if defined(atarist) || defined(__MINT__)
+    PERL_UNUSED_ARG(iotype);
     if (!fflush(fp)) {
         if (mode & O_BINARY)
             ((FILE *) fp)->_flag |= _IOBIN;
@@ -141,6 +145,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
     return 0;
 #  else
     dTHX;
+    PERL_UNUSED_ARG(iotype);
 #ifdef NETWARE
     if (PerlLIO_setmode(fp, mode) != -1) {
 #else
@@ -171,6 +176,9 @@ document
 #else
 #  if defined(USEMYBINMODE)
     dTHX;
+#    if defined(__CYGWIN__)
+    PERL_UNUSED_ARG(iotype);
+#    endif
     if (my_binmode(fp, iotype, mode) != FALSE)
         return 1;
     else
@@ -793,7 +801,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
 	} else {
 	    SV * const pkgsv = newSVpvs("PerlIO");
 	    SV * const layer = newSVpvn(name, len);
-	    CV * const cv    = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+	    CV * const cv    = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
 	    ENTER;
 	    SAVEINT(PL_in_load_module);
 	    if (cv) {
@@ -899,7 +907,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
 SV *
 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 {
-    HV * const stash = gv_stashpvs("PerlIO::Layer", TRUE);
+    HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
     SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
     return sv;
 }
@@ -911,6 +919,7 @@ XS(XS_PerlIO__Layer__NoWarnings)
      */
     dVAR;
     dXSARGS;
+    PERL_UNUSED_ARG(cv);
     if (items)
     	PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
     XSRETURN(0);
@@ -920,6 +929,7 @@ XS(XS_PerlIO__Layer__find)
 {
     dVAR;
     dXSARGS;
+    PERL_UNUSED_ARG(cv);
     if (items < 2)
 	Perl_croak(aTHX_ "Usage class->find(name[,load])");
     else {
@@ -2258,6 +2268,8 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 	if (self->Getarg)
 	    arg = (*self->Getarg)(aTHX_ o, param, flags);
 	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+	if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
+	    PerlIOBase(f)->flags |= PERLIO_F_UTF8;
 	if (arg)
 	    SvREFCNT_dec(arg);
     }
@@ -2869,6 +2881,7 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
 	    s = PerlIOSelf(f, PerlIOStdio);
 	    s->stdio = stdio;
+	    PerlIOUnix_refcnt_inc(fileno(stdio));
 	}
     }
     return f;
@@ -3416,9 +3429,15 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
 	if (PerlSIO_fflush(stdio) != 0)
 	    return EOF;
     }
-    c = PerlSIO_fgetc(stdio);
-    if (c == EOF)
-	return EOF;
+    for (;;) {
+	c = PerlSIO_fgetc(stdio);
+	if (c != EOF)
+	    break;
+	if (! PerlSIO_ferror(stdio) || errno != EINTR)
+	    return EOF;
+	PERL_ASYNC_CHECK();
+	SETERRNO(0,0);
+    }
 
 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
 
@@ -3535,6 +3554,7 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
 	    if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
 		PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
 		s->stdio = stdio;
+		PerlIOUnix_refcnt_inc(fileno(stdio));
 		/* Link previous lower layers under new one */
 		*PerlIONext(f) = l;
 	    }
@@ -3574,6 +3594,9 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
 	    PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
 	    if (s->stdio == f) {
 		dTHX;
+		const int fd = fileno(f);
+		if (fd >= 0)
+		    PerlIOUnix_refcnt_dec(fd);
 		PerlIO_pop(aTHX_ p);
 		return;
 	    }
@@ -5077,8 +5100,8 @@ PerlIO_tmpfile(void)
 	  if (f)
 	       PerlIOBase(f)->flags |= PERLIO_F_TEMP;
 	  PerlLIO_unlink(SvPVX_const(sv));
-	  SvREFCNT_dec(sv);
      }
+     SvREFCNT_dec(sv);
 #    else	/* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
      FILE * const stdio = PerlSIO_tmpfile();
 
@@ -5105,30 +5128,30 @@ const char *
 Perl_PerlIO_context_layers(pTHX_ const char *mode)
 {
     dVAR;
-    const char *type = NULL;
+    const char *direction = NULL;
+    SV *layers;
     /*
      * Need to supply default layer info from open.pm
      */
-    if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) {
-	SV * const layers
-	    = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
-				       "open", 4, 0, 0);
-	assert(layers);
-	if (SvOK(layers)) {
-	    STRLEN len;
-	    type = SvPV_const(layers, len);
-	    if (type && mode && mode[0] != 'r') {
-		/*
-		 * Skip to write part, which is separated by a '\0'
-		 */
-		STRLEN read_len = strlen(type);
-		if (read_len < len) {
-		    type += read_len + 1;
-		}
-	    }
-	}
+
+    if (!PL_curcop)
+	return NULL;
+
+    if (mode && mode[0] != 'r') {
+	if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
+	    direction = "open>";
+    } else {
+	if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
+	    direction = "open<";
     }
-    return type;
+    if (!direction)
+	return NULL;
+
+    layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+				      0, direction, 5, 0, 0);
+
+    assert(layers);
+    return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
 }