X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=95867507a9f6bb36a91fb837cc83c7ecaa57979a;hb=e66636537be1375e175fdc55f8c556880390711f;hp=0d91fb403f820c3699841e3bea7b6ef7babf1077;hpb=3890ecea71e8d1097fd1d7614b8a095c06dbb4f5;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index 0d91fb4..9586750 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.
  */
 
 /*
@@ -645,9 +648,13 @@ PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
 	int i;
 	list = PerlIO_list_alloc(aTHX);
 	for (i=0; i < proto->cur; i++) {
-	    SV *arg = NULL;
-	    if (proto->array[i].arg)
-		arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
+	    SV *arg = proto->array[i].arg;
+#ifdef sv_dup
+	    if (arg && param)
+		arg = sv_dup(arg, param);
+#else
+	    PERL_UNUSED_ARG(param);
+#endif
 	    PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
 	}
     }
@@ -789,7 +796,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) {
@@ -819,7 +826,8 @@ perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
 	IO * const io = GvIOn((GV *) SvRV(sv));
 	PerlIO * const ifp = IoIFP(io);
 	PerlIO * const ofp = IoOFP(io);
-	Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
+	Perl_warn(aTHX_ "set %" SVf " %p %p %p",
+		  SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
     }
     return 0;
 }
@@ -831,7 +839,8 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 	IO * const io = GvIOn((GV *) SvRV(sv));
 	PerlIO * const ifp = IoIFP(io);
 	PerlIO * const ofp = IoOFP(io);
-	Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
+	Perl_warn(aTHX_ "get %" SVf " %p %p %p",
+		  SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
     }
     return 0;
 }
@@ -839,14 +848,14 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
 static int
 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 {
-    Perl_warn(aTHX_ "clear %" SVf, sv);
+    Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
     return 0;
 }
 
 static int
 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
 {
-    Perl_warn(aTHX_ "free %" SVf, sv);
+    Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
     return 0;
 }
 
@@ -871,7 +880,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
     mg = mg_find(sv, PERL_MAGIC_ext);
     mg->mg_virtual = &perlio_vtab;
     mg_magical(sv);
-    Perl_warn(aTHX_ "attrib %" SVf, sv);
+    Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
     for (i = 2; i < items; i++) {
 	STRLEN len;
 	const char * const name = SvPV_const(ST(i), len);
@@ -893,7 +902,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;
 }
@@ -1013,10 +1022,13 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 		    PerlIO_funcs * const layer =
 			PerlIO_find_layer(aTHX_ s, llen, 1);
 		    if (layer) {
+			SV *arg = NULL;
+			if (as)
+			    arg = newSVpvn(as, alen);
 			PerlIO_list_push(aTHX_ av, layer,
-					 (as) ? newSVpvn(as,
-							 alen) :
-					 &PL_sv_undef);
+					 (arg) ? arg : &PL_sv_undef);
+			if (arg)
+			    SvREFCNT_dec(arg);
 		    }
 		    else {
 			if (ckWARN(WARN_LAYER))
@@ -1491,12 +1503,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
     if (layers && *layers) {
 	PerlIO_list_t *av;
 	if (incdef) {
-	    IV i;
-	    av = PerlIO_list_alloc(aTHX);
-	    for (i = 0; i < def->cur; i++) {
-		PerlIO_list_push(aTHX_ av, def->array[i].funcs,
-				 def->array[i].arg);
-	    }
+	    av = PerlIO_clone_list(aTHX_ def, NULL);
 	}
 	else {
 	    av = def;
@@ -1541,10 +1548,13 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 	    PerlIOl *l = *f;
 	    layera = PerlIO_list_alloc(aTHX);
 	    while (l) {
-		SV * const arg = (l->tab->Getarg)
-			? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
-			: &PL_sv_undef;
-		PerlIO_list_push(aTHX_ layera, l->tab, arg);
+		SV *arg = NULL;
+		if (l->tab->Getarg)
+		    arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
+		PerlIO_list_push(aTHX_ layera, l->tab,
+				 (arg) ? arg : &PL_sv_undef);
+		if (arg)
+		    SvREFCNT_dec(arg);
 		l = *PerlIONext(&l);
 	    }
 	}
@@ -2063,7 +2073,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     }
 #if 0
     PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
-		 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
+		 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
 		 l->flags, PerlIO_modestr(f, temp));
 #endif
     return 0;
@@ -2218,7 +2228,9 @@ PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
 	return NULL;
 #ifdef sv_dup
     if (param) {
-	return sv_dup(arg, param);
+	arg = sv_dup(arg, param);
+	SvREFCNT_inc_simple_void_NN(arg);
+	return arg;
     }
     else {
 	return newSVsv(arg);
@@ -2242,19 +2254,15 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
     }
     if (f) {
 	PerlIO_funcs * const self = PerlIOBase(o)->tab;
-	SV *arg;
+	SV *arg = NULL;
 	char buf[8];
 	PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
 		     self->name, (void*)f, (void*)o, (void*)param);
 	if (self->Getarg)
 	    arg = (*self->Getarg)(aTHX_ o, param, flags);
-	else {
-	    arg = NULL;
-	}
 	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
-	if (arg) {
+	if (arg)
 	    SvREFCNT_dec(arg);
-	}
     }
     return f;
 }
@@ -2278,8 +2286,9 @@ S_more_refcounted_fds(pTHX_ const int new_fd) {
 
     assert (new_max > new_fd);
 
-    new_array =
-	(int*) PerlMemShared_realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
+    /* Use plain realloc() since we need this memory to be really
+     * global and visible to all the interpreters and/or threads. */
+    new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
 
     if (!new_array) {
 #ifdef USE_ITHREADS
@@ -2398,7 +2407,7 @@ PerlIO_cleanup(pTHX)
 
 void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
 {
-    
+    dVAR;
 #ifdef DEBUGGING
     {
 	/* By now all filehandles should have been closed, so any
@@ -2412,23 +2421,16 @@ void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
 	}
     }
 #endif
-#if !defined(WIN32) || !defined(PERL_IMPLICIT_SYS)
-    /* On Windows, under PERL_IMPLICIT_SYS, all memory allocated by
-     * PerlMemShared_...() will be freed anyways when PL_curinterp
-     * is being destroyed. */
+    /* Not bothering with PL_perlio_mutex since by now
+     * all the interpreters are gone. */
     if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
         && PL_perlio_fd_refcnt) {
-	/* Not bothering with PL_perlio_mutex since by now all the
-	 * interpreters are gone. */
-	PerlMemShared_free(PL_perlio_fd_refcnt);
+	free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
 	PL_perlio_fd_refcnt = NULL;
 	PL_perlio_fd_refcnt_size = 0;
     }
-#endif
 }
 
-
-
 /*--------------------------------------------------------------------------------------*/
 /*
  * Bottom-most level for UNIX-like case
@@ -3417,9 +3419,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)))
 
@@ -4264,7 +4272,7 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
 #if 0
     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
-		 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
+		 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
 		 PerlIOBase(f)->flags);
 #endif
     {
@@ -4450,8 +4458,8 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 
 	if (ptr != chk ) {
 	    Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
-		       " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
-		       b->end, cnt);
+		       " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
+		       flags, c->nl, b->end, cnt);
 	}
 #endif
     }