X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doio.c;h=9cfcc4e1c5c8a3fc8aa795823d501b5e860d6cde;hb=6e6ca6c3d8f9eaf6e2364f1fef07b3f472f0a846;hp=0520992cc720f9fa016cbc666b2cf29890a78d15;hpb=ed2c6b9b45ca155543a6a8e651e2d3e0d446406e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/doio.c b/doio.c
index 0520992..9cfcc4e 100644
--- a/doio.c
+++ b/doio.c
@@ -213,6 +213,15 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	if (num_svs) {
 	    /* New style explict name, type is just mode and discipline/layer info */
 	    STRLEN l = 0;
+#ifdef USE_STDIO
+	    if (SvROK(*svp) && !strchr(name,'&')) {
+		if (ckWARN(WARN_IO))
+		    Perl_warner(aTHX_ packWARN(WARN_IO),
+			    "Can't open a reference");
+		SETERRNO(EINVAL, LIB_INVARG);
+		goto say_false;
+	    }
+#endif /* USE_STDIO */
 	    name = SvOK(*svp) ? SvPV(*svp, l) : "";
 	    len = (I32)l;
 	    name = savepvn(name, len);
@@ -248,7 +257,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	    if (*name == '\0') {
 		/* command is missing 19990114 */
 		if (ckWARN(WARN_PIPE))
-		    Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
+		    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
 		errno = EPIPE;
 		goto say_false;
 	    }
@@ -258,7 +267,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	    if (!num_svs && name[len-1] == '|') {
 		name[--len] = '\0' ;
 		if (ckWARN(WARN_PIPE))
-		    Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
+		    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
 	    }
 	    mode[0] = 'w';
 	    writing = 1;
@@ -272,6 +281,13 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	    else {
 		fp = PerlProc_popen(name,mode);
 	    }
+	    if (num_svs) {
+		if (*type) {
+		    if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
+			goto say_false;
+		    }
+		}
+	    }
 	}
 	else if (*type == IoTYPE_WRONLY) {
 	    TAINT_PROPER("open");
@@ -307,8 +323,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 		    if (num_svs > 1) {
 			Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
 		    }
-		    if (num_svs && SvIOK(*svp)) {
+		    if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
 			fd = SvUV(*svp);
+			num_svs = 0;
 		    }
 		    else if (isDIGIT(*type)) {
 			/*SUPPRESS 530*/
@@ -329,7 +346,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 			}
 			if (!thatio) {
 #ifdef EINVAL
-			    SETERRNO(EINVAL,SS$_IVCHAN);
+			    SETERRNO(EINVAL,SS_IVCHAN);
 #endif
 			    goto say_false;
 			}
@@ -455,7 +472,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	    if (*name == '\0') {
 		/* command is missing 19990114 */
 		if (ckWARN(WARN_PIPE))
-		    Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
+		    Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
 		errno = EPIPE;
 		goto say_false;
 	    }
@@ -474,6 +491,14 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 		fp = PerlProc_popen(name,mode);
 	    }
 	    IoTYPE(io) = IoTYPE_PIPE;
+	    if (num_svs) {
+		for (; isSPACE(*type); type++) ;
+		if (*type) {
+		    if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
+			goto say_false;
+		    }
+		}
+	    }
 	}
 	else {
 	    if (num_svs)
@@ -504,26 +529,28 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     }
     if (!fp) {
 	if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
-	    Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
+	    Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
 	goto say_false;
     }
 
     if (ckWARN(WARN_IO)) {
 	if ((IoTYPE(io) == IoTYPE_RDONLY) &&
 	    (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
-		Perl_warner(aTHX_ WARN_IO,
-			    "Filehandle STD%s opened only for input",
-			    (fp == PerlIO_stdout()) ? "OUT" : "ERR");
+		Perl_warner(aTHX_ packWARN(WARN_IO),
+			    "Filehandle STD%s reopened as %s only for input",
+			    ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
+			    GvENAME(gv));
 	}
 	else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
-		Perl_warner(aTHX_ WARN_IO,
-			    "Filehandle STDIN opened only for output");
+		Perl_warner(aTHX_ packWARN(WARN_IO),
+			    "Filehandle STDIN reopened as %s only for output",
+			    GvENAME(gv));
 	}
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::Scalar) assume it isn't a
-     * socket - this covers PerlIO::Scalar - otherwise unless we "know" the
+    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
+     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
      * type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
@@ -572,9 +599,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	    }
 	}
 	if (savefd != fd) {
-	    Pid_t pid;
-	    SV *sv;
-	    /* Still a small can-of-worms here if (say) PerlIO::Scalar
+	    /* Still a small can-of-worms here if (say) PerlIO::scalar
 	       is assigned to (say) STDOUT - for now let dup2() fail
 	       and provide the error
 	     */
@@ -584,25 +609,45 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 	    }
 #ifdef VMS
 	    if (savefd != PerlIO_fileno(PerlIO_stdin())) {
-	      char newname[FILENAME_MAX+1];
-             if (PerlIO_getname(fp, newname)) {
-	        if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
-	        if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",  newname);
-	      }
+                char newname[FILENAME_MAX+1];
+                if (PerlIO_getname(fp, newname)) {
+                    if (fd == PerlIO_fileno(PerlIO_stdout()))
+                        Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
+                    if (fd == PerlIO_fileno(PerlIO_stderr()))
+                        Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",  newname);
+                }
 	    }
 #endif
-	    LOCK_FDPID_MUTEX;
-	    sv = *av_fetch(PL_fdpid,fd,TRUE);
-	    (void)SvUPGRADE(sv, SVt_IV);
-	    pid = SvIVX(sv);
-	    SvIVX(sv) = 0;
-	    sv = *av_fetch(PL_fdpid,savefd,TRUE);
-	    UNLOCK_FDPID_MUTEX;
-	    (void)SvUPGRADE(sv, SVt_IV);
-	    SvIVX(sv) = pid;
-	    if (!was_fdopen) {
-		PerlIO_close(fp);
+
+#if !defined(WIN32)
+           /* PL_fdpid isn't used on Windows, so avoid this useless work.
+            * XXX Probably the same for a lot of other places. */
+            {
+                Pid_t pid;
+                SV *sv;
+
+                LOCK_FDPID_MUTEX;
+                sv = *av_fetch(PL_fdpid,fd,TRUE);
+                (void)SvUPGRADE(sv, SVt_IV);
+                pid = SvIVX(sv);
+                SvIVX(sv) = 0;
+                sv = *av_fetch(PL_fdpid,savefd,TRUE);
+                (void)SvUPGRADE(sv, SVt_IV);
+                SvIVX(sv) = pid;
+                UNLOCK_FDPID_MUTEX;
+            }
+#endif
+
+	    if (was_fdopen) {
+                /* need to close fp without closing underlying fd */
+                int ofd = PerlIO_fileno(fp);
+                int dupfd = PerlLIO_dup(ofd);
+                PerlIO_close(fp);
+                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_close(dupfd);
 	    }
+            else
+		PerlIO_close(fp);
 	}
 	fp = saveifp;
 	PerlIO_clearerr(fp);
@@ -621,8 +666,11 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     if (writing) {
 	if (IoTYPE(io) == IoTYPE_SOCKET
 	    || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
-	    mode[0] = 'w';
-	    if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+	    char *s = mode;
+	    if (*s == 'I' || *s == '#')
+	     s++;
+	    *s = 'w';
+	    if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) {
 		PerlIO_close(fp);
 		IoIFP(io) = Nullfp;
 		goto say_false;
@@ -694,7 +742,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 		filegid = PL_statbuf.st_gid;
 		if (!S_ISREG(PL_filemode)) {
 		    if (ckWARN_d(WARN_INPLACE))	
-		        Perl_warner(aTHX_ WARN_INPLACE,
+		        Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 			    "Can't do inplace edit: %s is not a regular file",
 		            PL_oldname );
 		    do_close(gv,FALSE);
@@ -726,7 +774,7 @@ Perl_nextargv(pTHX_ register GV *gv)
                       )
 		    {
 			if (ckWARN_d(WARN_INPLACE))	
-			    Perl_warner(aTHX_ WARN_INPLACE,
+			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 			      "Can't do inplace edit: %s would not be unique",
 			      SvPVX(sv));
 			do_close(gv,FALSE);
@@ -734,10 +782,10 @@ Perl_nextargv(pTHX_ register GV *gv)
 		    }
 #endif
 #ifdef HAS_RENAME
-#if !defined(DOSISH) && !defined(__CYGWIN__)
+#if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC)
 		    if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
 		        if (ckWARN_d(WARN_INPLACE))	
-			    Perl_warner(aTHX_ WARN_INPLACE,
+			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 			      "Can't rename %s to %s: %s, skipping file",
 			      PL_oldname, SvPVX(sv), Strerror(errno) );
 			do_close(gv,FALSE);
@@ -753,7 +801,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 		    (void)UNLINK(SvPVX(sv));
 		    if (link(PL_oldname,SvPVX(sv)) < 0) {
 		        if (ckWARN_d(WARN_INPLACE))	
-			    Perl_warner(aTHX_ WARN_INPLACE,
+			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 			      "Can't rename %s to %s: %s, skipping file",
 			      PL_oldname, SvPVX(sv), Strerror(errno) );
 			do_close(gv,FALSE);
@@ -767,7 +815,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 #  ifndef VMS  /* Don't delete; use automatic file versioning */
 		    if (UNLINK(PL_oldname) < 0) {
 		        if (ckWARN_d(WARN_INPLACE))	
-			    Perl_warner(aTHX_ WARN_INPLACE,
+			    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 			      "Can't remove %s: %s, skipping file",
 			      PL_oldname, Strerror(errno) );
 			do_close(gv,FALSE);
@@ -791,7 +839,7 @@ Perl_nextargv(pTHX_ register GV *gv)
 #endif
 		{
 		    if (ckWARN_d(WARN_INPLACE))	
-		        Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
+		        Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
 		          PL_oldname, Strerror(errno) );
 		    do_close(gv,FALSE);
 		    continue;
@@ -825,12 +873,12 @@ Perl_nextargv(pTHX_ register GV *gv)
 		if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
 		    && !S_ISREG(PL_statbuf.st_mode))	
 		{
-		    Perl_warner(aTHX_ WARN_INPLACE,
+		    Perl_warner(aTHX_ packWARN(WARN_INPLACE),
 				"Can't do inplace edit: %s is not a regular file",
 				PL_oldname);
 		}
 		else
-		    Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s",
+		    Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
 				PL_oldname, Strerror(eno));
 	    }
 	}
@@ -875,8 +923,9 @@ Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
 
     if (PerlProc_pipe(fd) < 0)
 	goto badexit;
-    IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
-    IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+    IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPESOCK_MODE);
+    IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPESOCK_MODE);
+    IoOFP(rstio) = IoIFP(rstio);
     IoIFP(wstio) = IoOFP(wstio);
     IoTYPE(rstio) = IoTYPE_RDONLY;
     IoTYPE(wstio) = IoTYPE_WRONLY;
@@ -908,7 +957,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 	gv = PL_argvgv;
     if (!gv || SvTYPE(gv) != SVt_PVGV) {
 	if (not_implicit)
-	    SETERRNO(EBADF,SS$_IVCHAN);
+	    SETERRNO(EBADF,SS_IVCHAN);
 	return FALSE;
     }
     io = GvIO(gv);
@@ -916,7 +965,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 	if (not_implicit) {
 	    if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
 		report_evil_fh(gv, io, PL_op->op_type);
-	    SETERRNO(EBADF,SS$_IVCHAN);
+	    SETERRNO(EBADF,SS_IVCHAN);
 	}
 	return FALSE;
     }
@@ -960,7 +1009,7 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
 	IoOFP(io) = IoIFP(io) = Nullfp;
     }
     else if (not_implicit) {
-	SETERRNO(EBADF,SS$_IVCHAN);
+	SETERRNO(EBADF,SS_IVCHAN);
     }
 
     return retval;
@@ -1021,7 +1070,7 @@ Perl_do_tell(pTHX_ GV *gv)
     }
     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 	report_evil_fh(gv, io, PL_op->op_type);
-    SETERRNO(EBADF,RMS$_IFI);
+    SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
 }
 
@@ -1040,7 +1089,7 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
     }
     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 	report_evil_fh(gv, io, PL_op->op_type);
-    SETERRNO(EBADF,RMS$_IFI);
+    SETERRNO(EBADF,RMS_IFI);
     return FALSE;
 }
 
@@ -1054,7 +1103,7 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
     if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 	report_evil_fh(gv, io, PL_op->op_type);
-    SETERRNO(EBADF,RMS$_IFI);
+    SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
 }
 
@@ -1136,7 +1185,7 @@ I32 fd;			/* file descriptor */
 Off_t length;		/* length to set file to */
 {
     struct flock fl;
-    struct stat filebuf;
+    Stat_t filebuf;
 
     if (PerlLIO_fstat(fd, &filebuf) < 0)
 	return -1;
@@ -1225,7 +1274,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	    if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
 		&& ckWARN_d(WARN_UTF8))
 	    {
-		Perl_warner(aTHX_ WARN_UTF8, "Wide character in print");
+		Perl_warner(aTHX_ packWARN(WARN_UTF8), "Wide character in print");
 	    }
 	}
 	tmps = SvPV(sv, len);
@@ -1290,7 +1339,7 @@ Perl_my_stat(pTHX)
 	PL_laststype = OP_STAT;
 	PL_laststatval = PerlLIO_stat(s, &PL_statcache);
 	if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
-	    Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
+	    Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
 	return PL_laststatval;
     }
 }
@@ -1309,7 +1358,7 @@ Perl_my_lstat(pTHX)
 	    return PL_laststatval;
 	}
 	if (ckWARN(WARN_IO)) {
-	    Perl_warner(aTHX_ WARN_IO, "Use of -l on filehandle %s",
+	    Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
 		    GvENAME(cGVOP_gv));
 	    return (PL_laststatval = -1);
 	}
@@ -1320,14 +1369,14 @@ Perl_my_lstat(pTHX)
     sv = POPs;
     PUTBACK;
     if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV && ckWARN(WARN_IO)) {
-	Perl_warner(aTHX_ WARN_IO, "Use of -l on filehandle %s",
+	Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
 		GvENAME((GV*) SvRV(sv)));
 	return (PL_laststatval = -1);
     }
     sv_setpv(PL_statname,SvPV(sv, n_a));
     PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
-	Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat");
+	Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
     return PL_laststatval;
 }
 
@@ -1368,7 +1417,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
 	else
 	    PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
 	if (ckWARN(WARN_EXEC))
-	    Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
+	    Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
 		(really ? tmps : PL_Argv[0]), Strerror(errno));
 	if (do_report) {
 	    int e = errno;
@@ -1506,7 +1555,7 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
 	    int e = errno;
 
 	    if (ckWARN(WARN_EXEC))
-		Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
+		Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
 		    PL_Argv[0], Strerror(errno));
 	    if (do_report) {
 		PerlLIO_write(fd, (void*)&e, sizeof(int));
@@ -2043,7 +2092,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp)
     opbuf = SvPV(opstr, opsize);
     if (opsize < 3 * SHORTSIZE
 	|| (opsize % (3 * SHORTSIZE))) {
-	SETERRNO(EINVAL,LIB$_INVARG);
+	SETERRNO(EINVAL,LIB_INVARG);
 	return -1;
     }
     SETERRNO(0,0);
@@ -2100,7 +2149,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
     if (shmctl(id, IPC_STAT, &shmds) == -1)
 	return -1;
     if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
-	SETERRNO(EFAULT,SS$_ACCVIO);		/* can't do as caller requested */
+	SETERRNO(EFAULT,SS_ACCVIO);		/* can't do as caller requested */
 	return -1;
     }
     shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
@@ -2227,7 +2276,7 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
 	    }
 	    if (cxt) (void)lib$find_file_end(&cxt);
 	    if (ok && sts != RMS$_NMF &&
-		sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
+		sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
 	    if (!ok) {
 		if (!(sts & 1)) {
 		    SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);