In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/85897674662b45b047282279484f658e686f40ce?hp=2ba1f20ac3ac18b441a222cea2b0bbf6f3588c7d>
- Log ----------------------------------------------------------------- commit 85897674662b45b047282279484f658e686f40ce Author: Eric Brine <[email protected]> Date: Fri Jul 27 18:54:24 2012 -0400 Document return to be exempt from the looks-like-a-function rule, like dump, goto and next. M pod/perlfunc.pod commit 8a7e748e29326858b955baeaddced9b162d38518 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 27 14:52:21 2012 -0700 perlfunc: document last/next EXPR Also remove some repetitive text from goto, added in 2ba1f20ac3. M pod/perlfunc.pod commit 1eb0b7be2ff1216a955a7054a93a0c52c175ceab Author: Father Chrysostomos <[email protected]> Date: Fri Jul 27 14:41:05 2012 -0700 B::Deparse: loopexes have assignment prec See ticket #113684 for detail. M dist/B-Deparse/Deparse.pm M dist/B-Deparse/t/core.t M dist/B-Deparse/t/deparse.t commit 3daac4daa059f320ef363c5084b3d59ffc1341c4 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 27 14:37:22 2012 -0700 Increase $B::Deparse::VERSION to 1.16 M dist/B-Deparse/Deparse.pm commit 1f039d60d3646db9ab9065236e00c45cbf099138 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 27 14:26:39 2012 -0700 [perl #113684] Make redo/last/next/dump accept expr These functions have been allowing arbitrary expressions, but would treat anything that did not resolve to a const op as the empty string. Not only were arguments swallowed up without warning, but constant folding could change the behaviour. Computed labels are allowed for goto, and there is no reason to disallow them for these other ops. This can also come in handy for certain types of code generators. In the process of modifying pp functions to accept arbitrary labels, I noticed that the label and loop-popping code was identical in three functions, so I moved it out into a separate static function, to make the changes easier. I also had to reorder newLOOPEX significantly, because code under the goto branch needed to a apply to last, and vice versa. Using multiple gotos to switch between the branches created too much of a mess. I also eliminated the use of SP from pp_last, to avoid copying the value back and forth between SP and PL_stack_sp. M op.c M pp_ctl.c M t/lib/croak/pp_ctl M t/op/loopctl.t commit 4b7c0884db5c600085cea2e6463d72ec6e4357f9 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 27 13:36:35 2012 -0700 pp.h: Make [TP]OPp and [TP]OPpx identical In the absence of n_a (see 8c074e2a and 95fad918), there is no differ- ence between [TP]OPp and [TP]OPpx except speed, so there is no reason for the x-less variant to be deprecated. M pp.h commit d001e19df0fde97505a5873d77b2a28b66bd94b4 Author: Father Chrysostomos <[email protected]> Date: Fri Jul 27 13:02:13 2012 -0700 op.c: apidoc typo M op.c ----------------------------------------------------------------------- Summary of changes: dist/B-Deparse/Deparse.pm | 6 +- dist/B-Deparse/t/core.t | 2 +- dist/B-Deparse/t/deparse.t | 7 +++ op.c | 44 ++++++++++-------- pod/perlfunc.pod | 36 +++++++++++---- pp.h | 9 ++-- pp_ctl.c | 110 +++++++++++++++++++------------------------- t/lib/croak/pp_ctl | 6 ++ t/op/loopctl.t | 39 +++++++++++++++- 9 files changed, 158 insertions(+), 101 deletions(-) diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index f2bd0b6..0bbcbee 100644 --- a/dist/B-Deparse/Deparse.pm +++ b/dist/B-Deparse/Deparse.pm @@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring CVf_METHOD CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = '1.15'; +$VERSION = '1.16'; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -2155,10 +2155,10 @@ sub loopex { } elsif (class($op) eq "OP") { # no-op } elsif (class($op) eq "UNOP") { - (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//; + (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//; $name .= " $kid"; } - return $self->maybe_parens($name, $cx, 16); + return $self->maybe_parens($name, $cx, 7); } sub pp_last { loopex(@_, "last") } diff --git a/dist/B-Deparse/t/core.t b/dist/B-Deparse/t/core.t index 62ff862..de8d280 100644 --- a/dist/B-Deparse/t/core.t +++ b/dist/B-Deparse/t/core.t @@ -74,7 +74,7 @@ sub CORE_test { $deparse->coderef2text( eval "no strict 'vars'; sub { () = $expr }" or die "$@in $expr" ), - qr/\sCORE::$keyword.*;/, + qr/\bCORE::$keyword.*[);]/, $name||$keyword } diff --git a/dist/B-Deparse/t/deparse.t b/dist/B-Deparse/t/deparse.t index 04d64df..811adb6 100644 --- a/dist/B-Deparse/t/deparse.t +++ b/dist/B-Deparse/t/deparse.t @@ -1146,6 +1146,13 @@ $_ = ($a xor not +($1 || 2) ** 2); () = warn() + 1; () = setpgrp() + 1; #### +# loopexes have assignment prec +() = (CORE::dump a) | 'b'; +() = (goto a) | 'b'; +() = (last a) | 'b'; +() = (next a) | 'b'; +() = (redo a) | 'b'; +#### # [perl #63558] open local(*FH) open local *FH; pipe local *FH, local *FH; diff --git a/op.c b/op.c index 276dbd8..d24ea4d 100644 --- a/op.c +++ b/op.c @@ -6368,7 +6368,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) Constructs, checks, and returns a loop-exiting op (such as C<goto> or C<last>). I<type> is the opcode. I<label> supplies the parameter determining the target of the op; it is consumed by this function and -become part of the constructed op tree. +becomes part of the constructed op tree. =cut */ @@ -6385,37 +6385,41 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) if (type != OP_GOTO) { /* "last()" means "last" */ - if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) + if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { o = newOP(type, OPf_SPECIAL); - else { - const_label: - o = newPVOP(type, - label->op_type == OP_CONST - ? SvUTF8(((SVOP*)label)->op_sv) - : 0, - savesharedpv(label->op_type == OP_CONST - ? SvPV_nolen_const(((SVOP*)label)->op_sv) - : "")); + goto free_label; } -#ifdef PERL_MAD - op_getmad(label,o,'L'); -#else - op_free(label); -#endif } else { /* Check whether it's going to be a goto &function */ if (label->op_type == OP_ENTERSUB && !(label->op_flags & OPf_STACKED)) label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); - else if (label->op_type == OP_CONST) { + } + + /* Check for a constant argument */ + if (label->op_type == OP_CONST) { SV * const sv = ((SVOP *)label)->op_sv; STRLEN l; const char *s = SvPV_const(sv,l); - if (l == strlen(s)) goto const_label; - } - o = newUNOP(type, OPf_STACKED, label); + if (l == strlen(s)) { + o = newPVOP(type, + SvUTF8(((SVOP*)label)->op_sv), + savesharedpv( + SvPV_nolen_const(((SVOP*)label)->op_sv))); + free_label: +#ifdef PERL_MAD + op_getmad(label,o,'L'); +#else + op_free(label); +#endif + label = NULL; + } } + + /* If we still have a label op, we need to create a stacked unop. */ + if (label) o = newUNOP(type, OPf_STACKED, label); + PL_hints |= HINT_BLOCK_SCOPE; return o; } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index b1cc605..b76da4a 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1597,6 +1597,8 @@ file. Manual error checking can be done this way: =item dump LABEL X<dump> X<core> X<undump> +=item dump EXPR + =item dump =for Pod::Functions create an immediate core dump @@ -1609,7 +1611,9 @@ having initialized all your variables at the beginning of the program. When the new binary is executed it will begin by executing a C<goto LABEL> (with all the restrictions that C<goto> suffers). Think of it as a goto with an intervening core dump and reincarnation. -If C<LABEL> is omitted, restarts the program from the top. +If C<LABEL> is omitted, restarts the program from the top. The +C<dump EXPR> form, available starting in Perl 5.18.0, allows a name to be +computed at run time, being otherwise identical to C<dump LABEL>. B<WARNING>: Any files opened at the time of the dump will I<not> be open any more when the program is reincarnated, with possible @@ -2899,6 +2903,8 @@ necessarily recommended if you're optimizing for maintainability: As shown in this example, C<goto-EXPR> is exempt from the "looks like a function" rule. A pair of parentheses following it does not (necessarily) delimit its argument. C<goto("NE")."XT"> is equivalent to C<goto NEXT>. +Also, unlike most named operators, this has the same precedence as +assignment. Use of C<goto-LABEL> or C<goto-EXPR> to jump into a construct is deprecated and will issue a warning. Even then, it may not be used to @@ -2922,11 +2928,6 @@ NAME needn't be the name of a subroutine; it can be a scalar variable containing a code reference or a block that evaluates to a code reference. -Unlike most named operators, this has the same precedence as assignment. -It is also exempt from the looks-like-a-function rule, so -C<goto ("foo")."bar"> will cause "bar" to be part of the argument to -C<goto>. - =item grep BLOCK LIST X<grep> @@ -3222,13 +3223,18 @@ Portability issues: L<perlport/kill>. =item last LABEL X<last> X<break> +=item last EXPR + =item last =for Pod::Functions exit a block prematurely The C<last> command is like the C<break> statement in C (as used in loops); it immediately exits the loop in question. If the LABEL is -omitted, the command refers to the innermost enclosing loop. The +omitted, the command refers to the innermost enclosing +loop. The C<last EXPR> form, available starting in Perl +5.18.0, allows a label name to be computed at run time, +and is otherwise identical to C<last LABEL>. The C<continue> block, if any, is not executed: LINE: while (<STDIN>) { @@ -3743,6 +3749,8 @@ L<attributes>, and L<Attribute::Handlers>. =item next LABEL X<next> X<continue> +=item next EXPR + =item next =for Pod::Functions iterate a block prematurely @@ -3757,7 +3765,9 @@ the next iteration of the loop: Note that if there were a C<continue> block on the above, it would get executed even on discarded lines. If LABEL is omitted, the command -refers to the innermost enclosing loop. +refers to the innermost enclosing loop. The C<next EXPR> form, available +as of Perl 5.18.0, allows a label name to be computed at run time, being +otherwise identical to C<next LABEL>. C<next> cannot be used to exit a block which returns a value such as C<eval {}>, C<sub {}>, or C<do {}>, and should not be used to exit @@ -5550,6 +5560,8 @@ case pretty much any characters can be read. =item redo LABEL X<redo> +=item redo EXPR + =item redo =for Pod::Functions start this loop iteration over again @@ -5557,7 +5569,9 @@ X<redo> The C<redo> command restarts the loop block without evaluating the conditional again. The C<continue> block, if any, is not executed. If the LABEL is omitted, the command refers to the innermost enclosing -loop. Programs that want to lie to themselves about what was just input +loop. The C<redo EXPR> form, available starting in Perl 5.18.0, allows a +label name to be computed at run time, and is otherwise identical to C<redo +LABEL>. Programs that want to lie to themselves about what was just input normally use this command: # a simpleminded Pascal comment stripper @@ -5889,6 +5903,10 @@ scalar context, and (of course) nothing at all in void context. or do FILE automatically returns the value of the last expression evaluated.) +Unlike most named operators, this is also exempt from the +looks-like-a-function rule, so C<return ("foo")."bar"> will +cause "bar" to be part of the argument to C<return>. + =item reverse LIST X<reverse> X<rev> X<invert> diff --git a/pp.h b/pp.h index 7f1b770..1b29739 100644 --- a/pp.h +++ b/pp.h @@ -97,10 +97,11 @@ See C<PUSHMARK> and L<perlcall> for other uses. Pops an SV off the stack. =for apidoc Amn|char*|POPp -Pops a string off the stack. Deprecated. New code should use POPpx. +Pops a string off the stack. =for apidoc Amn|char*|POPpx -Pops a string off the stack. +Pops a string off the stack. Identical to POPp. There are two names for +historical reasons. =for apidoc Amn|char*|POPpbytex Pops a string off the stack which must consist of bytes i.e. characters < 256. @@ -123,7 +124,7 @@ Pops a long off the stack. #define RETURNX(x) return (x, PUTBACK, NORMAL) #define POPs (*sp--) -#define POPp (SvPVx(POPs, PL_na)) /* deprecated */ +#define POPp POPpx #define POPpx (SvPVx_nolen(POPs)) #define POPpconstx (SvPVx_nolen_const(POPs)) #define POPpbytex (SvPVbytex_nolen(POPs)) @@ -140,7 +141,7 @@ Pops a long off the stack. #define TOPs (*sp) #define TOPm1s (*(sp-1)) #define TOPp1s (*(sp+1)) -#define TOPp (SvPV(TOPs, PL_na)) /* deprecated */ +#define TOPp TOPpx #define TOPpx (SvPV_nolen(TOPs)) #define TOPn (SvNV(TOPs)) #define TOPi ((IV)SvIV(TOPs)) diff --git a/pp_ctl.c b/pp_ctl.c index f2119a7..1bec840 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2519,10 +2519,49 @@ PP(pp_leavesublv) return cx->blk_sub.retop; } -PP(pp_last) +static I32 +S_unwind_loop(pTHX_ const char * const opname) { - dVAR; dSP; + dVAR; I32 cxix; + if (PL_op->op_flags & OPf_SPECIAL) { + cxix = dopoptoloop(cxstack_ix); + if (cxix < 0) + /* diag_listed_as: Can't "last" outside a loop block */ + Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); + } + else { + dSP; + STRLEN label_len; + const char * const label = + PL_op->op_flags & OPf_STACKED + ? SvPV(TOPs,label_len) + : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); + const U32 label_flags = + PL_op->op_flags & OPf_STACKED + ? SvUTF8(POPs) + : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; + PUTBACK; + cxix = dopoptolabel(label, label_len, label_flags); + if (cxix < 0) + /* diag_listed_as: Label not found for "last %s" */ + Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", + opname, + SVfARG(PL_op->op_flags & OPf_STACKED + && !SvGMAGICAL(TOPp1s) + ? TOPp1s + : newSVpvn_flags(label, + label_len, + label_flags | SVs_TEMP))); + } + if (cxix < cxstack_ix) + dounwind(cxix); + return cxix; +} + +PP(pp_last) +{ + dVAR; register PERL_CONTEXT *cx; I32 pop2 = 0; I32 gimme; @@ -2533,24 +2572,7 @@ PP(pp_last) SV **mark; SV *sv = NULL; - - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"last\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv), - (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"last %"SVf"\"", - SVfARG(newSVpvn_flags(cPVOP->op_pv, - strlen(cPVOP->op_pv), - ((cPVOP->op_private & OPpPV_IS_UTF8) - ? SVf_UTF8 : 0) | SVs_TEMP))); - } - if (cxix < cxstack_ix) - dounwind(cxix); + S_unwind_loop(aTHX_ "last"); POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2581,9 +2603,8 @@ PP(pp_last) } TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, + PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme, pop2 == CXt_SUB ? SVs_TEMP : 0); - PUTBACK; LEAVE; cxstack_ix--; @@ -2611,31 +2632,13 @@ PP(pp_last) PP(pp_next) { dVAR; - I32 cxix; register PERL_CONTEXT *cx; - I32 inner; + const I32 inner = PL_scopestack_ix; - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"next\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv), - (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"next %"SVf"\"", - SVfARG(newSVpvn_flags(cPVOP->op_pv, - strlen(cPVOP->op_pv), - ((cPVOP->op_private & OPpPV_IS_UTF8) - ? SVf_UTF8 : 0) | SVs_TEMP))); - } - if (cxix < cxstack_ix) - dounwind(cxix); + S_unwind_loop(aTHX_ "next"); /* clear off anything above the scope we're re-entering, but * save the rest until after a possible continue block */ - inner = PL_scopestack_ix; TOPBLOCK(cx); if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); @@ -2646,30 +2649,11 @@ PP(pp_next) PP(pp_redo) { dVAR; - I32 cxix; + const I32 cxix = S_unwind_loop(aTHX_ "redo"); register PERL_CONTEXT *cx; I32 oldsave; - OP* redo_op; - - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"redo\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv), - (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"redo %"SVf"\"", - SVfARG(newSVpvn_flags(cPVOP->op_pv, - strlen(cPVOP->op_pv), - ((cPVOP->op_private & OPpPV_IS_UTF8) - ? SVf_UTF8 : 0) | SVs_TEMP))); - } - if (cxix < cxstack_ix) - dounwind(cxix); + OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; - redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl index 0f075cd..b62b526 100644 --- a/t/lib/croak/pp_ctl +++ b/t/lib/croak/pp_ctl @@ -1,4 +1,10 @@ __END__ +# NAME dump with computed label +my $label = "foo"; +dump $label; +EXPECT +Can't find label foo at - line 2. +######## # NAME when outside given use 5.01; when(undef){} diff --git a/t/op/loopctl.t b/t/op/loopctl.t index d28c191..fcb1237 100644 --- a/t/op/loopctl.t +++ b/t/op/loopctl.t @@ -36,7 +36,7 @@ BEGIN { } require "test.pl"; -plan( tests => 61 ); +plan( tests => 64 ); my $ok; @@ -1067,3 +1067,40 @@ cmp_ok($ok,'==',1,'dynamically scoped'); "constant optimization doesn't change return value"); } } + +# [perl #113684] +last_113684: +{ + label1: + { + my $label = "label1"; + eval { last $label }; + fail("last with non-constant label"); + last last_113684; + } + pass("last with non-constant label"); +} +next_113684: +{ + label2: + { + my $label = "label2"; + eval { next $label }; + fail("next with non-constant label"); + next next_113684; + } + pass("next with non-constant label"); +} +redo_113684: +{ + my $count; + label3: + { + if ($count++) { + pass("redo with non-constant label"); last redo_113684 + } + my $label = "label3"; + eval { redo $label }; + fail("redo with non-constant label"); + } +} -- Perl5 Master Repository
