Fix one test message, add two tests.

[perl5.git] / doio.c

diff --git a/doio.c b/doio.c
index a631eeb..b84a14a 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -782,7 +782,6 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
            *s = 'w';
            if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
                PerlIO_close(fp);
-               IoIFP(io) = NULL;
                goto say_false;
            }
        }
@@ -799,7 +798,7 @@ say_false:
 }
 
 PerlIO *
-Perl_nextargv(pTHX_ GV *gv)
+Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
 {
     IO * const io = GvIOp(gv);
 
@@ -807,7 +806,7 @@ Perl_nextargv(pTHX_ GV *gv)
 
     if (!PL_argvoutgv)
        PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
-    if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
+    if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
        IoFLAGS(io) &= ~IOf_START;
        if (PL_inplace) {
            assert(PL_defoutgv);
@@ -837,7 +836,10 @@ Perl_nextargv(pTHX_ GV *gv)
        SvSETMAGIC(GvSV(gv));
        PL_oldname = SvPVx(GvSV(gv), oldlen);
         if (LIKELY(!PL_inplace)) {
-            if (do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)) {
+            if (nomagicopen
+                    ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
+                    : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
+               ) {
                 return IoIFP(GvIOp(gv));
             }
         }
@@ -1041,7 +1043,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
        }
        return FALSE;
     }
-    retval = io_close(io, not_implicit);
+    retval = io_close(io, NULL, not_implicit, FALSE);
     if (not_implicit) {
        IoLINES(io) = 0;
        IoPAGE(io) = 0;
@@ -1052,7 +1054,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 }
 
 bool
-Perl_io_close(pTHX_ IO *io, bool not_implicit)
+Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
 {
     bool retval = FALSE;
 
@@ -1074,15 +1076,36 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
        else {
            if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {          /* a socket */
                const bool prev_err = PerlIO_error(IoOFP(io));
+#ifdef USE_PERLIO
+               if (prev_err)
+                   PerlIO_restore_errno(IoOFP(io));
+#endif
                retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
                PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
            }
            else {
                const bool prev_err = PerlIO_error(IoIFP(io));
+#ifdef USE_PERLIO
+               if (prev_err)
+                   PerlIO_restore_errno(IoIFP(io));
+#endif
                retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
            }
        }
        IoOFP(io) = IoIFP(io) = NULL;
+
+       if (warn_on_fail && !retval) {
+           if (gv)
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
+                               "Warning: unable to close filehandle %"
+                                HEKf" properly: %"SVf,
+                                GvNAME_HEK(gv), get_sv("!",GV_ADD));
+           else
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
+                               "Warning: unable to close filehandle "
+                               "properly: %"SVf,
+                                get_sv("!",GV_ADD));
+       }
     }
     else if (not_implicit) {
        SETERRNO(EBADF,SS_IVCHAN);
@@ -1126,7 +1149,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 (gv != PL_argvgv || !nextargv(gv))       /* get another fp handy */
+           if (gv != PL_argvgv || !nextargv(gv, FALSE))        /* get another fp handy */
                return TRUE;
        }
        else
@@ -1759,6 +1782,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 #endif
                    }
                    else {
+                        SETERRNO(EBADF,RMS_IFI);
                        tot--;
                    }
                }
@@ -1799,6 +1823,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 #endif
                    }
                    else {
+                        SETERRNO(EBADF,RMS_IFI);
                        tot--;
                    }
                }