This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update version to 0.9916
[perl5.git] / doio.c
diff --git a/doio.c b/doio.c
index 79ab20c..856b19a 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -741,9 +741,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 +758,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 +771,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 +808,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 +839,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 +856,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
@@ -943,7 +955,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 +988,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 +1011,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 +1026,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)
        {
@@ -1206,7 +1228,10 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     if (io && (fp = IoIFP(io))) {
         int fd = PerlIO_fileno(fp);
-        if (fd >= 0) {
+        if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
+            SETERRNO(EINVAL,LIB_INVARG);
+            return -1;
+        } else {
             return PerlLIO_lseek(fd, pos, whence);
         }
     }
@@ -1525,9 +1550,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)));
@@ -1563,10 +1589,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);
     }
@@ -1680,7 +1707,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);
@@ -1704,7 +1731,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();
@@ -1719,10 +1746,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)
 {
@@ -1822,8 +1845,18 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                         int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
                        APPLY_TAINT_PROPER();
                         if (fd < 0) {
-                            SETERRNO(EBADF,RMS_IFI);
+                           SETERRNO(EBADF,RMS_IFI);
+                           tot--;
+#if Uid_t_sign == 1
+                       } else if (val < 0) {
+                           SETERRNO(EINVAL,LIB_INVARG);
                            tot--;
+#endif
+#if Gid_t_sign == 1
+                       } else if (val2 < 0) {
+                           SETERRNO(EINVAL,LIB_INVARG);
+                           tot--;
+#endif
                         } else if (fchown(fd, val, val2))
                            tot--;
 #else
@@ -1884,40 +1917,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);
@@ -1949,18 +1949,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
                }
            }
        }
@@ -2340,7 +2369,12 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
     if (msize < 0)
        Perl_croak(aTHX_ "Arg too short for msgsnd");
     SETERRNO(0,0);
-    return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
+    if (id >= 0 && flags >= 0) {
+      return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
+    } else {
+      SETERRNO(EINVAL,LIB_INVARG);
+      return -1;
+    }
 #else
     PERL_UNUSED_ARG(sp);
     PERL_UNUSED_ARG(mark);
@@ -2373,7 +2407,12 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
     mbuf = SvGROW(mstr, sizeof(long)+msize+1);
 
     SETERRNO(0,0);
-    ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
+    if (id >= 0 && msize >= 0 && flags >= 0) {
+        ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
+    } else {
+        SETERRNO(EINVAL,LIB_INVARG);
+        ret = -1;
+    }
     if (ret >= 0) {
        SvCUR_set(mstr, sizeof(long)+ret);
        *SvEND(mstr) = '\0';
@@ -2457,7 +2496,12 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
        SETERRNO(EFAULT,SS_ACCVIO);             /* can't do as caller requested */
        return -1;
     }
-    shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
+    if (id >= 0) {
+        shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
+    } else {
+        SETERRNO(EINVAL,LIB_INVARG);
+        return -1;
+    }
     if (shm == (char *)-1)     /* I hate System V IPC, I really do */
        return -1;
     if (optype == OP_SHMREAD) {
@@ -2503,8 +2547,9 @@ 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.
-Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
+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
 */