applied suggested patch; added missing prototype changes to

[p5sagit/p5-mst-13.2.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index a2ed109..a849dbb 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -501,10 +501,16 @@ PP(pp_open)
     djSP; dTARGET;
     GV *gv;
     SV *sv;
+    SV *name;
+    I32 have_name = 0;
     char *tmps;
     STRLEN len;
     MAGIC *mg;
 
+    if (MAXARG > 2) {
+       name = POPs;
+       have_name = 1;
+    }
     if (MAXARG > 1)
        sv = POPs;
     if (!isGV(TOPs))
@@ -537,6 +543,8 @@ PP(pp_open)
        PUSHMARK(SP);
        XPUSHs(SvTIED_obj((SV*)gv, mg));
        XPUSHs(sv);
+       if (have_name)
+           XPUSHs(name);
        PUTBACK;
        ENTER;
        call_method("OPEN", G_SCALAR);
@@ -546,7 +554,7 @@ PP(pp_open)
     }
 
     tmps = SvPV(sv, len);
-    if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
+    if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
        PUSHi( (I32)PL_forkprocess );
     else if (PL_forkprocess == 0)              /* we are a new child */
        PUSHi(0);
@@ -1272,10 +1280,15 @@ PP(pp_leavewrite)
     fp = IoOFP(io);
     if (!fp) {
        if (ckWARN2(WARN_CLOSED,WARN_IO)) {
+           SV* sv = sv_newmortal();
+           gv_efullname3(sv, gv, Nullch);
            if (IoIFP(io))
-               Perl_warner(aTHX_ WARN_IO, "Filehandle only opened for input");
+               Perl_warner(aTHX_ WARN_IO,
+                           "Filehandle %s opened only for input",
+                           SvPV_nolen(sv));
            else if (ckWARN(WARN_CLOSED))
-               Perl_warner(aTHX_ WARN_CLOSED, "Write on closed filehandle");
+               Perl_warner(aTHX_ WARN_CLOSED,
+                           "Write on closed filehandle %s", SvPV_nolen(sv));
        }
        PUSHs(&PL_sv_no);
     }
@@ -1339,21 +1352,23 @@ PP(pp_prtf)
     sv = NEWSV(0,0);
     if (!(io = GvIO(gv))) {
        if (ckWARN(WARN_UNOPENED)) {
-           gv_fullname3(sv, gv, Nullch);
-           Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
+           gv_efullname3(sv, gv, Nullch);
+           Perl_warner(aTHX_ WARN_UNOPENED,
+                       "Filehandle %s never opened", SvPV(sv,n_a));
        }
        SETERRNO(EBADF,RMS$_IFI);
        goto just_say_no;
     }
     else if (!(fp = IoOFP(io))) {
        if (ckWARN2(WARN_CLOSED,WARN_IO))  {
-           gv_fullname3(sv, gv, Nullch);
+           gv_efullname3(sv, gv, Nullch);
            if (IoIFP(io))
-               Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input",
-                       SvPV(sv,n_a));
+               Perl_warner(aTHX_ WARN_IO,
+                           "Filehandle %s opened only for input",
+                           SvPV(sv,n_a));
            else if (ckWARN(WARN_CLOSED))
-               Perl_warner(aTHX_ WARN_CLOSED, "printf on closed filehandle %s",
-                       SvPV(sv,n_a));
+               Perl_warner(aTHX_ WARN_CLOSED,
+                           "printf on closed filehandle %s", SvPV(sv,n_a));
        }
        SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
        goto just_say_no;
@@ -1538,8 +1553,17 @@ PP(pp_sysread)
        if (length == 0 && PerlIO_error(IoIFP(io)))
            length = -1;
     }
-    if (length < 0)
+    if (length < 0) {
+       if (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
+           || IoIFP(io) == PerlIO_stderr())
+       {
+           SV* sv = sv_newmortal();
+           gv_efullname3(sv, gv, Nullch);
+           Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
+                       SvPV_nolen(sv));
+       }
        goto say_undef;
+    }
     SvCUR_set(bufsv, length+offset);
     *SvEND(bufsv) = '\0';
     (void)SvPOK_only(bufsv);
@@ -3561,6 +3585,8 @@ PP(pp_system)
     int status;
     Sigsave_t ihand,qhand;     /* place to save signals during system() */
     STRLEN n_a;
+    I32 did_pipes = 0;
+    int pp[2];
 
     if (SP - MARK == 1) {
        if (PL_tainting) {
@@ -3571,16 +3597,24 @@ PP(pp_system)
     }
     PERL_FLUSHALL_FOR_CHILD;
 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
+    if (PerlProc_pipe(pp) >= 0)
+       did_pipes = 1;
     while ((childpid = vfork()) == -1) {
        if (errno != EAGAIN) {
            value = -1;
            SP = ORIGMARK;
            PUSHi(value);
+           if (did_pipes) {
+               PerlLIO_close(pp[0]);
+               PerlLIO_close(pp[1]);
+           }
            RETURN;
        }
        sleep(5);
     }
     if (childpid > 0) {
+       if (did_pipes)
+           PerlLIO_close(pp[1]);
        rsignal_save(SIGINT, SIG_IGN, &ihand);
        rsignal_save(SIGQUIT, SIG_IGN, &qhand);
        do {
@@ -3591,28 +3625,54 @@ PP(pp_system)
        STATUS_NATIVE_SET(result == -1 ? -1 : status);
        do_execfree();  /* free any memory child malloced on vfork */
        SP = ORIGMARK;
+       if (did_pipes) {
+           int errkid;
+           int n = 0, n1;
+
+           while (n < sizeof(int)) {
+               n1 = PerlLIO_read(pp[0],
+                                 (void*)(((char*)&errkid)+n),
+                                 (sizeof(int)) - n);
+               if (n1 <= 0)
+                   break;
+               n += n1;
+           }
+           PerlLIO_close(pp[0]);
+           if (n) {                    /* Error */
+               if (n != sizeof(int))
+                   Perl_croak(aTHX_ "panic: kid popen errno read");
+               errno = errkid;         /* Propagate errno from kid */
+               STATUS_CURRENT = -1;
+           }
+       }
        PUSHi(STATUS_CURRENT);
        RETURN;
     }
+    if (did_pipes) {
+       PerlLIO_close(pp[0]);
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+       fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+#endif
+    }
     if (PL_op->op_flags & OPf_STACKED) {
        SV *really = *++MARK;
-       value = (I32)do_aexec(really, MARK, SP);
+       value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
     }
     else if (SP - MARK != 1)
-       value = (I32)do_aexec(Nullsv, MARK, SP);
+       value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
     else {
-       value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
+       value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
     }
     PerlProc__exit(-1);
 #else /* ! FORK or VMS or OS/2 */
     if (PL_op->op_flags & OPf_STACKED) {
        SV *really = *++MARK;
-       value = (I32)do_aspawn(aTHX_ really, (void **)MARK, (void **)SP);
+       value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
     }
     else if (SP - MARK != 1)
-       value = (I32)do_aspawn(aTHX_ Nullsv, (void **)MARK, (void **)SP);
+       value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
     else {
-       value = (I32)do_spawn(aTHX_ SvPVx(sv_mortalcopy(*SP), n_a));
+       value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
     }
     STATUS_NATIVE_SET(value);
     do_execfree();
@@ -3639,7 +3699,7 @@ PP(pp_exec)
 #else
 #  ifdef __OPEN_VM
        {
-          (void ) do_aspawn(aTHX_ Nullsv, MARK, SP);
+          (void ) do_aspawn(Nullsv, MARK, SP);
           value = 0;
        }
 #  else
@@ -3656,7 +3716,7 @@ PP(pp_exec)
        value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
 #else
 #  ifdef __OPEN_VM
-       (void) do_spawn(aTHX_ SvPVx(sv_mortalcopy(*SP), n_a));
+       (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
        value = 0;
 #  else
        value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));