Merge the fixes for RT #37033 into blead.

9 files changed, 86 insertions, 34 deletions

diff --git a/MANIFEST b/MANIFEST
index 05a47fa1e8..92efe61391 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/embed.fnc b/embed.fnc
index a7e004fe26..5c380fffd5 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1784,8 +1784,8 @@ s	|void	|init_postdump_symbols|int argc|NN char **argv|NULLOK char **env
 s	|void	|init_predump_symbols
 rs	|void	|my_exit_jump
 s	|void	|nuke_stacks
-s	|int	|open_script	|NN const char *scriptname|bool dosearch \
-				|NN bool *suidscript|NN PerlIO **rsfpp
+s	|PerlIO *|open_script	|NN const char *scriptname|bool dosearch \
+				|NN bool *suidscript
 sr	|void	|usage
 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
 so	|void	|validate_suid	|NN PerlIO *rsfp
diff --git a/embed.h b/embed.h
index 541309e42e..9fdf91b7ce 100644
--- a/embed.h
+++ b/embed.h
@@ -1439,7 +1439,7 @@
 #define minus_v()		S_minus_v(aTHX)
 #define my_exit_jump()		S_my_exit_jump(aTHX)
 #define nuke_stacks()		S_nuke_stacks(aTHX)
-#define open_script(a,b,c,d)	S_open_script(aTHX_ a,b,c,d)
+#define open_script(a,b,c)	S_open_script(aTHX_ a,b,c)
 #define parse_body(a,b)		S_parse_body(aTHX_ a,b)
 #define run_body(a)		S_run_body(aTHX_ a)
 #define usage()			S_usage(aTHX)
diff --git a/parser.h b/parser.h
index 931ebd6f35..1e9c71d3ce 100644
--- a/parser.h
+++ b/parser.h
@@ -106,7 +106,7 @@ typedef struct yy_parser {
     char	tokenbuf[256];
 
     U8		lex_fakeeof;	/* precedence at which to fake EOF */
-    PERL_BITFIELD16	lex_flags:14;
+    U8		lex_flags;
     PERL_BITFIELD16	in_pod:1;      /* lexer is within a =pod section */
     PERL_BITFIELD16	filtered:1;    /* source filters in evalbytes */
 } yy_parser;
@@ -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 551867501c..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);
 
@@ -2073,7 +2074,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     {
 	bool suidscript = FALSE;
 
-	open_script(scriptname, dosearch, &suidscript, &rsfp);
+	rsfp = open_script(scriptname, dosearch, &suidscript);
+	if (!rsfp) {
+	    rsfp = PerlIO_stdin();
+	    lex_start_flags = LEX_DONT_CLOSE_RSFP;
+	}
 
 	validate_suid(validarg, scriptname, fdscript, suidscript,
 		      linestr_sv, rsfp);
@@ -2228,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)
@@ -3614,11 +3619,11 @@ S_init_main_stash(pTHX)
     sv_setpvs(get_sv("/", GV_ADD), "\n");
 }
 
-STATIC int
-S_open_script(pTHX_ const char *scriptname, bool dosearch,
-	      bool *suidscript, PerlIO **rsfpp)
+STATIC PerlIO *
+S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 {
     int fdscript = -1;
+    PerlIO *rsfp = NULL;
     dVAR;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
@@ -3668,16 +3673,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
 	scriptname = (char *)"";
     if (fdscript >= 0) {
-	*rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
-#       if defined(HAS_FCNTL) && defined(F_SETFD)
-	    if (*rsfpp)
-                /* ensure close-on-exec */
-	        fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
-#       endif
+	rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
     }
     else if (!*scriptname) {
 	forbid_setid(0, *suidscript);
-	*rsfpp = PerlIO_stdin();
+	return NULL;
     }
     else {
 #ifdef FAKE_BIT_BUCKET
@@ -3712,7 +3712,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
 #endif
 	}
 #endif
-	*rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+	rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
 #ifdef FAKE_BIT_BUCKET
 	if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
 		  sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
@@ -3721,13 +3721,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
 	}
 	scriptname = BIT_BUCKET;
 #endif
-#       if defined(HAS_FCNTL) && defined(F_SETFD)
-	    if (*rsfpp)
-                /* ensure close-on-exec */
-	        fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
-#       endif
     }
-    if (!*rsfpp) {
+    if (!rsfp) {
 	/* PSz 16 Sep 03  Keep neat error message */
 	if (PL_e_script)
 	    Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
@@ -3735,7 +3730,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch,
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
-    return fdscript;
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+    /* ensure close-on-exec */
+    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+#endif
+    return rsfp;
 }
 
 /* Mention
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/proto.h b/proto.h
index f01e7c3cdf..dd3fd587de 100644
--- a/proto.h
+++ b/proto.h
@@ -5925,12 +5925,11 @@ STATIC void	S_my_exit_jump(pTHX)
 			__attribute__noreturn__;
 
 STATIC void	S_nuke_stacks(pTHX);
-STATIC int	S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript, PerlIO **rsfpp)
+STATIC PerlIO *	S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 			__attribute__nonnull__(pTHX_1)
-			__attribute__nonnull__(pTHX_3)
-			__attribute__nonnull__(pTHX_4);
+			__attribute__nonnull__(pTHX_3);
 #define PERL_ARGS_ASSERT_OPEN_SCRIPT	\
-	assert(scriptname); assert(suidscript); assert(rsfpp)
+	assert(scriptname); assert(suidscript)
 
 STATIC void*	S_parse_body(pTHX_ char **env, XSINIT_t xsinit);
 STATIC void	S_run_body(pTHX_ I32 oldscope)
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 c7194df993..829ff86a3b 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);