X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/75af9d73c8bf8178b2a2ced9d70164b65b62ec8c..faba7be906cb08c47ba757a9b6123764c537aed2:/doio.c

diff --git a/doio.c b/doio.c
index 39e5ce7..67966b5 100644
--- a/doio.c
+++ b/doio.c
@@ -110,7 +110,8 @@ S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp,
                 if (result == EOF && old_fd > PL_maxsysfd) {
                     /* Why is this not Perl_warn*() call ? */
                     PerlIO_printf(Perl_error_log,
-                                  "Warning: unable to close filehandle %"HEKf" properly.\n",
+                                  "Warning: unable to close filehandle %" HEKf
+                                  " properly.\n",
                                   HEKfARG(GvENAME_HEK(gv))
                         );
                 }
@@ -636,14 +637,14 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	if ((IoTYPE(io) == IoTYPE_RDONLY) &&
 	    (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
 		Perl_warner(aTHX_ packWARN(WARN_IO),
-			    "Filehandle STD%s reopened as %"HEKf
+			    "Filehandle STD%s reopened as %" HEKf
 			    " only for input",
 			    ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
 			    HEKfARG(GvENAME_HEK(gv)));
 	}
 	else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
 		Perl_warner(aTHX_ packWARN(WARN_IO),
-		    "Filehandle STDIN reopened as %"HEKf" only for output",
+		    "Filehandle STDIN reopened as %" HEKf " only for output",
 		     HEKfARG(GvENAME_HEK(gv))
 		);
 	}
@@ -741,9 +742,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
                 int ofd = PerlIO_fileno(fp);
                 int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
-                if (coe < 0) {
+		/* Assume if we have F_SETFD we have F_GETFD. */
+                /* Get a copy of all the fd flags. */
+                int fd_flags = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (fd_flags < 0) {
                     if (dupfd >= 0)
                         PerlLIO_close(dupfd);
                     goto say_false;
@@ -757,8 +759,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
                 PerlIO_close(fp);
                 PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-		/* The dup trick has lost close-on-exec on ofd */
-		fcntl(ofd,F_SETFD, coe);
+		/* The dup trick has lost close-on-exec on ofd,
+                 * and possibly any other flags, so restore them. */
+		fcntl(ofd,F_SETFD, fd_flags);
 #endif
                 PerlLIO_close(dupfd);
 	    }
@@ -769,12 +772,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	PerlIO_clearerr(fp);
 	fd = PerlIO_fileno(fp);
     }
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-    if (fd >= 0) {
-        if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) {
-            PerlLIO_close(fd);
-            goto say_false;
-        }
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
+    if (fd >= 0 && fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
+        PerlLIO_close(fd);
+        goto say_false;
     }
 #endif
     IoIFP(io) = fp;
@@ -808,9 +809,13 @@ PerlIO *
 Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 {
     IO * const io = GvIOp(gv);
+    SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL;
 
     PERL_ARGS_ASSERT_NEXTARGV;
 
+    if (old_out_name)
+        SAVEFREESV(old_out_name);
+
     if (!PL_argvoutgv)
 	PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
     if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
@@ -835,6 +840,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
     if (!GvAV(gv))
 	return NULL;
     while (av_tindex(GvAV(gv)) >= 0) {
+	Stat_t statbuf;
 	STRLEN oldlen;
         SV *const sv = av_shift(GvAV(gv));
 	SAVEFREESV(sv);
@@ -851,6 +857,13 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
             }
         }
         else {
+            {
+                IO * const io = GvIOp(PL_argvoutgv);
+                if (io && IoIFP(io) && old_out_name && !io_close(io, PL_argvoutgv, FALSE, FALSE)) {
+                    Perl_croak(aTHX_ "Failed to close in-place edit file %"
+                               SVf ": %s\n", old_out_name, Strerror(errno));
+                }
+            }
             /* This very long block ends with return IoIFP(GvIOp(gv));
                Both this block and the block above fall through on open
                failure to the warning code, and then the while loop above tries
@@ -887,7 +900,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 		    const char *star = strchr(PL_inplace, '*');
 		    if (star) {
 			const char *begin = PL_inplace;
-			sv_setpvs(sv, "");
+                        SvPVCLEAR(sv);
 			do {
 			    sv_catpvn(sv, begin, star - begin);
 			    sv_catpvn(sv, PL_oldname, oldlen);
@@ -909,7 +922,8 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
                       )
 		    {
 			Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
-					 "Can't do inplace edit: %"SVf" would not be unique",
+					 "Can't do inplace edit: %"
+                                         SVf " would not be unique",
 					 SVfARG(sv));
 			do_close(gv,FALSE);
 			continue;
@@ -919,8 +933,10 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 #if !defined(DOSISH) && !defined(__CYGWIN__)
 		    if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
 			Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
-					 "Can't rename %s to %"SVf": %s, skipping file",
-					 PL_oldname, SVfARG(sv), Strerror(errno));
+					 "Can't rename %s to %" SVf
+                                         ": %s, skipping file",
+					 PL_oldname, SVfARG(sv),
+                                         Strerror(errno));
 			do_close(gv,FALSE);
 			continue;
 		    }
@@ -934,7 +950,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 		    (void)UNLINK(SvPVX_const(sv));
 		    if (link(PL_oldname,SvPVX_const(sv)) < 0) {
 			Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
-					 "Can't rename %s to %"SVf": %s, skipping file",
+					 "Can't rename %s to %" SVf ": %s, skipping file",
 					 PL_oldname, SVfARG(sv), Strerror(errno) );
 			do_close(gv,FALSE);
 			continue;
@@ -943,7 +959,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 #endif
 		}
 		else {
-#if !defined(DOSISH) && !defined(AMIGAOS)
+#if !defined(DOSISH) && !defined(__amigaos4__)
 #  ifndef VMS  /* Don't delete; use automatic file versioning */
 		    if (UNLINK(PL_oldname) < 0) {
 			Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
@@ -976,13 +992,13 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
                 if (PL_lastfd >= 0) {
-                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                    (void)PerlLIO_fstat(PL_lastfd,&statbuf);
 #ifdef HAS_FCHMOD
                     (void)fchmod(PL_lastfd,PL_filemode);
 #else
                     (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                    if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
                         /* XXX silently ignore failures */
 #ifdef HAS_FCHOWN
                         PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
@@ -999,8 +1015,8 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 
         if (ckWARN_d(WARN_INPLACE)) {
             const int eno = errno;
-            if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
-                && !S_ISREG(PL_statbuf.st_mode)) {
+            if (PerlLIO_stat(PL_oldname, &statbuf) >= 0
+                && !S_ISREG(statbuf.st_mode)) {
                 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
                             "Can't do inplace edit: %s is not a regular file",
                             PL_oldname);
@@ -1014,7 +1030,17 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
     if (io && (IoFLAGS(io) & IOf_ARGV))
 	IoFLAGS(io) |= IOf_START;
     if (PL_inplace) {
-	(void)do_close(PL_argvoutgv,FALSE);
+        if (old_out_name) {
+            IO * const io = GvIOp(PL_argvoutgv);
+            if (io && IoIFP(io) && !io_close(io, PL_argvoutgv, FALSE, FALSE)) {
+                Perl_croak(aTHX_ "Failed to close in-place edit file %" SVf ": %s\n",
+                           old_out_name, Strerror(errno));
+            }
+        }
+        else {
+            /* maybe this is no longer wanted */
+            (void)do_close(PL_argvoutgv,FALSE);
+        }
 	if (io && (IoFLAGS(io) & IOf_ARGV)
 	    && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
 	{
@@ -1105,13 +1131,13 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
 	    if (gv)
 		Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
 				"Warning: unable to close filehandle %"
-				 HEKf" properly: %"SVf,
+				 HEKf " properly: %" SVf,
 				 HEKfARG(GvNAME_HEK(gv)),
                                  SVfARG(get_sv("!",GV_ADD)));
 	    else
 		Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
 				"Warning: unable to close filehandle "
-				"properly: %"SVf,
+				"properly: %" SVf,
 				 SVfARG(get_sv("!",GV_ADD)));
 	}
     }
@@ -1337,9 +1363,9 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
     if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
 	assert(!SvGMAGICAL(sv));
 	if (SvIsUV(sv))
-	    PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
+	    PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
 	else
-	    PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
+	    PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
 	return !PerlIO_error(fp);
     }
     else {
@@ -1413,7 +1439,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         do_fstat_have_io:
         PL_laststype = OP_STAT;
         PL_statgv = gv ? gv : (GV *)io;
-        sv_setpvs(PL_statname, "");
+        SvPVCLEAR(PL_statname);
         if (io) {
 	    if (IoIFP(io)) {
                 int fd = PerlIO_fileno(IoIFP(io));
@@ -1481,7 +1507,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
 	if (ckWARN(WARN_IO)) {
 	    /* diag_listed_as: Use of -l on filehandle%s */
 	    Perl_warner(aTHX_ packWARN(WARN_IO),
-		 	     "Use of -l on filehandle %"HEKf,
+		              "Use of -l on filehandle %" HEKf,
 			      HEKfARG(GvENAME_HEK(cGVOP_gv)));
 	}
 	return -1;
@@ -1508,7 +1534,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
         else
 	    /* diag_listed_as: Use of -l on filehandle%s */
             Perl_warner(aTHX_ packWARN(WARN_IO),
-                             "Use of -l on filehandle %"HEKf,
+                             "Use of -l on filehandle %" HEKf,
                               HEKfARG(GvENAME_HEK((const GV *)
                                           (SvROK(sv) ? SvRV(sv) : sv))));
     }
@@ -1528,9 +1554,10 @@ S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
 {
     const int e = errno;
     PERL_ARGS_ASSERT_EXEC_FAILED;
+
     if (ckWARN(WARN_EXEC))
-	Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
-		    cmd, Strerror(e));
+        Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
+                    cmd, Strerror(e));
     if (do_report) {
         /* XXX silently ignore failures */
         PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
@@ -1566,10 +1593,11 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
 	    (really && *tmps != '/'))		/* will execvp use PATH? */
 	    TAINT_ENV();		/* testing IFS here is overkill, probably */
 	PERL_FPU_PRE_EXEC
-	if (really && *tmps)
-	    PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
-	else
-	    PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
+	if (really && *tmps) {
+            PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
+	} else {
+            PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
+	}
 	PERL_FPU_POST_EXEC
  	S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
     }
@@ -1615,7 +1643,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
     {
         char flags[PERL_FLAGS_MAX];
 	if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
-	    strnEQ(cmd+PL_cshlen," -c",3)) {
+	    strEQs(cmd+PL_cshlen," -c")) {
           my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
 	  s = cmd+PL_cshlen+3;
 	  if (*s == 'f') {
@@ -1651,7 +1679,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
     if (*cmd == '.' && isSPACE(cmd[1]))
 	goto doshell;
 
-    if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+    if (strEQs(cmd,"exec") && isSPACE(cmd[4]))
 	goto doshell;
 
     s = cmd;
@@ -1683,7 +1711,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 	    }
 	  doshell:
 	    PERL_FPU_PRE_EXEC
-	    PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
+            PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
 	    PERL_FPU_POST_EXEC
  	    S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
 	    Safefree(buf);
@@ -1707,7 +1735,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
     *a = NULL;
     if (PL_Argv[0]) {
 	PERL_FPU_PRE_EXEC
-	PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
+        PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
 	PERL_FPU_POST_EXEC
 	if (errno == ENOEXEC) {		/* for system V NIH syndrome */
 	    do_execfree();
@@ -1722,10 +1750,6 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 
 #endif /* OS2 || WIN32 */
 
-#ifdef VMS
-#include <starlet.h> /* for sys$delprc */
-#endif
-
 I32
 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 {
@@ -1874,7 +1898,8 @@ nothing in the core.
                 len -= 3;
             }
            if ((val = whichsig_pvn(s, len)) < 0)
-               Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
+               Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
+                                SVfARG(*mark));
 	}
 	else
 	{
@@ -1887,40 +1912,7 @@ nothing in the core.
 	}
 	APPLY_TAINT_PROPER();
 	tot = sp - mark;
-#ifdef VMS
-	/* kill() doesn't do process groups (job trees?) under VMS */
-	if (val == SIGKILL) {
-	    /* Use native sys$delprc() to insure that target process is
-	     * deleted; supervisor-mode images don't pay attention to
-	     * CRTL's emulation of Unix-style signals and kill()
-	     */
-	    while (++mark <= sp) {
-		I32 proc;
-		unsigned long int __vmssts;
-		SvGETMAGIC(*mark);
-		if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
-		    Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
-		proc = SvIV_nomg(*mark);
-		APPLY_TAINT_PROPER();
-		if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
-		    tot--;
-		    switch (__vmssts) {
-			case SS$_NONEXPR:
-			case SS$_NOSUCHNODE:
-			    SETERRNO(ESRCH,__vmssts);
-			    break;
-			case SS$_NOPRIV:
-			    SETERRNO(EPERM,__vmssts);
-			    break;
-			default:
-			    SETERRNO(EVMSERR,__vmssts);
-		    }
-		}
-	    }
-	    PERL_ASYNC_CHECK();
-	    break;
-	}
-#endif
+
 	while (++mark <= sp) {
 	    Pid_t proc;
 	    SvGETMAGIC(*mark);
@@ -1952,18 +1944,47 @@ nothing in the core.
             }
 	    else if (PL_unsafe) {
 		if (UNLINK(s))
+		{
 		    tot--;
+		}
+#if defined(__amigaos4__) && defined(NEWLIB)
+		else
+		{
+                  /* Under AmigaOS4 unlink only 'fails' if the
+                   * filename is invalid.  It may not remove the file
+                   * if it's locked, so check if it's still around. */
+                  if ((access(s,F_OK) != -1))
+                  {
+                    tot--;
+                  }
+		}
+#endif
 	    }
 	    else {	/* don't let root wipe out directories without -U */
-		if (PerlLIO_lstat(s,&PL_statbuf) < 0)
-		    tot--;
-		else if (S_ISDIR(PL_statbuf.st_mode)) {
+		Stat_t statbuf;
+		if (PerlLIO_lstat(s, &statbuf) < 0)
 		    tot--;
+		else if (S_ISDIR(statbuf.st_mode)) {
 		    SETERRNO(EISDIR, SS_NOPRIV);
+		    tot--;
 		}
 		else {
 		    if (UNLINK(s))
-			tot--;
+		    {
+				tot--;
+			}
+#if defined(__amigaos4__) && defined(NEWLIB)
+			else
+			{
+				/* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
+				/* It may not remove the file if it's Locked, so check if it's still */
+				/* arround */
+				if((access(s,F_OK) != -1))
+				{
+					tot--;
+				}
+			}	
+#endif
 		}
 	    }
 	}
@@ -2373,7 +2394,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
 
     /* suppress warning when reading into undef var --jhi */
     if (! SvOK(mstr))
-	sv_setpvs(mstr, "");
+        SvPVCLEAR(mstr);
     msize = SvIVx(*++mark);
     mtype = (long)SvIVx(*++mark);
     flags = SvIVx(*++mark);
@@ -2484,7 +2505,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 	SvGETMAGIC(mstr);
 	SvUPGRADE(mstr, SVt_PV);
 	if (! SvOK(mstr))
-	    sv_setpvs(mstr, "");
+            SvPVCLEAR(mstr);
 	SvPOK_only(mstr);
 	mbuf = SvGROW(mstr, (STRLEN)msize+1);
 
@@ -2521,7 +2542,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 
 Function called by C<do_readline> to spawn a glob (or do the glob inside
 perl on VMS).  This code used to be inline, but now perl uses C<File::Glob>
-this glob starter is only used by miniperl during the build process.
+this glob starter is only used by miniperl during the build process,
+or when PERL_EXTERNAL_GLOB is defined.
 Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
 
 =cut
@@ -2581,14 +2603,11 @@ Perl_vms_start_glob
 #endif /* !CSH */
 #endif /* !DOSISH */
     {
-	GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
-	SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
-	SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
-	if (home && *home) SvGETMAGIC(*home);
-	if (path && *path) SvGETMAGIC(*path);
-	save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
-	if (home && *home) SvSETMAGIC(*home);
-	if (path && *path) SvSETMAGIC(*path);
+        SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
+        if (svp && *svp)
+            save_helem_flags(GvHV(PL_envgv),
+                             newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
+                             SAVEf_SETMAGIC);
     }
     (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
                    NULL, NULL, 0);