X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e0fa5af24242618e2201252ebce12dfc87892dd1..5f74f29c8f6f417d66c92da59fd3fa4b09850be6:/perlio.c

diff --git a/perlio.c b/perlio.c
index 963601a..7c16e43 100644
--- a/perlio.c
+++ b/perlio.c
@@ -38,12 +38,12 @@
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
-#include "XSUB.h"
+#ifdef PERL_IMPLICIT_CONTEXT
+#undef dSYS
+#define dSYS dTHX
+#endif
 
-#undef PerlMemShared_calloc
-#define PerlMemShared_calloc(x,y) calloc(x,y)
-#undef PerlMemShared_free
-#define PerlMemShared_free(x) free(x)
+#include "XSUB.h"
 
 int
 perlsio_binmode(FILE *fp, int iotype, int mode)
@@ -99,6 +99,55 @@ perlsio_binmode(FILE *fp, int iotype, int mode)
 #endif
 }
 
+#ifndef O_ACCMODE
+#define O_ACCMODE 3		/* Assume traditional implementation */
+#endif
+
+int
+PerlIO_intmode2str(int rawmode, char *mode, int *writing)
+{
+    int result = rawmode & O_ACCMODE;
+    int ix = 0;
+    int ptype;
+    switch (result) {
+    case O_RDONLY:
+	ptype = IoTYPE_RDONLY;
+	break;
+    case O_WRONLY:
+	ptype = IoTYPE_WRONLY;
+	break;
+    case O_RDWR:
+    default:
+	ptype = IoTYPE_RDWR;
+	break;
+    }
+    if (writing)
+	*writing = (result != O_RDONLY);
+
+    if (result == O_RDONLY) {
+	mode[ix++] = 'r';
+    }
+#ifdef O_APPEND
+    else if (rawmode & O_APPEND) {
+	mode[ix++] = 'a';
+	if (result != O_WRONLY)
+	    mode[ix++] = '+';
+    }
+#endif
+    else {
+	if (result == O_WRONLY)
+	    mode[ix++] = 'w';
+	else {
+	    mode[ix++] = 'r';
+	    mode[ix++] = '+';
+	}
+    }
+    if (rawmode & O_BINARY)
+	mode[ix++] = 'b';
+    mode[ix] = '\0';
+    return ptype;
+}
+
 #ifndef PERLIO_LAYERS
 int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
@@ -129,19 +178,24 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 }
 
 PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 {
+#ifndef PERL_MICRO
     if (f) {
 	int fd = PerlLIO_dup(PerlIO_fileno(f));
 	if (fd >= 0) {
+	    char mode[8];
+	    int omode = fcntl(fd, F_GETFL);
+	    PerlIO_intmode2str(omode,mode,NULL);
 	    /* the r+ is a hack */
-	    return PerlIO_fdopen(fd, "r+");
+	    return PerlIO_fdopen(fd, mode);
 	}
 	return NULL;
     }
     else {
 	SETERRNO(EBADF, SS$_IVCHAN);
     }
+#endif
     return NULL;
 }
 
@@ -204,7 +258,7 @@ Perl_boot_core_PerlIO(pTHX)
 #ifdef PERLIO_IS_STDIO
 
 void
-PerlIO_init(void)
+PerlIO_init(pTHX)
 {
     /*
      * Does nothing (yet) except force this file to be included in perl
@@ -241,7 +295,7 @@ PerlIO_tmpfile(void)
 }
 
 void
-PerlIO_init(void)
+PerlIO_init(pTHX)
 {
     /*
      * Force this file to be included in perl binary. Which allows this
@@ -358,11 +412,8 @@ PerlIO_debug(const char *fmt, ...)
 /*
  * Table of pointers to the PerlIO structs (malloc'ed)
  */
-PerlIO *_perlio = NULL;
 #define PERLIO_TABLE_SIZE 64
 
-
-
 PerlIO *
 PerlIO_allocate(pTHX)
 {
@@ -371,7 +422,7 @@ PerlIO_allocate(pTHX)
      */
     PerlIO **last;
     PerlIO *f;
-    last = &_perlio;
+    last = &PL_perlio;
     while ((f = *last)) {
 	int i;
 	last = (PerlIO **) (f);
@@ -381,7 +432,7 @@ PerlIO_allocate(pTHX)
 	    }
 	}
     }
-    f = PerlMemShared_calloc(PERLIO_TABLE_SIZE, sizeof(PerlIO));
+    Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
     if (!f) {
 	return NULL;
     }
@@ -389,6 +440,23 @@ PerlIO_allocate(pTHX)
     return f + 1;
 }
 
+#undef PerlIO_fdupopen
+PerlIO *
+PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
+{
+    if (f && *f) {
+	PerlIO_funcs *tab = PerlIOBase(f)->tab;
+	PerlIO *new;
+	PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
+        new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
+	return new;
+    }
+    else {
+	SETERRNO(EBADF, SS$_IVCHAN);
+	return NULL;
+    }
+}
+
 void
 PerlIO_cleantable(pTHX_ PerlIO **tablep)
 {
@@ -402,16 +470,14 @@ PerlIO_cleantable(pTHX_ PerlIO **tablep)
 		PerlIO_close(f);
 	    }
 	}
-	PerlMemShared_free(table);
+	Safefree(table);
 	*tablep = NULL;
     }
 }
 
-PerlIO_list_t *PerlIO_known_layers;
-PerlIO_list_t *PerlIO_def_layerlist;
 
 PerlIO_list_t *
-PerlIO_list_alloc(void)
+PerlIO_list_alloc(pTHX)
 {
     PerlIO_list_t *list;
     Newz('L', list, 1, PerlIO_list_t);
@@ -420,12 +486,11 @@ PerlIO_list_alloc(void)
 }
 
 void
-PerlIO_list_free(PerlIO_list_t *list)
+PerlIO_list_free(pTHX_ PerlIO_list_t *list)
 {
     if (list) {
 	if (--list->refcnt == 0) {
 	    if (list->array) {
-		dTHX;
 		IV i;
 		for (i = 0; i < list->cur; i++) {
 		    if (list->array[i].arg)
@@ -439,9 +504,8 @@ PerlIO_list_free(PerlIO_list_t *list)
 }
 
 void
-PerlIO_list_push(PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
+PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
 {
-    dTHX;
     PerlIO_pair_t *p;
     if (list->cur >= list->len) {
 	list->len += 8;
@@ -457,28 +521,55 @@ PerlIO_list_push(PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
     }
 }
 
-
-void
-PerlIO_cleanup_layers(pTHX_ void *data)
+PerlIO_list_t *
+PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
 {
-#if 0
-    PerlIO_known_layers = Nullhv;
-    PerlIO_def_layerlist = Nullav;
-#endif
+    PerlIO_list_t *list = (PerlIO_list_t *) NULL;
+    if (proto) {
+	int i;
+	list = PerlIO_list_alloc(aTHX);
+	for (i=0; i < proto->cur; i++) {
+	    SV *arg = Nullsv;
+	    if (proto->array[i].arg)
+		arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
+	    PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
+	}
+    }
+    return list;
 }
 
 void
-PerlIO_cleanup()
+PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
 {
-    dTHX;
-    PerlIO_cleantable(aTHX_ & _perlio);
+#ifdef USE_ITHREADS
+    PerlIO **table = &proto->Iperlio;
+    PerlIO *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_debug("Clone %p from %p\n",aTHX,proto);
+    while ((f = *table)) {
+	    int i;
+	    table = (PerlIO **) (f++);
+	    for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
+		if (*f) {
+		    (void) fp_dup(f, 0, param);
+		}
+		f++;
+	    }
+	}
+#endif
 }
 
 void
 PerlIO_destruct(pTHX)
 {
-    PerlIO **table = &_perlio;
+    PerlIO **table = &PL_perlio;
     PerlIO *f;
+#ifdef USE_ITHREADS
+    PerlIO_debug("Destruct %p\n",aTHX);
+#endif
     while ((f = *table)) {
 	int i;
 	table = (PerlIO **) (f++);
@@ -498,6 +589,10 @@ PerlIO_destruct(pTHX)
 	    f++;
 	}
     }
+    PerlIO_list_free(aTHX_ PL_known_layers);
+    PL_known_layers = NULL;
+    PerlIO_list_free(aTHX_ PL_def_layerlist);
+    PL_def_layerlist = NULL;
 }
 
 void
@@ -516,7 +611,7 @@ PerlIO_pop(pTHX_ PerlIO *f)
 		return;
 	}
 	*f = l->next;;
-	PerlMemShared_free(l);
+	Safefree(l);
     }
 }
 
@@ -531,15 +626,15 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
     IV i;
     if ((SSize_t) len <= 0)
 	len = strlen(name);
-    for (i = 0; i < PerlIO_known_layers->cur; i++) {
-	PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
+    for (i = 0; i < PL_known_layers->cur; i++) {
+	PerlIO_funcs *f = PL_known_layers->array[i].funcs;
 	if (memEQ(f->name, name, len)) {
 	    PerlIO_debug("%.*s => %p\n", (int) len, name, f);
 	    return f;
 	}
     }
-    if (load && PL_subname && PerlIO_def_layerlist
-	&& PerlIO_def_layerlist->cur >= 2) {
+    if (load && PL_subname && PL_def_layerlist
+	&& PL_def_layerlist->cur >= 2) {
 	SV *pkgsv = newSVpvn("PerlIO", 6);
 	SV *layer = newSVpvn(name, len);
 	ENTER;
@@ -662,9 +757,9 @@ XS(XS_PerlIO__Layer__find)
 void
 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 {
-    if (!PerlIO_known_layers)
-	PerlIO_known_layers = PerlIO_list_alloc();
-    PerlIO_list_push(PerlIO_known_layers, tab, Nullsv);
+    if (!PL_known_layers)
+	PL_known_layers = PerlIO_list_alloc(aTHX);
+    PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
     PerlIO_debug("define %s %p\n", tab->name, tab);
 }
 
@@ -689,8 +784,8 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 		     */
 		    char q = ((*s == '\'') ? '"' : '\'');
 		    Perl_warn(aTHX_
-			      "perlio: invalid separator character %c%c%c in layer specification list",
-			      q, *s, q);
+			      "perlio: invalid separator character %c%c%c in layer specification list %s",
+			      q, *s, q, s);
 		    return -1;
 		}
 		do {
@@ -739,7 +834,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
 		    PerlIO_funcs *layer =
 			PerlIO_find_layer(aTHX_ s, llen, 1);
 		    if (layer) {
-			PerlIO_list_push(av, layer,
+			PerlIO_list_push(aTHX_ av, layer,
 					 (as) ? newSVpvn(as,
 							 alen) :
 					 &PL_sv_undef);
@@ -770,7 +865,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
 	}
     }
     PerlIO_debug("Pushing %s\n", tab->name);
-    PerlIO_list_push(av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
+    PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
 		     &PL_sv_undef);
 }
 
@@ -796,10 +891,10 @@ PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
 PerlIO_list_t *
 PerlIO_default_layers(pTHX)
 {
-    if (!PerlIO_def_layerlist) {
+    if (!PL_def_layerlist) {
 	const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
 	PerlIO_funcs *osLayer = &PerlIO_unix;
-	PerlIO_def_layerlist = PerlIO_list_alloc();
+	PL_def_layerlist = PerlIO_list_alloc(aTHX);
 	PerlIO_define_layer(aTHX_ & PerlIO_unix);
 #if defined(WIN32) && !defined(UNDER_CE)
 	PerlIO_define_layer(aTHX_ & PerlIO_win32);
@@ -816,20 +911,20 @@ PerlIO_default_layers(pTHX)
 #endif
 	PerlIO_define_layer(aTHX_ & PerlIO_utf8);
 	PerlIO_define_layer(aTHX_ & PerlIO_byte);
-	PerlIO_list_push(PerlIO_def_layerlist,
+	PerlIO_list_push(aTHX_ PL_def_layerlist,
 			 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
 			 &PL_sv_undef);
 	if (s) {
-	    PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist, s);
+	    PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
 	}
 	else {
-	    PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
+	    PerlIO_default_buffer(aTHX_ PL_def_layerlist);
 	}
     }
-    if (PerlIO_def_layerlist->cur < 2) {
-	PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
+    if (PL_def_layerlist->cur < 2) {
+	PerlIO_default_buffer(aTHX_ PL_def_layerlist);
     }
-    return PerlIO_def_layerlist;
+    return PL_def_layerlist;
 }
 
 void
@@ -857,7 +952,7 @@ PerlIO_default_layer(pTHX_ I32 n)
 void
 PerlIO_stdstreams(pTHX)
 {
-    if (!_perlio) {
+    if (!PL_perlio) {
 	PerlIO_allocate(aTHX);
 	PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
 	PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
@@ -869,7 +964,7 @@ PerlIO *
 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
 {
     PerlIOl *l = NULL;
-    l = PerlMemShared_calloc(tab->size, sizeof(char));
+    Newc('L',l,tab->size,char,PerlIOl);
     if (l) {
 	Zero(l, tab->size, char);
 	l->next = *f;
@@ -955,12 +1050,12 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 {
     int code = 0;
     if (names) {
-	PerlIO_list_t *layers = PerlIO_list_alloc();
+	PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
 	code = PerlIO_parse_layers(aTHX_ layers, names);
 	if (code == 0) {
 	    code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
 	}
-	PerlIO_list_free(layers);
+	PerlIO_list_free(aTHX_ layers);
     }
     return code;
 }
@@ -977,16 +1072,19 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
     PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
 		 f, PerlIOBase(f)->tab->name, iotype, mode,
 		 (names) ? names : "(Null)");
-    PerlIO_flush(f);
-    if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) {
-	PerlIO *top = f;
-	while (*top) {
-	    if (PerlIOBase(top)->tab == &PerlIO_crlf) {
-		PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
-		break;
+    /* Can't flush if switching encodings. */
+    if (!(names && memEQ(names, ":encoding(", 10))) {
+        PerlIO_flush(f);
+	if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) {
+	    PerlIO *top = f;
+	    while (*top) {
+	        if (PerlIOBase(top)->tab == &PerlIO_crlf) {
+		  PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
+		  break;
+		}
+		top = PerlIONext(top);
+		PerlIO_flush(top);
 	    }
-	    top = PerlIONext(top);
-	    PerlIO_flush(top);
 	}
     }
     return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
@@ -1004,23 +1102,6 @@ PerlIO__close(PerlIO *f)
     }
 }
 
-#undef PerlIO_fdupopen
-PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
-{
-    if (f && *f) {
-	PerlIO_funcs *tab = PerlIOBase(f)->tab;
-	PerlIO *new;
-	PerlIO_debug("fdupopen f=%p param=%p\n",f,param);
-        new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param);
-	return new;
-    }
-    else {
-	SETERRNO(EBADF, SS$_IVCHAN);
-	return NULL;
-    }
-}
-
 #undef PerlIO_close
 int
 PerlIO_close(PerlIO *f)
@@ -1105,7 +1186,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
 {
     PerlIO_list_t *def = PerlIO_default_layers(aTHX);
     int incdef = 1;
-    if (!_perlio)
+    if (!PL_perlio)
 	PerlIO_stdstreams(aTHX);
     if (narg) {
 	SV *arg = *args;
@@ -1116,8 +1197,8 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
 	if (SvROK(arg) && !sv_isobject(arg)) {
 	    PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
 	    if (handler) {
-		def = PerlIO_list_alloc();
-		PerlIO_list_push(def, handler, &PL_sv_undef);
+		def = PerlIO_list_alloc(aTHX);
+		PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
 		incdef = 0;
 	    }
 	    /*
@@ -1133,9 +1214,9 @@ PerlIO_resolve_layers(pTHX_ const char *layers,
 	PerlIO_list_t *av;
 	if (incdef) {
 	    IV i = def->cur;
-	    av = PerlIO_list_alloc();
+	    av = PerlIO_list_alloc(aTHX);
 	    for (i = 0; i < def->cur; i++) {
-		PerlIO_list_push(av, def->array[i].funcs,
+		PerlIO_list_push(aTHX_ av, def->array[i].funcs,
 				 def->array[i].arg);
 	    }
 	}
@@ -1174,12 +1255,12 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 	     * yet
 	     */
 	    PerlIOl *l = *f;
-	    layera = PerlIO_list_alloc();
+	    layera = PerlIO_list_alloc(aTHX);
 	    while (l) {
 		SV *arg =
 		    (l->tab->Getarg) ? (*l->tab->
-					Getarg) (&l) : &PL_sv_undef;
-		PerlIO_list_push(layera, l->tab, arg);
+					Getarg) (aTHX_ &l, NULL, 0) : &PL_sv_undef;
+		PerlIO_list_push(aTHX_ layera, l->tab, arg);
 		l = *PerlIONext(&l);
 	    }
 	}
@@ -1220,7 +1301,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 		}
 	    }
 	}
-	PerlIO_list_free(layera);
+	PerlIO_list_free(aTHX_ layera);
     }
     return f;
 }
@@ -1342,7 +1423,8 @@ PerlIO_flush(PerlIO *f)
 	 * things on fflush(NULL), but should we be bound by their design
 	 * decisions? --jhi
 	 */
-	PerlIO **table = &_perlio;
+	dTHX;
+	PerlIO **table = &PL_perlio;
 	int code = 0;
 	while ((f = *table)) {
 	    int i;
@@ -1360,7 +1442,8 @@ PerlIO_flush(PerlIO *f)
 void
 PerlIOBase_flush_linebuf()
 {
-    PerlIO **table = &_perlio;
+    dTHX;
+    PerlIO **table = &PL_perlio;
     PerlIO *f;
     while ((f = *table)) {
 	int i;
@@ -1875,6 +1958,112 @@ PerlIOBase_setlinebuf(PerlIO *f)
     }
 }
 
+SV *
+PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
+{
+    if (!arg)
+	return Nullsv;
+#ifdef sv_dup
+    if (param) {
+	return sv_dup(arg, param);
+    }
+    else {
+	return newSVsv(arg);
+    }
+#else
+    return newSVsv(arg);
+#endif
+}
+
+PerlIO *
+PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
+{
+    PerlIO *nexto = PerlIONext(o);
+    if (*nexto) {
+	PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
+	f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
+    }
+    if (f) {
+	PerlIO_funcs *self = PerlIOBase(o)->tab;
+	SV *arg = Nullsv;
+	char buf[8];
+	PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
+	if (self->Getarg) {
+	    arg = (*self->Getarg)(aTHX_ o,param,flags);
+	}
+	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
+	if (arg) {
+	    SvREFCNT_dec(arg);
+	}
+    }
+    return f;
+}
+
+#define PERLIO_MAX_REFCOUNTABLE_FD 2048
+#ifdef USE_THREADS
+perl_mutex PerlIO_mutex;
+#endif
+int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
+
+void
+PerlIO_init(pTHX)
+{
+ /* Place holder for stdstreams call ??? */
+#ifdef USE_THREADS
+ MUTEX_INIT(&PerlIO_mutex);
+#endif
+}
+
+void
+PerlIOUnix_refcnt_inc(int fd)
+{
+    if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+#ifdef USE_THREADS
+	MUTEX_LOCK(&PerlIO_mutex);
+#endif
+	PerlIO_fd_refcnt[fd]++;
+	PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
+#ifdef USE_THREADS
+	MUTEX_UNLOCK(&PerlIO_mutex);
+#endif
+    }
+}
+
+int
+PerlIOUnix_refcnt_dec(int fd)
+{
+    int cnt = 0;
+    if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+#ifdef USE_THREADS
+	MUTEX_LOCK(&PerlIO_mutex);
+#endif
+	cnt = --PerlIO_fd_refcnt[fd];
+	PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
+#ifdef USE_THREADS
+	MUTEX_UNLOCK(&PerlIO_mutex);
+#endif
+    }
+    return cnt;
+}
+
+void
+PerlIO_cleanup(pTHX)
+{
+    int i;
+#ifdef USE_ITHREADS
+    PerlIO_debug("Cleanup %p\n",aTHX);
+#endif
+    /* Raise STDIN..STDERR refcount so we don't close them */
+    for (i=0; i < 3; i++)
+	PerlIOUnix_refcnt_inc(i);
+    PerlIO_cleantable(aTHX_ &PL_perlio);
+    /* Restore STDIN..STDERR refcount */
+    for (i=0; i < 3; i++)
+	PerlIOUnix_refcnt_dec(i);
+}
+
+
+
 /*--------------------------------------------------------------------------------------*/
 /*
  * Bottom-most level for UNIX-like case
@@ -1952,8 +2141,8 @@ IV
 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
 {
     IV code = PerlIOBase_pushed(f, mode, arg);
+    PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
     if (*PerlIONext(f)) {
-	PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
 	s->fd = PerlIO_fileno(PerlIONext(f));
 	/*
 	 * XXX could (or should) we retrieve the oflags from the open file
@@ -2001,6 +2190,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 	s->fd = fd;
 	s->oflags = imode;
 	PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+        PerlIOUnix_refcnt_inc(fd);
 	return f;
     }
     else {
@@ -2013,66 +2203,23 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     }
 }
 
-SV *
-PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
-{
-    if (!arg)
-	return Nullsv;
-#ifdef sv_dup
-    if (param) {
-	return sv_dup(arg, param);
-    }
-    else {
-	return newSVsv(arg);
-    }
-#else
-    return newSVsv(arg);
-#endif
-}
-
 PerlIO *
-PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
-{
-    PerlIO *nexto = PerlIONext(o);
-    if (*nexto) {
-	PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
-	f = (*tab->Dup)(aTHX_ f, nexto, param);
-    }
-    if (f) {
-	PerlIO_funcs *self = PerlIOBase(o)->tab;
-	SV *arg = Nullsv;
-	char buf[8];
-	PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",self->name,f,o,param);
-	if (self->Getarg) {
-	    arg = (*self->Getarg)(o);
-	    if (arg) {
-		arg = PerlIO_sv_dup(aTHX_ arg, param);
-	    }
-	}
-	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
-	if (!f && arg) {
-	    SvREFCNT_dec(arg);
-	}
-    }
-    return f;
-}
-
-PerlIO *
-PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
     PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
-    int fd = PerlLIO_dup(os->fd);
-    if (fd >= 0) {
-	f = PerlIOBase_dup(aTHX_ f, o, param);
+    int fd = os->fd;
+    if (flags & PERLIO_DUP_FD) {
+	fd = PerlLIO_dup(fd);
+    }
+    if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
+	f = PerlIOBase_dup(aTHX_ f, o, param, flags);
 	if (f) {
 	    /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
 	    PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
 	    s->fd = fd;
+	    PerlIOUnix_refcnt_inc(fd);
 	    return f;
 	}
-	else {
-	    PerlLIO_close(fd);
-	}
     }
     return NULL;
 }
@@ -2138,6 +2285,16 @@ PerlIOUnix_close(PerlIO *f)
     dTHX;
     int fd = PerlIOSelf(f, PerlIOUnix)->fd;
     int code = 0;
+    if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
+	if (PerlIOUnix_refcnt_dec(fd) > 0) {
+	    PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
+	    return 0;
+        }
+    }
+    else {
+	SETERRNO(EBADF,SS$_IVCHAN);
+	return -1;
+    }
     while (PerlLIO_close(fd) != 0) {
 	if (errno != EINTR) {
 	    code = -1;
@@ -2257,12 +2414,14 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     if (f) {
 	char *path = SvPV_nolen(*args);
 	PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
-	FILE *stdio =
-	    PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
+	FILE *stdio;
+	PerlIOUnix_refcnt_dec(fileno(s->stdio));
+	stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
 			    s->stdio);
 	if (!s->stdio)
 	    return NULL;
 	s->stdio = stdio;
+	PerlIOUnix_refcnt_inc(fileno(s->stdio));
 	return f;
     }
     else {
@@ -2282,6 +2441,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 				    PerlIOArg),
 				   PerlIOStdio);
 		    s->stdio = stdio;
+		    PerlIOUnix_refcnt_inc(fileno(s->stdio));
 		}
 		return f;
 	    }
@@ -2316,6 +2476,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 			       (aTHX_(f = PerlIO_allocate(aTHX)), self,
 				mode, PerlIOArg), PerlIOStdio);
 		s->stdio = stdio;
+		PerlIOUnix_refcnt_inc(fileno(s->stdio));
 		return f;
 	    }
 	}
@@ -2323,6 +2484,61 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     return NULL;
 }
 
+PerlIO *
+PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
+{
+    /* This assumes no layers underneath - which is what
+       happens, but is not how I remember it. NI-S 2001/10/16
+     */
+    if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
+	FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
+	if (flags & PERLIO_DUP_FD) {
+	    int fd = PerlLIO_dup(fileno(stdio));
+	    if (fd >= 0) {
+		char mode[8];
+		stdio = fdopen(fd, PerlIO_modestr(o,mode));
+	    }
+	    else {
+		/* FIXME: To avoid messy error recovery if dup fails
+		   re-use the existing stdio as though flag was not set
+		 */
+	    }
+	}
+	PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
+	PerlIOUnix_refcnt_inc(fileno(stdio));
+    }
+    return f;
+}
+
+IV
+PerlIOStdio_close(PerlIO *f)
+{
+    dSYS;
+#ifdef SOCKS5_VERSION_NAME
+    int optval;
+    Sock_size_t optlen = sizeof(int);
+#endif
+    FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+    if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
+	/* Do not close it but do flush any buffers */
+	PerlIO_flush(f);
+	return 0;
+    }
+    return (
+#ifdef SOCKS5_VERSION_NAME
+	       (getsockopt
+		(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
+		 &optlen) <
+		0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
+#else
+	       PerlSIO_fclose(stdio)
+#endif
+	);
+
+}
+
+
+
 SSize_t
 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
 {
@@ -2388,28 +2604,6 @@ PerlIOStdio_tell(PerlIO *f)
 }
 
 IV
-PerlIOStdio_close(PerlIO *f)
-{
-    dSYS;
-#ifdef SOCKS5_VERSION_NAME
-    int optval;
-    Sock_size_t optlen = sizeof(int);
-#endif
-    FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
-    return (
-#ifdef SOCKS5_VERSION_NAME
-	       (getsockopt
-		(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
-		 &optlen) <
-		0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
-#else
-	       PerlSIO_fclose(stdio)
-#endif
-	);
-
-}
-
-IV
 PerlIOStdio_flush(PerlIO *f)
 {
     dSYS;
@@ -2564,32 +2758,6 @@ PerlIOStdio_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 
 #endif
 
-PerlIO *
-PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
-{
-    /* This assumes no layers underneath - which is what
-       happens, but is not how I remember it. NI-S 2001/10/16
-     */
-    int fd = PerlLIO_dup(PerlIO_fileno(o));
-    if (fd >= 0) {
-	char buf[8];
-	FILE *stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o, buf));
-	if (stdio) {
-	    if ((f = PerlIOBase_dup(aTHX_ f, o, param))) {
-		PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
-	    }
-	    else {
-		PerlSIO_fclose(stdio);
-	    }
-	}
-	else {
-	    PerlLIO_close(fd);
-	    f = NULL;
-	}
-    }
-    return f;
-}
-
 PerlIO_funcs PerlIO_stdio = {
     "stdio",
     sizeof(PerlIOStdio),
@@ -2724,19 +2892,26 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 	f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
 			  NULL, narg, args);
 	if (f) {
-	    PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
-	    fd = PerlIO_fileno(f);
-#if O_BINARY != O_TEXT
-	    /*
-	     * do something about failing setmode()? --jhi
-	     */
-	    PerlLIO_setmode(fd, O_BINARY);
-#endif
-	    if (init && fd == 2) {
+            if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
+		/*
+		 * if push fails during open, open fails. close will pop us.
+		 */
+		PerlIO_close (f);
+		return NULL;
+	    } else {
+		fd = PerlIO_fileno(f);
+#if (O_BINARY != O_TEXT) && !defined(__BEOS__)
 		/*
-		 * Initial stderr is unbuffered
+		 * do something about failing setmode()? --jhi
 		 */
-		PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
+		PerlLIO_setmode(fd, O_BINARY);
+#endif
+		if (init && fd == 2) {
+		    /*
+		     * Initial stderr is unbuffered
+		     */
+		    PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
+		}
 	    }
 	}
     }
@@ -3011,7 +3186,7 @@ PerlIOBuf_close(PerlIO *f)
     IV code = PerlIOBase_close(f);
     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
-	PerlMemShared_free(b->buf);
+	Safefree(b->buf);
     }
     b->buf = NULL;
     b->ptr = b->end = b->buf;
@@ -3046,7 +3221,8 @@ PerlIOBuf_get_base(PerlIO *f)
     if (!b->buf) {
 	if (!b->bufsiz)
 	    b->bufsiz = 4096;
-	b->buf = PerlMemShared_calloc(b->bufsiz, sizeof(STDCHAR));
+	b->buf =
+	Newz('B',b->buf,b->bufsiz, STDCHAR);
 	if (!b->buf) {
 	    b->buf = (STDCHAR *) & b->oneword;
 	    b->bufsiz = sizeof(b->oneword);
@@ -3082,9 +3258,9 @@ PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 }
 
 PerlIO *
-PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
- return PerlIOBase_dup(aTHX_ f, o, param);
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
 }
 
 
@@ -3160,7 +3336,7 @@ PerlIOPending_flush(PerlIO *f)
     dTHX;
     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
     if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
-	PerlMemShared_free(b->buf);
+	Safefree(b->buf);
 	b->buf = NULL;
     }
     PerlIO_pop(aTHX_ f);
@@ -3362,7 +3538,7 @@ PerlIOCrlf_get_cnt(PerlIO *f)
 			int code;
 			b->ptr++;	/* say we have read it as far as
 					 * flush() is concerned */
-			b->buf++;	/* Leave space an front of buffer */
+			b->buf++;	/* Leave space in front of buffer */
 			b->bufsiz--;	/* Buffer is thus smaller */
 			code = PerlIO_fill(f);	/* Fetch some more */
 			b->bufsiz++;	/* Restore size for next time */
@@ -3557,8 +3733,8 @@ PerlIOMmap_map(PerlIO *f)
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
 	int fd = PerlIO_fileno(f);
-	struct stat st;
-	code = fstat(fd, &st);
+	Stat_t st;
+	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
 	    if (len > 0) {
@@ -3810,9 +3986,9 @@ PerlIOMmap_close(PerlIO *f)
 }
 
 PerlIO *
-PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 {
- return PerlIOBase_dup(aTHX_ f, o, param);
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
 }
 
 
@@ -3847,51 +4023,37 @@ PerlIO_funcs PerlIO_mmap = {
 
 #endif				/* HAS_MMAP */
 
-void
-PerlIO_init(void)
-{
-    dTHX;
-#ifndef WIN32
-    call_atexit(PerlIO_cleanup_layers, NULL);
-#endif
-    if (!_perlio) {
-#ifndef WIN32
-	atexit(&PerlIO_cleanup);
-#endif
-    }
-}
-
 #undef PerlIO_stdin
 PerlIO *
 PerlIO_stdin(void)
 {
-    if (!_perlio) {
-	dTHX;
+    dTHX;
+    if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
-    return &_perlio[1];
+    return &PL_perlio[1];
 }
 
 #undef PerlIO_stdout
 PerlIO *
 PerlIO_stdout(void)
 {
-    if (!_perlio) {
-	dTHX;
+    dTHX;
+    if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
-    return &_perlio[2];
+    return &PL_perlio[2];
 }
 
 #undef PerlIO_stderr
 PerlIO *
 PerlIO_stderr(void)
 {
-    if (!_perlio) {
-	dTHX;
+    dTHX;
+    if (!PL_perlio) {
 	PerlIO_stdstreams(aTHX);
     }
-    return &_perlio[3];
+    return &PL_perlio[3];
 }
 
 /*--------------------------------------------------------------------------------------*/
@@ -4175,3 +4337,8 @@ PerlIO_sprintf(char *s, int n, const char *fmt, ...)
     return result;
 }
 #endif
+
+
+
+
+