[perl #57512] Warnings for implicitly closed handles
authorFather Chrysostomos <sprout@cpan.org>
Thu, 18 Sep 2014 05:16:58 +0000 (21:16 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 3 Nov 2014 02:23:43 +0000 (18:23 -0800)
If the implicit close() fails, warn about it, mentioning $! in the
message.  This is a default warning in the io category.

We do this in two spots, sv_clear and gp_free.  While sv_clear would
be sufficient to get the warning emitted, the warning won’t contain
the name of the handle when called from there, because lone IO thing-
ies are nameless.  Doing it also when a GV’s glob pointer is freed--as
long as the IO thingy in there has a reference count of 1--allows the
name to be included in the message, because we still have the glob,
which is where the name is stored.

The result:

$ ./miniperl -Ilib -e 'open fh, ">/Volumes/Disk Image/foo"; print fh "x"x1000, "\n" for 1..50; undef *fh'
Warning: unable to close filehandle fh properly: No space left on device at -e line 1.

doio.c
embed.fnc
embed.h
gv.c
pod/perldiag.pod
proto.h
sv.c
t/io/eintr.t
t/op/lexsub.t

diff --git a/doio.c b/doio.c
index 1df3535..6087612 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1043,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;
@@ -1054,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;
 
@@ -1093,6 +1093,19 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit)
            }
        }
        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);
index ab5bb0d..78ad3d8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -651,7 +651,8 @@ Ap  |void   |init_tm        |NN struct tm *ptm
 : Used in perly.y
 AnpPR  |char*  |instr          |NN const char* big|NN const char* little
 : Used in sv.c
-p      |bool   |io_close       |NN IO* io|bool not_implicit
+p      |bool   |io_close       |NN IO* io|NULLOK GV *gv \
+                               |bool not_implicit|bool warn_on_fail
 : Used in perly.y
 pR     |OP*    |invert         |NULLOK OP* cmd
 ApR    |I32    |is_lvalue_sub
diff --git a/embed.h b/embed.h
index b9ff3c6..1a98de5 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define init_constants()       Perl_init_constants(aTHX)
 #define init_debugger()                Perl_init_debugger(aTHX)
 #define invert(a)              Perl_invert(aTHX_ a)
-#define io_close(a,b)          Perl_io_close(aTHX_ a,b)
+#define io_close(a,b,c,d)      Perl_io_close(aTHX_ a,b,c,d)
 #define isinfnansv(a)          Perl_isinfnansv(aTHX_ a)
 #define jmaybe(a)              Perl_jmaybe(aTHX_ a)
 #define keyword(a,b,c)         Perl_keyword(aTHX_ a,b,c)
diff --git a/gv.c b/gv.c
index 7abc6cc..c8d4345 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2515,6 +2515,16 @@ Perl_gp_free(pTHX_ GV *gv)
            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
        SvREFCNT_dec(hv);
       }
+      if (io && SvREFCNT(io) == 1 && IoIFP(io)
+            && (IoTYPE(io) == IoTYPE_WRONLY ||
+                IoTYPE(io) == IoTYPE_RDWR   ||
+                IoTYPE(io) == IoTYPE_APPEND)
+            && ckWARN_d(WARN_IO)
+            && IoIFP(io) != PerlIO_stdin()
+            && IoIFP(io) != PerlIO_stdout()
+            && IoIFP(io) != PerlIO_stderr()
+            && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+       io_close(io, gv, FALSE, TRUE);
       SvREFCNT_dec(io);
       SvREFCNT_dec(cv);
       SvREFCNT_dec(form);
index 3cc009a..4c61146 100644 (file)
@@ -6803,6 +6803,13 @@ you called it with no args and C<$@> was empty.
 the close().  This usually indicates your file system ran out of disk
 space.
 
+=item Warning: unable to close filehandle properly: %s
+
+=item Warning: unable to close filehandle %s properly: %s
+
+(S io) An error occurred when Perl implicitly closed a filehandle.  This
+usually indicates your file system ran out of disk space.
+
 =item Warning: Use of "%s" without parentheses is ambiguous
 
 (S ambiguous) You wrote a unary operator followed by something that
diff --git a/proto.h b/proto.h
index 3835a17..6741563 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1834,7 +1834,7 @@ PERL_CALLCONV U32 Perl_intro_my(pTHX);
 PERL_CALLCONV OP*      Perl_invert(pTHX_ OP* cmd)
                        __attribute__warn_unused_result__;
 
-PERL_CALLCONV bool     Perl_io_close(pTHX_ IO* io, bool not_implicit)
+PERL_CALLCONV bool     Perl_io_close(pTHX_ IO* io, GV *gv, bool not_implicit, bool warn_on_fail)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_IO_CLOSE      \
        assert(io)
diff --git a/sv.c b/sv.c
index 70683a1..f398a93 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6493,7 +6493,10 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                IoIFP(sv) != PerlIO_stderr() &&
                !(IoFLAGS(sv) & IOf_FAKE_DIRP))
            {
-               io_close(MUTABLE_IO(sv), FALSE);
+               io_close(MUTABLE_IO(sv), NULL, FALSE,
+                        (IoTYPE(sv) == IoTYPE_WRONLY ||
+                         IoTYPE(sv) == IoTYPE_RDWR   ||
+                         IoTYPE(sv) == IoTYPE_APPEND));
            }
            if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
                PerlDir_close(IoDIRP(sv));
index fd19b8a..ca15232 100644 (file)
@@ -69,6 +69,7 @@ plan(tests => 10);
 # make two handles that will always block
 
 sub fresh_io {
+       close $in if $in; close $out if $out;
        undef $in; undef $out; # use fresh handles each time
        pipe $in, $out;
        $sigst = "";
index cbf44ae..385aaee 100644 (file)
@@ -373,7 +373,10 @@ like runperl(
      progs => [ split "\n",
       'use feature qw - lexical_subs state -;
        no warnings q-experimental::lexical_subs-;
-       sub DB::sub{ print qq|4\n|; goto $DB::sub }
+       sub DB::sub{
+         print qq|4\n| unless $DB::sub =~ DESTROY;
+         goto $DB::sub
+       }
        state sub foo {print qq|2\n|}
        foo();
       '
@@ -753,7 +756,10 @@ pass "pad taking ownership once more of packagified my-sub";
      progs => [ split "\n",
       'use feature qw - lexical_subs state -;
        no warnings q-experimental::lexical_subs-;
-       sub DB::sub{ print qq|4\n|; goto $DB::sub }
+       sub DB::sub{
+         print qq|4\n| unless $DB::sub =~ DESTROY;
+         goto $DB::sub
+       }
        my sub foo {print qq|2\n|}
        foo();
       '