Forgotten deMANIFESTation.

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

diff --git a/doio.c b/doio.c
index ab74d4a..eeb9720 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -572,8 +572,6 @@ 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
               is assigned to (say) STDOUT - for now let dup2() fail
               and provide the error
@@ -584,25 +582,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);
@@ -997,7 +1015,7 @@ Perl_do_eof(pTHX_ GV *gv)
                PerlIO_set_cnt(IoIFP(io),-1);
        }
        if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
-           if (!nextargv(PL_argvgv))   /* get another fp handy */
+           if (gv != PL_argvgv || !nextargv(gv))       /* get another fp handy */
                return TRUE;
        }
        else
@@ -1223,7 +1241,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        }
        else if (DO_UTF8(sv)) {
            if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
-               && ckWARN(WARN_UTF8))
+               && ckWARN_d(WARN_UTF8))
            {
                Perl_warner(aTHX_ WARN_UTF8, "Wide character in print");
            }
@@ -1308,13 +1326,22 @@ Perl_my_lstat(pTHX)
                Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
            return PL_laststatval;
        }
-       Perl_croak(aTHX_ "You can't use -l on a filehandle");
+       if (ckWARN(WARN_IO)) {
+           Perl_warner(aTHX_ WARN_IO, "Use of -l on filehandle %s",
+                   GvENAME(cGVOP_gv));
+           return (PL_laststatval = -1);
+       }
     }
 
     PL_laststype = OP_LSTAT;
     PL_statgv = Nullgv;
     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",
+               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'))