In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/ffdb8b167ec4e9c0f37371dfd7b0abb01e413f90?hp=a8f52b62a9a286742b10878b4bb35fea1f0a012d>
- Log ----------------------------------------------------------------- commit ffdb8b167ec4e9c0f37371dfd7b0abb01e413f90 Author: Father Chrysostomos <[email protected]> Date: Sun Sep 1 00:30:59 2013 -0700 Fix two line numbers bugs involving quote-like ops I was going to try and fix #line directives in quote-like operators, but I found myself fixing bug #3643 at the same time. Before this commit, the #line directive would last until the end of the quote-ilke operator, but not beyond: qq{${ print __LINE__,"\n"; # 43 }}; print __LINE__,"\n"; # 5 The old method: The lexer would scan to find the closing delimiter after seeing qq{, incrementing the line number (CopLINE(PL_curcop)) as it went. Then it would enter a scope for parsing the contents of the string, with the line number localised and reset to the line of the qq{. When it finished parsing the contents of qq{...}, it would then pop the scope, restoring the previous value of the line number. According to the new method: When scanning to find the ending delimiter for qq{, the lexer still increments CopLINE(PL_curcop), but then sets it back immediately to the line of the first delimiter. When parsing the contents of qq{...}, the line number is *not* local- ised. Instead, thatâs when we increment CopLINE(PL_curcop) for real. Hence, scan_str no longer increments the line number (except before the starting delimiter). It is up to callers to handle that *or* call sublex_push. There is some special handling for here-docs. Here-docsâ line numbers have to increase while the body of the here-doc is being parsed, but then rewound back to the here-doc marker (<<END) when the code after it on the same line is parsed. Then when the next line break is reached, the line number is incremented by the appropriate number for it to hop over the here-doc body. We already have a mechanism for that, storing the number of lines in lex_shared->herelines. Parsing of here-docs still happens the old way, with line num- bers localised to the right scope. But now we have to move lex_shared->herelines into the inner scopeâs lex_shared struct when parsing a multiline quote other than a here-doc. One thing this commit does not handle yet is #line inside a here-doc. Bug #3643 was one symptom of a larger problem: During the parsing of the contents of a quote-like operator, the (localised) line number was incremented only in embedded code snip- pets, not in constants parts of the string. So "${ warn __LINE__, __LINE__, __LINE__ }" would correctly give â123â. But this would produce the same incorrectly: " foo bar baz ${ warn __LINE__, __LINE__, __LINE__ }" Now the parsing of the contents of the string increments the line num- ber in constant parts, too. M t/comp/parser.t M toke.c commit 25502127feba592f2312380b350122c445020707 Author: Father Chrysostomos <[email protected]> Date: Sat Aug 31 17:47:23 2013 -0700 [perl #115768] improve (caller)[2] line numbers warn and die have special code (closest_cop) to find a nulled nextstate op closest to the warn or die op, to get the line number from it. This commit extends that capability to caller, so that if (1) { foo(); } sub foo { warn +(caller)[2] } shows the right line number. M embed.fnc M embed.h M pp_ctl.c M proto.h M t/op/caller.t M util.c commit ecadf9b7005812a5eb20b351ef9bcd042c7e3daf Author: Father Chrysostomos <[email protected]> Date: Sat Aug 31 06:44:12 2013 -0700 test.pl:runperl: more portability warnings VMS treats initial < > | 2> and trailing & as special in command line arguments, so we should avoid them in tests. M t/test.pl commit a446b943f7a5b38f67cca69a513d873bc8335552 Author: Father Chrysostomos <[email protected]> Date: Fri Aug 30 14:50:43 2013 -0700 toke.c: Reorder checks around deprecate_escaped_meta ckWARN_d involves a function call, so put faster checks first. M toke.c commit fd6781a58d18dfad9bb46419ccb1acf5a86e2cf6 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 29 20:34:04 2013 -0700 perl5200delta: Remove Function::Parameters 1.0202 works with bleadperl. M Porting/perl5200delta.pod commit 082ae057d508f4560023f327db2757c3a90f4609 Author: Father Chrysostomos <[email protected]> Date: Thu Aug 29 00:49:10 2013 -0700 Mention Tk in perl5200delta See: https://rt.cpan.org/Ticket/Display.html?id=88210 https://rt.perl.org/rt3//Public/Bug/Display.html?id=118189 M Porting/perl5200delta.pod ----------------------------------------------------------------------- Summary of changes: Porting/perl5200delta.pod | 8 +++---- embed.fnc | 3 ++- embed.h | 2 +- pp_ctl.c | 7 +++++- proto.h | 10 ++++---- t/comp/parser.t | 10 +++++++- t/op/caller.t | 15 +++++++++++- t/test.pl | 12 ++++++++-- toke.c | 60 +++++++++++++++++++++++++++++++++++++++++++---- util.c | 18 +++++++++----- 10 files changed, 119 insertions(+), 26 deletions(-) diff --git a/Porting/perl5200delta.pod b/Porting/perl5200delta.pod index 098a880..15d862c 100644 --- a/Porting/perl5200delta.pod +++ b/Porting/perl5200delta.pod @@ -373,10 +373,6 @@ L<Error> version 0.17020 =item * -L<Function::Parameters> version 1.0201 - -=item * - L<HTML::StripScripts> version 1.05 =item * @@ -387,6 +383,10 @@ L<LaTeX::Encode> version 0.08 L<Mail::SpamAssasin> version 3.3.2 +=item + +L<Tk> version 804.031 + =back =back diff --git a/embed.fnc b/embed.fnc index f18ecb4..088086e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -258,6 +258,8 @@ ApR |UV |cast_uv |NV f #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) ApR |I32 |my_chsize |int fd|Off_t length #endif +p |const COP*|closest_cop |NN const COP *cop|NULLOK const OP *o \ + |NULLOK const OP *curop|bool opnext : Used in perly.y pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o : Used in op.c and perl.c @@ -2285,7 +2287,6 @@ s |bool |is_cur_LC_category_utf8|int category #endif #if defined(PERL_IN_UTIL_C) -s |const COP*|closest_cop |NN const COP *cop|NULLOK const OP *o s |SV* |mess_alloc s |SV * |with_queued_errors|NN SV *ex s |bool |invoke_exception_hook|NULLOK SV *ex|bool warn diff --git a/embed.h b/embed.h index 5ce9ed0..7708a61 100644 --- a/embed.h +++ b/embed.h @@ -1067,6 +1067,7 @@ #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) #define ck_tell(a) Perl_ck_tell(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) +#define closest_cop(a,b,c,d) Perl_closest_cop(aTHX_ a,b,c,d) #define convert(a,b,c) Perl_convert(aTHX_ a,b,c) #define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d) #define coresub_op(a,b,c) Perl_coresub_op(aTHX_ a,b,c) @@ -1667,7 +1668,6 @@ # endif # if defined(PERL_IN_UTIL_C) #define ckwarn_common(a) S_ckwarn_common(aTHX_ a) -#define closest_cop(a,b) S_closest_cop(aTHX_ a,b) #define invoke_exception_hook(a,b) S_invoke_exception_hook(aTHX_ a,b) #define mess_alloc() S_mess_alloc(aTHX) #define with_queued_errors(a) S_with_queued_errors(aTHX_ a) diff --git a/pp_ctl.c b/pp_ctl.c index b9ef68f..4ce8ddb 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1811,6 +1811,7 @@ PP(pp_caller) const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; + const COP *lcop; if (MAXARG) { if (has_arg) @@ -1854,7 +1855,11 @@ PP(pp_caller) PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); - mPUSHi((I32)CopLINE(cx->blk_oldcop)); + lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling, + cx->blk_sub.retop, TRUE); + if (!lcop) + lcop = cx->blk_oldcop; + mPUSHi((I32)CopLINE(lcop)); if (!has_arg) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { diff --git a/proto.h b/proto.h index a0329bb..a3106cb 100644 --- a/proto.h +++ b/proto.h @@ -663,6 +663,11 @@ PERL_CALLCONV void Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) PERL_CALLCONV bool Perl_ckwarn(pTHX_ U32 w); PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w); +PERL_CALLCONV const COP* Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, bool opnext) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CLOSEST_COP \ + assert(cop) + PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o) __attribute__warn_unused_result__; @@ -7519,11 +7524,6 @@ PERL_CALLCONV UV Perl__to_fold_latin1(pTHX_ const U8 c, U8 *p, STRLEN *lenp, con #endif #if defined(PERL_IN_UTIL_C) STATIC bool S_ckwarn_common(pTHX_ U32 w); -STATIC const COP* S_closest_cop(pTHX_ const COP *cop, const OP *o) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_CLOSEST_COP \ - assert(cop) - STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn); STATIC SV* S_mess_alloc(pTHX); STATIC SV * S_with_queued_errors(pTHX_ SV *ex) diff --git a/t/comp/parser.t b/t/comp/parser.t index 28412da..44106cb 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -8,7 +8,7 @@ BEGIN { chdir 't'; } -print "1..162\n"; +print "1..166\n"; sub failed { my ($got, $expected, $name) = @_; @@ -591,6 +591,14 @@ time #line 42 ;check('parser\.t', 42, 'line number after "nullary\n#line"'); +"${ +#line 53 +_}"; +check('parser\.t', 54, 'line number after qq"${#line}"'); + +#line 24 +" +${check('parser\.t', 25, 'line number inside qq/<newline>${...}/')}"; __END__ # Don't add new tests HERE. See note above diff --git a/t/op/caller.t b/t/op/caller.t index 09728d3..61a3816 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 92 ); + plan( tests => 94 ); } my @c; @@ -269,6 +269,19 @@ END is eval "(caller 0)[6]", "(caller 0)[6]", 'eval text returned by caller does not include \n;'; +if (1) { + is (sub { (caller)[2] }->(), __LINE__, + '[perl #115768] caller gets line numbers from nulled cops'); +} +# Test it at the end of the program, too. +fresh_perl_is(<<'115768', 2, {}, + if (1) { + foo(); + } + sub foo { print +(caller)[2] } +115768 + '[perl #115768] caller gets line numbers from nulled cops (2)'); + # PL_linestr should not be modifiable eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"'; pass "no assertion failure after modifying eval text via caller"; diff --git a/t/test.pl b/t/test.pl index c452c38..cdd72ea 100644 --- a/t/test.pl +++ b/t/test.pl @@ -606,8 +606,16 @@ sub _create_runperl { # Create the string to qx in runperl(). die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { - if ($prog =~ tr/'"// && !$args{non_portable}) { - warn "quotes in prog >>$prog<< are not portable"; + if (!$args{non_portable}) { + if ($prog =~ tr/'"//) { + warn "quotes in prog >>$prog<< are not portable"; + } + if ($prog =~ /^([<>|]|2>)/) { + warn "Initial $1 in prog >>$prog<< is not portable"; + } + if ($prog =~ /&\z/) { + warn "Trailing & in prog >>$prog<< is not portable"; + } } if ($is_mswin || $is_netware || $is_vms) { $runperl = $runperl . qq ( -e "$prog" ); diff --git a/toke.c b/toke.c index 2764709..556f0e7 100644 --- a/toke.c +++ b/toke.c @@ -307,6 +307,14 @@ static const char* const lex_state_names[] = { CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \ PL_parser->lex_shared->herelines = 0; \ } STMT_END +/* Called after scan_str to update CopLINE(PL_curcop), but only when there + * is no sublex_push to follow. */ +#define COPLINE_SET_FROM_MULTI_END \ + STMT_START { \ + CopLINE_set(PL_curcop, PL_multi_end); \ + if (PL_multi_end != PL_multi_start) \ + PL_parser->lex_shared->herelines = 0; \ + } STMT_END #ifdef DEBUGGING @@ -2584,8 +2592,13 @@ S_sublex_push(pTHX) { dVAR; LEXSHARED *shared; + const bool is_heredoc = + CopLINE(PL_curcop) == (line_t)PL_multi_start - 1; ENTER; + assert(CopLINE(PL_curcop) == (line_t)PL_multi_start + || CopLINE(PL_curcop) == (line_t)PL_multi_start - 1); + PL_lex_state = PL_sublex_info.super_state; SAVEBOOL(PL_lex_dojoin); SAVEI32(PL_lex_brackets); @@ -2598,7 +2611,8 @@ S_sublex_push(pTHX) SAVESPTR(PL_lex_repl); SAVEVPTR(PL_lex_inpat); SAVEI16(PL_lex_inwhat); - SAVECOPLINE(PL_curcop); + if (is_heredoc) + SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); SAVEPPTR(PL_bufend); SAVEPPTR(PL_oldbufptr); @@ -2611,6 +2625,7 @@ S_sublex_push(pTHX) SAVEGENERICPV(PL_lex_casestack); SAVEGENERICPV(PL_parser->lex_shared); SAVEBOOL(PL_parser->lex_re_reparsing); + SAVEI32(PL_copline); /* The here-doc parser needs to be able to peek into outer lexing scopes to find the body of the here-doc. So we put PL_linestr and @@ -2641,11 +2656,17 @@ S_sublex_push(pTHX) *PL_lex_casestack = '\0'; PL_lex_starts = 0; PL_lex_state = LEX_INTERPCONCAT; - CopLINE_set(PL_curcop, (line_t)PL_multi_start); + if (is_heredoc) + CopLINE_inc(PL_curcop); + PL_copline = NOLINE; Newxz(shared, 1, LEXSHARED); shared->ls_prev = PL_parser->lex_shared; PL_parser->lex_shared = shared; + if (!is_heredoc && PL_multi_start != PL_multi_end) { + shared->herelines = shared->ls_prev->herelines; + shared->ls_prev->herelines = 0; + } PL_lex_inwhat = PL_sublex_info.sub_inwhat; if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS; @@ -2710,6 +2731,12 @@ S_sublex_done(pTHX) PL_lex_state = LEX_INTERPCONCAT; PL_lex_repl = NULL; } + if (SvTYPE(PL_linestr) >= SVt_PVNV) { + CopLINE(PL_curcop) += + ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow + + PL_parser->lex_shared->herelines; + PL_parser->lex_shared->herelines = 0; + } return ','; } else { @@ -3827,6 +3854,11 @@ S_scan_const(pTHX_ char *start) /* return the substring (via pl_yylval) only if we parsed anything */ if (s > PL_bufptr) { + char *s2 = PL_bufptr; + for (; s2 < s; s2++) { + if (*s2 == '\n') + COPLINE_INC_WITH_HERELINES; + } SvREFCNT_inc_simple_void_NN(sv); if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING )) && ! PL_parser->lex_re_reparsing) @@ -4404,6 +4436,7 @@ S_readpipe_override(pTHX) && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe) && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))) { + COPLINE_SET_FROM_MULTI_END; PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */ @@ -5865,6 +5898,7 @@ Perl_yylex(pTHX) sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0); if (*d == '(') { d = scan_str(d,TRUE,TRUE,FALSE, FALSE); + COPLINE_SET_FROM_MULTI_END; if (!d) { /* MUST advance bufptr here to avoid bogus "at end of line" context messages from yyerror(). @@ -6768,6 +6802,7 @@ Perl_yylex(pTHX) case '\'': s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + COPLINE_SET_FROM_MULTI_END; DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { @@ -6802,6 +6837,8 @@ Perl_yylex(pTHX) break; } } + if (pl_yylval.ival == OP_CONST) + COPLINE_SET_FROM_MULTI_END; TERM(sublex_start()); case '`': @@ -8280,6 +8317,7 @@ Perl_yylex(pTHX) case KEY_q: s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + COPLINE_SET_FROM_MULTI_END; if (!s) missingterm(NULL); pl_yylval.ival = OP_CONST; @@ -8291,6 +8329,7 @@ Perl_yylex(pTHX) case KEY_qw: { OP *words = NULL; s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + COPLINE_SET_FROM_MULTI_END; if (!s) missingterm(NULL); PL_expect = XOPERATOR; @@ -8671,6 +8710,7 @@ Perl_yylex(pTHX) /* Look for a prototype */ if (*s == '(') { s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); + COPLINE_SET_FROM_MULTI_END; if (!s) Perl_croak(aTHX_ "Prototype not terminated"); (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO)); @@ -9654,6 +9694,7 @@ S_scan_subst(pTHX_ char *start) char *s; PMOP *pm; I32 first_start; + line_t first_line; I32 es = 0; char charset = '\0'; /* character set modifier */ #ifdef PERL_MAD @@ -9683,6 +9724,7 @@ S_scan_subst(pTHX_ char *start) #endif first_start = PL_multi_start; + first_line = CopLINE(PL_curcop); s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE); if (!s) { if (PL_lex_stuff) { @@ -9745,6 +9787,12 @@ S_scan_subst(pTHX_ char *start) SvREFCNT_dec(PL_sublex_info.repl); PL_sublex_info.repl = repl; } + if (CopLINE(PL_curcop) != first_line) { + sv_upgrade(PL_sublex_info.repl, SVt_PVNV); + ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow = + CopLINE(PL_curcop) - first_line; + CopLINE_set(PL_curcop, first_line); + } PL_lex_op = (OP*)pm; pl_yylval.ival = OP_SUBST; @@ -10400,6 +10448,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, STRLEN termlen; /* length of terminating string */ int last_off = 0; /* last position for nesting bracket */ char *escaped_open = NULL; + line_t herelines; #ifdef PERL_MAD int stuffstart; char *tstart; @@ -10439,6 +10488,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, /* mark where we are */ PL_multi_start = CopLINE(PL_curcop); PL_multi_open = term; + herelines = PL_parser->lex_shared->herelines; /* find corresponding closing delimiter */ if (term && (tmps = strchr("([{< )]}> )]}>",term))) @@ -10452,8 +10502,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, * happen for <>, as they aren't metas. */ if (deprecate_escaped_meta && (PL_multi_open == PL_multi_close - || ! ckWARN_d(WARN_DEPRECATED) - || PL_multi_open == '<')) + || PL_multi_open == '<' + || ! ckWARN_d(WARN_DEPRECATED))) { deprecate_escaped_meta = FALSE; } @@ -10792,6 +10842,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, SvUTF8_on(sv); PL_multi_end = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_multi_start); + PL_parser->lex_shared->herelines = herelines; /* if we allocated too much space, give some back */ if (SvCUR(sv) + 5 < SvLEN(sv)) { diff --git a/util.c b/util.c index 00f3821..0cd99f3 100644 --- a/util.c +++ b/util.c @@ -1178,15 +1178,20 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } -STATIC const COP* -S_closest_cop(pTHX_ const COP *cop, const OP *o) +const COP* +Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, + bool opnext) { dVAR; - /* Look for PL_op starting from o. cop is the last COP we've seen. */ + /* Look for curop starting from o. cop is the last COP we've seen. */ + /* opnext means that curop is actually the ->op_next of the op we are + seeking. */ PERL_ARGS_ASSERT_CLOSEST_COP; - if (!o || o == PL_op) + if (!o || !curop || ( + opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop + )) return cop; if (o->op_flags & OPf_KIDS) { @@ -1202,7 +1207,7 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) /* Keep searching, and return when we've found something. */ - new_cop = closest_cop(cop, kid); + new_cop = closest_cop(cop, kid, curop, opnext); if (new_cop) return new_cop; } @@ -1272,7 +1277,8 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) * from the sibling of PL_curcop. */ - const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + const COP *cop = + closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); if (!cop) cop = PL_curcop; -- Perl5 Master Repository
