diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | parser.h | 3 | ||||
| -rw-r--r-- | perl.c | 4 | ||||
| -rw-r--r-- | pod/perldelta.pod | 5 | ||||
| -rw-r--r-- | t/op/require_37033.t | 42 | ||||
| -rw-r--r-- | toke.c | 15 |
6 files changed, 63 insertions, 7 deletions
@@ -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 @@ -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 */ @@ -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(); @@ -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); |