[perl #57512] Warnings for implicitly closed handles

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.

1 files changed, 15 insertions, 2 deletions

diff --git a/doio.c b/doio.c
index 1df3535092..60876127b5 100644
--- 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);