X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/94ccb8071447cc02333d411ff69ed91cc131500a..1178b7e3a549517a99a0e9d85bc912c8d535b92d:/perlio.c

diff --git a/perlio.c b/perlio.c
index 5db65b9..0eee430 100644
--- a/perlio.c
+++ b/perlio.c
@@ -70,6 +70,8 @@
 int mkstemp(char*);
 #endif
 
+#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
+
 /* Call the callback or PerlIOBase, and return failure. */
 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) 	\
 	if (PerlIOValid(f)) {					\
@@ -135,7 +137,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
      * This used to be contents of do_binmode in doio.c
      */
 #ifdef DOSISH
-#  if defined(atarist) || defined(__MINT__)
+#  if defined(atarist)
     PERL_UNUSED_ARG(iotype);
     if (!fflush(fp)) {
         if (mode & O_BINARY)
@@ -527,11 +529,47 @@ PerlIO_debug(const char *fmt, ...)
  * Inner level routines
  */
 
+/* check that the head field of each layer points back to the head */
+
+#ifdef DEBUGGING
+#  define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
+static void
+PerlIO_verify_head(pTHX_ PerlIO *f)
+{
+    PerlIOl *head, *p;
+    int seen = 0;
+    if (!PerlIOValid(f))
+	return;
+    p = head = PerlIOBase(f)->head;
+    assert(p);
+    do {
+	assert(p->head == head);
+	if (p == (PerlIOl*)f)
+	    seen = 1;
+	p = p->next;
+    } while (p);
+    assert(seen);
+}
+#else
+#  define VERIFY_HEAD(f)
+#endif
+
+
 /*
  * Table of pointers to the PerlIO structs (malloc'ed)
  */
 #define PERLIO_TABLE_SIZE 64
 
+static void
+PerlIO_init_table(pTHX)
+{
+    if (PL_perlio)
+	return;
+    Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
+}
+
+
+
 PerlIO *
 PerlIO_allocate(pTHX)
 {
@@ -539,24 +577,30 @@ PerlIO_allocate(pTHX)
     /*
      * Find a free slot in the table, allocating new table as necessary
      */
-    PerlIO **last;
-    PerlIO *f;
+    PerlIOl **last;
+    PerlIOl *f;
     last = &PL_perlio;
     while ((f = *last)) {
 	int i;
-	last = (PerlIO **) (f);
+	last = (PerlIOl **) (f);
 	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
-	    if (!*++f) {
-		return f;
+	    if (!((++f)->next)) {
+		f->flags = 0; /* lockcnt */
+		f->tab = NULL;
+		f->head = f;
+		return (PerlIO *)f;
 	    }
 	}
     }
-    Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
+    Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
     if (!f) {
 	return NULL;
     }
-    *last = f;
-    return f + 1;
+    *last = (PerlIOl*) f++;
+    f->flags = 0; /* lockcnt */
+    f->tab = NULL;
+    f->head = f;
+    return (PerlIO*) f;
 }
 
 #undef PerlIO_fdupopen
@@ -579,16 +623,16 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 }
 
 void
-PerlIO_cleantable(pTHX_ PerlIO **tablep)
+PerlIO_cleantable(pTHX_ PerlIOl **tablep)
 {
-    PerlIO * const table = *tablep;
+    PerlIOl * const table = *tablep;
     if (table) {
 	int i;
-	PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
+	PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
 	for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
-	    PerlIO * const f = table + i;
-	    if (*f) {
-		PerlIO_close(f);
+	    PerlIOl * const f = table + i;
+	    if (f->next) {
+		PerlIO_close(&(f->next));
 	    }
 	}
 	Safefree(table);
@@ -614,10 +658,8 @@ PerlIO_list_free(pTHX_ PerlIO_list_t *list)
 	if (--list->refcnt == 0) {
 	    if (list->array) {
 		IV i;
-		for (i = 0; i < list->cur; i++) {
-		    if (list->array[i].arg)
-			SvREFCNT_dec(list->array[i].arg);
-		}
+		for (i = 0; i < list->cur; i++)
+		    SvREFCNT_dec(list->array[i].arg);
 		Safefree(list->array);
 	    }
 	    Safefree(list);
@@ -671,19 +713,19 @@ void
 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
 {
 #ifdef USE_ITHREADS
-    PerlIO **table = &proto->Iperlio;
-    PerlIO *f;
+    PerlIOl **table = &proto->Iperlio;
+    PerlIOl *f;
     PL_perlio = NULL;
     PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
     PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
-    PerlIO_allocate(aTHX); /* root slot is never used */
+    PerlIO_init_table(aTHX);
     PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
     while ((f = *table)) {
 	    int i;
-	    table = (PerlIO **) (f++);
+	    table = (PerlIOl **) (f++);
 	    for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
-		if (*f) {
-		    (void) fp_dup(f, 0, param);
+		if (f->next) {
+		    (void) fp_dup(&(f->next), 0, param);
 		}
 		f++;
 	    }
@@ -699,19 +741,19 @@ void
 PerlIO_destruct(pTHX)
 {
     dVAR;
-    PerlIO **table = &PL_perlio;
-    PerlIO *f;
+    PerlIOl **table = &PL_perlio;
+    PerlIOl *f;
 #ifdef USE_ITHREADS
     PerlIO_debug("Destruct %p\n",(void*)aTHX);
 #endif
     while ((f = *table)) {
 	int i;
-	table = (PerlIO **) (f++);
+	table = (PerlIOl **) (f++);
 	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
-	    PerlIO *x = f;
+	    PerlIO *x = &(f->next);
 	    const PerlIOl *l;
 	    while ((l = *x)) {
-		if (l->tab->kind & PERLIO_K_DESTRUCT) {
+		if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
 		    PerlIO_debug("Destruct popping %s\n", l->tab->name);
 		    PerlIO_flush(x);
 		    PerlIO_pop(aTHX_ x);
@@ -729,9 +771,11 @@ void
 PerlIO_pop(pTHX_ PerlIO *f)
 {
     const PerlIOl *l = *f;
+    VERIFY_HEAD(f);
     if (l) {
-	PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
-	if (l->tab->Popped) {
+	PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
+			    l->tab ? l->tab->name : "(Null)");
+	if (l->tab && l->tab->Popped) {
 	    /*
 	     * If popped returns non-zero do not free its layer structure
 	     * it has either done so itself, or it is shared and still in
@@ -740,8 +784,16 @@ PerlIO_pop(pTHX_ PerlIO *f)
 	    if ((*l->tab->Popped) (aTHX_ f) != 0)
 		return;
 	}
-	*f = l->next;
-	Safefree(l);
+	if (PerlIO_lockcnt(f)) {
+	    /* we're in use; defer freeing the structure */
+	    PerlIOBase(f)->flags = PERLIO_F_CLEARED;
+	    PerlIOBase(f)->tab = NULL;
+	}
+	else {
+	    *f = l->next;
+	    Safefree(l);
+	}
+
     }
 }
 
@@ -807,19 +859,18 @@ 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    = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
+	    CV * const cv    = get_cvs("PerlIO::Layer::NoWarnings", 0);
 	    ENTER;
-	    SAVEINT(PL_in_load_module);
+	    SAVEBOOL(PL_in_load_module);
 	    if (cv) {
 		SAVEGENERICSV(PL_warnhook);
 		PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
 	    }
-	    PL_in_load_module++;
+	    PL_in_load_module = TRUE;
 	    /*
 	     * The two SVs are magically freed by load_module
 	     */
 	    Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
-	    PL_in_load_module--;
 	    LEAVE;
 	    return PerlIO_find_layer(aTHX_ name, len, 0);
 	}
@@ -920,7 +971,7 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
 
 XS(XS_PerlIO__Layer__NoWarnings)
 {
-    /* This is used as a %SIG{__WARN__} handler to supress warnings
+    /* This is used as a %SIG{__WARN__} handler to suppress warnings
        during loading of layers.
      */
     dVAR;
@@ -981,10 +1032,9 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 		     * seen as an invalid separator character.
 		     */
 		    const char q = ((*s == '\'') ? '"' : '\'');
-		    if (ckWARN(WARN_LAYER))
-			Perl_warner(aTHX_ packWARN(WARN_LAYER),
-			      "Invalid separator character %c%c%c in PerlIO layer specification %s",
-			      q, *s, q, s);
+		    Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
+				   "Invalid separator character %c%c%c in PerlIO layer specification %s",
+				   q, *s, q, s);
 		    SETERRNO(EINVAL, LIB_INVARG);
 		    return -1;
 		}
@@ -1018,10 +1068,9 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 			     */
 			case '\0':
 			    e--;
-			    if (ckWARN(WARN_LAYER))
-				Perl_warner(aTHX_ packWARN(WARN_LAYER),
-				      "Argument list not closed for PerlIO layer \"%.*s\"",
-				      (int) (e - s), s);
+			    Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
+					   "Argument list not closed for PerlIO layer \"%.*s\"",
+					   (int) (e - s), s);
 			    return -1;
 			default:
 			    /*
@@ -1040,13 +1089,11 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 			    arg = newSVpvn(as, alen);
 			PerlIO_list_push(aTHX_ av, layer,
 					 (arg) ? arg : &PL_sv_undef);
-			if (arg)
-			    SvREFCNT_dec(arg);
+			SvREFCNT_dec(arg);
 		    }
 		    else {
-			if (ckWARN(WARN_LAYER))
-			    Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
-				  (int) llen, s);
+			Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
+				       (int) llen, s);
 			return -1;
 		    }
 		}
@@ -1207,7 +1254,7 @@ PerlIO_stdstreams(pTHX)
 {
     dVAR;
     if (!PL_perlio) {
-	PerlIO_allocate(aTHX);
+	PerlIO_init_table(aTHX);
 	PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
 	PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
 	PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
@@ -1217,14 +1264,20 @@ PerlIO_stdstreams(pTHX)
 PerlIO *
 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
 {
+    VERIFY_HEAD(f);
     if (tab->fsize != sizeof(PerlIO_funcs)) {
-      mismatch:
-	Perl_croak(aTHX_ "Layer does not match this perl");
+	Perl_croak( aTHX_
+	    "%s (%d) does not match %s (%d)",
+	    "PerlIO layer function table size", tab->fsize,
+	    "size expected by this perl", sizeof(PerlIO_funcs) );
     }
     if (tab->size) {
 	PerlIOl *l;
 	if (tab->size < sizeof(PerlIOl)) {
-	    goto mismatch;
+	    Perl_croak( aTHX_
+		"%s (%d) smaller than %s (%d)",
+		"PerlIO layer instance size", tab->size,
+		"size expected by this perl", sizeof(PerlIOl) );
 	}
 	/* Real layer with a data area */
 	if (f) {
@@ -1234,6 +1287,7 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
 	    if (l) {
 		l->next = *f;
 		l->tab = (PerlIO_funcs*) tab;
+		l->head = ((PerlIOl*)f)->head;
 		*f = l;
 		PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
 			     (void*)f, tab->name,
@@ -1266,7 +1320,7 @@ PerlIOBase_binmode(pTHX_ PerlIO *f)
 {
    if (PerlIOValid(f)) {
 	/* Is layer suitable for raw stream ? */
-	if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
+	if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
 	    /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
 	    PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
 	}
@@ -1295,7 +1349,7 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 	 */
 	t = f;
 	while (t && (l = *t)) {
-	    if (l->tab->Binmode) {
+	    if (l->tab && l->tab->Binmode) {
 		/* Has a handler - normal case */
 		if ((*l->tab->Binmode)(aTHX_ t) == 0) {
 		    if (*t == l) {
@@ -1313,7 +1367,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 	    }
 	}
 	if (PerlIOValid(f)) {
-	    PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
+	    PerlIO_debug(":raw f=%p :%s\n", (void*)f,
+		PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
 	    return 0;
 	}
     }
@@ -1342,6 +1397,8 @@ int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 {
     int code = 0;
+    ENTER;
+    save_scalar(PL_errgv);
     if (f && names) {
 	PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
 	code = PerlIO_parse_layers(aTHX_ layers, names);
@@ -1350,6 +1407,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 	}
 	PerlIO_list_free(aTHX_ layers);
     }
+    LEAVE;
     return code;
 }
 
@@ -1363,7 +1421,8 @@ int
 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 {
     PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
-                 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
+                 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
+		       	PerlIOBase(f)->tab->name : "(Null)",
                  iotype, mode, (names) ? names : "(Null)");
 
     if (names) {
@@ -1390,7 +1449,9 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 		/* Perhaps we should turn on bottom-most aware layer
 		   e.g. Ilya's idea that UNIX TTY could serve
 		 */
-		if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
+		if (PerlIOBase(f)->tab &&
+		    PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
+		{
 		    if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
 			/* Not in text mode - flush any pending stuff and flip it */
 			PerlIO_flush(f);
@@ -1437,6 +1498,9 @@ Perl_PerlIO_close(pTHX_ PerlIO *f)
     const int code = PerlIO__close(aTHX_ f);
     while (PerlIOValid(f)) {
 	PerlIO_pop(aTHX_ f);
+	if (PerlIO_lockcnt(f))
+	    /* we're in use; the 'pop' deferred freeing the structure */
+	    f = PerlIONext(f);
     }
     return code;
 }
@@ -1456,12 +1520,12 @@ PerlIO_layer_from_ref(pTHX_ SV *sv)
     /*
      * For any scalar type load the handler which is bundled with perl
      */
-    if (SvTYPE(sv) < SVt_PVAV) {
+    if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
 	PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
 	/* This isn't supposed to happen, since PerlIO::scalar is core,
 	 * but could happen anyway in smaller installs or with PAR */
-	if (!f && ckWARN(WARN_LAYER))
-	    Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
+	if (!f)
+	    Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
 	return f;
     }
 
@@ -1562,12 +1626,11 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 	    layera = PerlIO_list_alloc(aTHX);
 	    while (l) {
 		SV *arg = NULL;
-		if (l->tab->Getarg)
+		if (l->tab && 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);
+		SvREFCNT_dec(arg);
 		l = *PerlIONext(&l);
 	    }
 	}
@@ -1684,20 +1747,21 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f)
     else {
 	/*
 	 * Is it good API design to do flush-all on NULL, a potentially
-	 * errorneous input? Maybe some magical value (PerlIO*
+	 * erroneous input? Maybe some magical value (PerlIO*
 	 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
 	 * things on fflush(NULL), but should we be bound by their design
 	 * decisions? --jhi
 	 */
-	PerlIO **table = &PL_perlio;
+	PerlIOl **table = &PL_perlio;
+	PerlIOl *ff;
 	int code = 0;
-	while ((f = *table)) {
+	while ((ff = *table)) {
 	    int i;
-	    table = (PerlIO **) (f++);
+	    table = (PerlIOl **) (ff++);
 	    for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
-		if (*f && PerlIO_flush(f) != 0)
+		if (ff->next && PerlIO_flush(&(ff->next)) != 0)
 		    code = -1;
-		f++;
+		ff++;
 	    }
 	}
 	return code;
@@ -1708,17 +1772,17 @@ void
 PerlIOBase_flush_linebuf(pTHX)
 {
     dVAR;
-    PerlIO **table = &PL_perlio;
-    PerlIO *f;
+    PerlIOl **table = &PL_perlio;
+    PerlIOl *f;
     while ((f = *table)) {
 	int i;
-	table = (PerlIO **) (f++);
+	table = (PerlIOl **) (f++);
 	for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
-	    if (*f
-		&& (PerlIOBase(f)->
+	    if (f->next
+		&& (PerlIOBase(&(f->next))->
 		    flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
 		== (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
-		PerlIO_flush(f);
+		PerlIO_flush(&(f->next));
 	    f++;
 	}
     }
@@ -1773,10 +1837,7 @@ PerlIO_has_base(PerlIO *f)
 
 	  if (tab)
 	       return (tab->Get_base != NULL);
-	  SETERRNO(EINVAL, LIB_INVARG);
      }
-     else
-	  SETERRNO(EBADF, SS_IVCHAN);
 
      return 0;
 }
@@ -1784,15 +1845,14 @@ PerlIO_has_base(PerlIO *f)
 int
 PerlIO_fast_gets(PerlIO *f)
 {
-    if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
-	 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
+    if (PerlIOValid(f)) {
+	 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
+	     const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
 
-	 if (tab)
-	      return (tab->Set_ptrcnt != NULL);
-	 SETERRNO(EINVAL, LIB_INVARG);
+	     if (tab)
+		  return (tab->Set_ptrcnt != NULL);
+	 }
     }
-    else
-	 SETERRNO(EBADF, SS_IVCHAN);
 
     return 0;
 }
@@ -1805,10 +1865,7 @@ PerlIO_has_cntptr(PerlIO *f)
 
 	if (tab)
 	     return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
-	  SETERRNO(EINVAL, LIB_INVARG);
     }
-    else
-	 SETERRNO(EBADF, SS_IVCHAN);
 
     return 0;
 }
@@ -1821,10 +1878,7 @@ PerlIO_canset_cnt(PerlIO *f)
 
 	  if (tab)
 	       return (tab->Set_ptrcnt != NULL);
-	  SETERRNO(EINVAL, LIB_INVARG);
     }
-    else
-	 SETERRNO(EBADF, SS_IVCHAN);
 
     return 0;
 }
@@ -1878,7 +1932,7 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
     PERL_UNUSED_ARG(mode);
     PERL_UNUSED_ARG(arg);
     if (PerlIOValid(f)) {
-	if (tab->kind & PERLIO_K_UTF8)
+	if (tab && tab->kind & PERLIO_K_UTF8)
 	    PerlIOBase(f)->flags |= PERLIO_F_UTF8;
 	else
 	    PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
@@ -2047,7 +2101,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 
     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
 		  PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
-    if (tab->Set_ptrcnt != NULL)
+    if (tab && tab->Set_ptrcnt != NULL)
 	l->flags |= PERLIO_F_FASTGETS;
     if (mode) {
 	if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
@@ -2276,14 +2330,14 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 	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)
+		     self ? self->name : "(Null)",
+		     (void*)f, (void*)o, (void*)param);
+	if (self && 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);
+	SvREFCNT_dec(arg);
     }
     return f;
 }
@@ -2477,6 +2531,38 @@ typedef struct {
     int oflags;                 /* open/fcntl flags */
 } PerlIOUnix;
 
+static void
+S_lockcnt_dec(pTHX_ const void* f)
+{
+    PerlIO_lockcnt((PerlIO*)f)--;
+}
+
+
+/* call the signal handler, and if that handler happens to clear
+ * this handle, free what we can and return true */
+
+static bool
+S_perlio_async_run(pTHX_ PerlIO* f) {
+    ENTER;
+    SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
+    PerlIO_lockcnt(f)++;
+    PERL_ASYNC_CHECK();
+    if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
+	return 0;
+    /* we've just run some perl-level code that could have done
+     * anything, including closing the file or clearing this layer.
+     * If so, free any lower layers that have already been
+     * cleared, then return an error. */
+    while (PerlIOValid(f) &&
+	    (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
+    {
+	const PerlIOl *l = *f;
+	*f = l->next;
+	Safefree(l);
+    }
+    return 1;
+}
+
 int
 PerlIOUnix_oflags(const char *mode)
 {
@@ -2609,7 +2695,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 		int perm, PerlIO *f, int narg, SV **args)
 {
     if (PerlIOValid(f)) {
-	if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+	if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
 	    (*PerlIOBase(f)->tab->Close)(aTHX_ f);
     }
     if (narg > 0) {
@@ -2617,7 +2703,11 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 	    mode++;
 	else {
 	    imode = PerlIOUnix_oflags(mode);
+#ifdef VMS
+	    perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
+#else
 	    perm = 0666;
+#endif
 	}
 	if (imode != -1) {
 	    const char *path = SvPV_nolen_const(*args);
@@ -2676,7 +2766,10 @@ SSize_t
 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
     dVAR;
-    const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+    int fd;
+    if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+	return -1;
+    fd = PerlIOSelf(f, PerlIOUnix)->fd;
 #ifdef PERLIO_STD_SPECIAL
     if (fd == 0)
         return PERLIO_STD_IN(fd, vbuf, count);
@@ -2699,7 +2792,9 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 	    }
 	    return len;
 	}
-	PERL_ASYNC_CHECK();
+	/* EINTR */
+	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+	    return -1;
     }
     /*NOTREACHED*/
 }
@@ -2708,7 +2803,10 @@ SSize_t
 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
     dVAR;
-    const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+    int fd;
+    if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+	return -1;
+    fd = PerlIOSelf(f, PerlIOUnix)->fd;
 #ifdef PERLIO_STD_SPECIAL
     if (fd == 1 || fd == 2)
         return PERLIO_STD_OUT(fd, vbuf, count);
@@ -2723,7 +2821,9 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    return len;
 	}
-	PERL_ASYNC_CHECK();
+	/* EINTR */
+	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+	    return -1;
     }
     /*NOTREACHED*/
 }
@@ -2758,7 +2858,9 @@ PerlIOUnix_close(pTHX_ PerlIO *f)
 	    code = -1;
 	    break;
 	}
-	PERL_ASYNC_CHECK();
+	/* EINTR */
+	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+	    return -1;
     }
     if (code == 0) {
 	PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
@@ -3033,7 +3135,9 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
     	stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
     set_this:
 	PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
-	PerlIOUnix_refcnt_inc(fileno(stdio));
+        if(stdio) {
+	    PerlIOUnix_refcnt_inc(fileno(stdio));
+        }
     }
     return f;
 }
@@ -3229,8 +3333,11 @@ SSize_t
 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 {
     dVAR;
-    FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
+    FILE * s;
     SSize_t got = 0;
+    if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+	return -1;
+    s = PerlIOSelf(f, PerlIOStdio)->stdio;
     for (;;) {
 	if (count == 1) {
 	    STDCHAR *buf = (STDCHAR *) vbuf;
@@ -3250,7 +3357,8 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 	    got = -1;
 	if (got >= 0 || errno != EINTR)
 	    break;
-	PERL_ASYNC_CHECK();
+	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+	    return -1;
 	SETERRNO(0,0);	/* just in case */
     }
     return got;
@@ -3319,12 +3427,15 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 {
     dVAR;
     SSize_t got;
+    if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+	return -1;
     for (;;) {
 	got = PerlSIO_fwrite(vbuf, 1, count,
 			      PerlIOSelf(f, PerlIOStdio)->stdio);
 	if (got >= 0 || errno != EINTR)
 	    break;
-	PERL_ASYNC_CHECK();
+	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+	    return -1;
 	SETERRNO(0,0);	/* just in case */
     }
     return got;
@@ -3486,9 +3597,12 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 IV
 PerlIOStdio_fill(pTHX_ PerlIO *f)
 {
-    FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+    FILE * stdio;
     int c;
     PERL_UNUSED_CONTEXT;
+    if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+	return -1;
+    stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
 
     /*
      * fflush()ing read-only streams can cause trouble on some stdio-s
@@ -3503,7 +3617,8 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
 	    break;
 	if (! PerlSIO_ferror(stdio) || errno != EINTR)
 	    return EOF;
-	PERL_ASYNC_CHECK();
+	if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+	    return -1;
 	SETERRNO(0,0);
     }
 
@@ -3651,7 +3766,7 @@ PerlIO_findFILE(PerlIO *f)
     /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
     /* However, we're not really exporting a FILE * to someone else (who
        becomes responsible for closing it, or calling PerlIO_releaseFILE())
-       So we need to undo its refernce count increase on the underlying file
+       So we need to undo its reference count increase on the underlying file
        descriptor. We have to do this, because if the loop above returns you
        the FILE *, then *it* didn't increase any reference count. So there's
        only one way to be consistent. */
@@ -3766,6 +3881,22 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 		 */
 		PerlLIO_setmode(fd, O_BINARY);
 #endif
+#ifdef VMS
+#include <rms.h>
+		/* Enable line buffering with record-oriented regular files
+		 * so we don't introduce an extraneous record boundary when
+		 * the buffer fills up.
+		 */
+		if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
+		    Stat_t st;
+		    if (PerlLIO_fstat(fd, &st) == 0
+		        && S_ISREG(st.st_mode)
+		        && (st.st_fab_rfm == FAB$C_VAR 
+			    || st.st_fab_rfm == FAB$C_VFC)) {
+			PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
+		    }
+		}
+#endif
 	    }
 	}
     }
@@ -4019,7 +4150,8 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 		PerlIO_flush(f);
 	}
 	if (b->ptr >= (b->buf + b->bufsiz))
-	    PerlIO_flush(f);
+	    if (PerlIO_flush(f) == -1)
+		return -1;
     }
     if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
 	PerlIO_flush(f);
@@ -4125,8 +4257,8 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f)
 
     if (!b->buf) {
 	if (!b->bufsiz)
-	    b->bufsiz = 4096;
-	b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
+	    b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
+	Newxz(b->buf,b->bufsiz, STDCHAR);
 	if (!b->buf) {
 	    b->buf = (STDCHAR *) & b->oneword;
 	    b->bufsiz = sizeof(b->oneword);
@@ -4529,7 +4661,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 	if (c->nl) {
 	    ptr = c->nl + 1;
 	    if (ptr == b->end && *c->nl == 0xd) {
-		/* Defered CR at end of buffer case - we lied about count */
+		/* Deferred CR at end of buffer case - we lied about count */
 		ptr--;
 	    }
 	}
@@ -4547,7 +4679,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 	IV flags = PerlIOBase(f)->flags;
 	STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
 	if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
-	  /* Defered CR at end of buffer case - we lied about count */
+	  /* Deferred CR at end of buffer case - we lied about count */
 	  chk--;
 	}
 	chk -= cnt;
@@ -4977,7 +5109,7 @@ Perl_PerlIO_stdin(pTHX)
     if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
-    return &PL_perlio[1];
+    return (PerlIO*)&PL_perlio[1];
 }
 
 PerlIO *
@@ -4987,7 +5119,7 @@ Perl_PerlIO_stdout(pTHX)
     if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
-    return &PL_perlio[2];
+    return (PerlIO*)&PL_perlio[2];
 }
 
 PerlIO *
@@ -4997,7 +5129,7 @@ Perl_PerlIO_stderr(pTHX)
     if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
-    return &PL_perlio[3];
+    return (PerlIO*)&PL_perlio[3];
 }
 
 /*--------------------------------------------------------------------------------------*/
@@ -5170,16 +5302,29 @@ PerlIO_tmpfile(void)
 	  f = PerlIO_fdopen(fd, "w+b");
 #else /* WIN32 */
 #    if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
-     SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
+     int fd = -1;
+     char tempname[] = "/tmp/PerlIO_XXXXXX";
+     const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
+     SV * sv = NULL;
      /*
       * I have no idea how portable mkstemp() is ... NI-S
       */
-     const int fd = mkstemp(SvPVX(sv));
+     if (tmpdir && *tmpdir) {
+	 /* if TMPDIR is set and not empty, we try that first */
+	 sv = newSVpv(tmpdir, 0);
+	 sv_catpv(sv, tempname + 4);
+	 fd = mkstemp(SvPVX(sv));
+     }
+     if (fd < 0) {
+	 sv = NULL;
+	 /* else we try /tmp */
+	 fd = mkstemp(tempname);
+     }
      if (fd >= 0) {
 	  f = PerlIO_fdopen(fd, "w+");
 	  if (f)
 	       PerlIOBase(f)->flags |= PERLIO_F_TEMP;
-	  PerlLIO_unlink(SvPVX_const(sv));
+	  PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
      }
      SvREFCNT_dec(sv);
 #    else	/* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
@@ -5227,8 +5372,7 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode)
     if (!direction)
 	return NULL;
 
-    layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
-				      0, direction, 5, 0, 0);
+    layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
 
     assert(layers);
     return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;