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

diff --git a/perlio.c b/perlio.c
index c960a03..7c16e43 100644
--- a/perlio.c
+++ b/perlio.c
@@ -38,6 +38,11 @@
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
+#ifdef PERL_IMPLICIT_CONTEXT
+#undef dSYS
+#define dSYS dTHX
+#endif
+
 #include "XSUB.h"
 
 int
@@ -173,8 +178,9 @@ 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) {
@@ -189,6 +195,7 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
     else {
 	SETERRNO(EBADF, SS$_IVCHAN);
     }
+#endif
     return NULL;
 }
 
@@ -435,13 +442,13 @@ PerlIO_allocate(pTHX)
 
 #undef PerlIO_fdupopen
 PerlIO *
-PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param)
+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);
+        new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
 	return new;
     }
     else {
@@ -777,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 {
@@ -1065,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;
@@ -1249,7 +1259,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
 	    while (l) {
 		SV *arg =
 		    (l->tab->Getarg) ? (*l->tab->
-					Getarg) (&l) : &PL_sv_undef;
+					Getarg) (aTHX_ &l, NULL, 0) : &PL_sv_undef;
 		PerlIO_list_push(aTHX_ layera, l->tab, arg);
 		l = *PerlIONext(&l);
 	    }
@@ -1966,12 +1976,12 @@ PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
 }
 
 PerlIO *
-PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+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);
+	f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
     }
     if (f) {
 	PerlIO_funcs *self = PerlIOBase(o)->tab;
@@ -1979,13 +1989,10 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
 	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);
-	    }
+	    arg = (*self->Getarg)(aTHX_ o,param,flags);
 	}
 	f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
-	if (!f && arg) {
+	if (arg) {
 	    SvREFCNT_dec(arg);
 	}
     }
@@ -2197,12 +2204,15 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 }
 
 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 = 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);
+	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);
@@ -2475,13 +2485,25 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 }
 
 PerlIO *
-PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param)
+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))) {
+    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));
     }
@@ -2870,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 (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__)
-	    /*
-	     * do something about failing setmode()? --jhi
-	     */
-	    PerlLIO_setmode(fd, O_BINARY);
-#endif
-	    if (init && fd == 2) {
 		/*
-		 * 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;
+		}
 	    }
 	}
     }
@@ -3229,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);
 }
 
 
@@ -3509,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 */
@@ -3957,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);
 }