The parser should always close the file handle that it opened.smoke-me/RT37033

Previously it would leave the file handle open if it was (equal to) stdin,
on the assumption that this must have been because no script name was
supplied on the interpreter command line, so the interpreter was defaulting
to reading the script from standard input.

However, if the program has closed STDIN, then the next file handle opened
(for any reason) will have file descriptor 0. So in this situation, the
handle that require opened to read the module would be mistaken for the above
situation and left open. Effectively, this leaked a file handle.

This is now fixed, by explicitly tracking from parser creation time whether
it should keep the file handle open, and only setting this flag when
defaulting to reading the main program from standard input. This resolves
RT #37033.

6 files changed, 63 insertions, 7 deletions

diff --git a/MANIFEST b/MANIFEST
index 720385ddf8..e16b435a36 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5304,6 +5304,7 @@ t/op/read.t			See if read() works
 t/op/recurse.t			See if deep recursion works
 t/op/ref.t			See if refs and objects work
 t/op/repeat.t			See if x operator works
+t/op/require_37033.t		See if require always closes rsfp
 t/op/require_errors.t		See if errors from require are reported correctly
 t/op/reset.t			See if reset operator works
 t/op/reverse.t			See if reverse operator works
diff --git a/parser.h b/parser.h
index 3a32e1fe60..1e9c71d3ce 100644
--- a/parser.h
+++ b/parser.h
@@ -120,9 +120,10 @@ typedef struct yy_parser {
 # define LEX_IGNORE_UTF8_HINTS	0x00000002
 # define LEX_EVALBYTES		0x00000004
 # define LEX_START_COPIED	0x00000008
+# define LEX_DONT_CLOSE_RSFP	0x00000010
 # define LEX_START_FLAGS \
 	(LEX_START_SAME_FILTER|LEX_START_COPIED \
-	|LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES)
+	|LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES|LEX_DONT_CLOSE_RSFP)
 #endif
 
 /* flags for parser API */
diff --git a/perl.c b/perl.c
index 3610780ca3..104cac7c8a 100644
--- a/perl.c
+++ b/perl.c
@@ -1803,6 +1803,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #endif
     SV *linestr_sv = newSV_type(SVt_PVIV);
     bool add_read_e_script = FALSE;
+    U32 lex_start_flags = 0;
 
     PERL_SET_PHASE(PERL_PHASE_START);
 
@@ -2076,6 +2077,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	rsfp = open_script(scriptname, dosearch, &suidscript);
 	if (!rsfp) {
 	    rsfp = PerlIO_stdin();
+	    lex_start_flags = LEX_DONT_CLOSE_RSFP;
 	}
 
 	validate_suid(validarg, scriptname, fdscript, suidscript,
@@ -2231,7 +2233,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
 #endif
 
-    lex_start(linestr_sv, rsfp, 0);
+    lex_start(linestr_sv, rsfp, lex_start_flags);
     PL_subname = newSVpvs("main");
 
     if (add_read_e_script)
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 40a1f425d7..dbdd49206e 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -243,7 +243,10 @@ that they represent may be covered elsewhere.
 
 =item *
 
-XXX
+F<t/op/require_37033.t> has been added, to test that C<require> always closes
+the file handle that it opens. Previously, it had been leaking the file handle
+if it happened to have file descriptor 0, which would happen if C<require> was
+called (explicitly or implicitly) when C<STDIN> had been closed.
 
 =back
 
diff --git a/t/op/require_37033.t b/t/op/require_37033.t
new file mode 100644
index 0000000000..dac8568010
--- /dev/null
+++ b/t/op/require_37033.t
@@ -0,0 +1,42 @@
+#!perl -w
+use strict;
+
+# Check that require doesn't leave the handle it uses open, if it happens that
+# the handle it opens gets file descriptor 0. RT #37033.
+
+require './test.pl';
+@INC = 'lib';
+
+sub test_require {
+    my ($state, $want) = @_;
+    delete $INC{'test_use_14937.pm'};
+    open my $fh, '<', 'README' or die "Can't open README: $!";
+    my $fileno = fileno $fh;
+    if (defined $want) {
+	is($fileno, $want,
+	   "file handle has correct numeric file descriptor $state");
+    } else {
+	like($fileno, qr/\A\d+\z/,
+	     "file handle has a numeric file descriptor $state");
+    }
+    close $fh or die;
+
+    is($INC{'test_use_14937.pm'}, undef, "test_use_14937 isn't loaded $state");
+    require test_use_14937;
+    isnt($INC{'test_use_14937.pm'}, undef, "test_use_14937 is loaded $state");
+
+    open $fh, '<', 'README' or die "Can't open README: $!";
+    is(fileno $fh, $fileno,
+       "file handle has the same numeric file descriptor $state");
+    close $fh or die;
+}
+
+is(fileno STDIN, 0, 'STDIN is open on file descriptor 0');
+test_require('(STDIN open)');
+
+close STDIN or die "Can't close STDIN: $!";
+
+is(fileno STDIN, undef, 'STDIN is closed');
+test_require('(STDIN closed)', 0);
+
+done_testing();
diff --git a/toke.c b/toke.c
index bec4b211cf..9e3c03c551 100644
--- a/toke.c
+++ b/toke.c
@@ -684,7 +684,13 @@ used by perl internally, so extensions should always pass zero.
 */
 
 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
-   can share filters with the current parser. */
+   can share filters with the current parser.
+   LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
+   caller, hence isn't owned by the parser, so shouldn't be closed on parser
+   destruction. This is used to handle the case of defaulting to reading the
+   script from the standard input because no filename was given on the command
+   line (without getting confused by situation where STDIN has been closed, so
+   the script handle is opened on fd 0)  */
 
 void
 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
@@ -751,7 +757,8 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
 	parser->linestart = SvPVX(parser->linestr);
     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
     parser->last_lop = parser->last_uni = NULL;
-    parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES);
+    parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+				 |LEX_DONT_CLOSE_RSFP);
 
     parser->in_pod = parser->filtered = 0;
 }
@@ -767,7 +774,7 @@ Perl_parser_free(pTHX_  const yy_parser *parser)
     PL_curcop = parser->saved_curcop;
     SvREFCNT_dec(parser->linestr);
 
-    if (parser->rsfp == PerlIO_stdin())
+    if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
 	PerlIO_clearerr(parser->rsfp);
     else if (parser->rsfp && (!parser->old_parser ||
 		(parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
@@ -1283,7 +1290,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
 	/* End of real input.  Close filehandle (unless it was STDIN),
 	 * then add implicit termination.
 	 */
-	if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
+	if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
 	    PerlIO_clearerr(PL_parser->rsfp);
 	else if (PL_parser->rsfp)
 	    (void)PerlIO_close(PL_parser->rsfp);