[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.

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);

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

embed.h

@@ -1185,7 +1185,7 @@
 #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)

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);

pod/perldiag.pod

@@ -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

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)

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));

t/io/eintr.t

@@ -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 = "";

t/op/lexsub.t

@@ -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();
       '