In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f3515641172f14301235d89dff009456a47e7daf?hp=fda8e777fa2df245de209839b8b21252b2f12c47>
- Log ----------------------------------------------------------------- commit f3515641172f14301235d89dff009456a47e7daf Author: Father Chrysostomos <[email protected]> Date: Thu Oct 2 14:13:20 2014 -0700 Deparse âlocal ourâ Deparse was omitting the âourâ. M lib/B/Deparse.pm M lib/B/Deparse.t commit 70d363bd195a2a49d6bcc3056325336f88954b00 Author: Father Chrysostomos <[email protected]> Date: Thu Oct 2 14:13:15 2014 -0700 Keep concise-xs.t happy M ext/B/t/concise-xs.t commit c8ec376c37745331f05b004c0212a85156dca42d Author: Father Chrysostomos <[email protected]> Date: Thu Oct 2 13:38:12 2014 -0700 Deparse \(..., (@a), ...) correctly It is the presence of parentheses immediately around the array (and possibly local/our/my/+) in refgen context, rather than parentheses surrounding the argument to \, that causes the array to be flattened. B::Deparse was deparsing \(@a) correctly, but not \(@a, (@b)), in which takes a reference to @a and to each of @bâs elements. It was omitting the parentheses around @b. M lib/B/Deparse.pm M lib/B/Deparse.t commit a2167ea9aa2930062a9c589acf175b51c19cf90e Author: Father Chrysostomos <[email protected]> Date: Thu Oct 2 12:54:15 2014 -0700 Update comments for OPf_SPECIAL/do âdo subnameâ has been removed, so OPf_SPECIAL no longer applies to OP_ENTERSUB. M op.h commit c997e36218768fb357b1f3d160131f259311e3a3 Author: Father Chrysostomos <[email protected]> Date: Thu Oct 2 12:44:19 2014 -0700 Make list assignment respect foreach aliasing See ff2a62e0c8 for the explanation. The bug fix in that commit did not apply to foreachâs aliasing. In short, ($a,$b)=($c,$d) needs to account for whether two of those variable names could be referring to the same variable. This commit causes the test suite to exercise a code path in scope.c added by ff2a62e0c8, which turned out to be buggy. (I forgot to test it at the time.) M embed.fnc M embed.h M pp_ctl.c M proto.h M scope.c M sv.c M t/op/for.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + ext/B/t/concise-xs.t | 1 + lib/B/Deparse.pm | 50 +++++++++++++++++++++++++++++++++----------------- lib/B/Deparse.t | 12 ++++++++++++ op.h | 2 +- pp_ctl.c | 1 + proto.h | 5 +++++ scope.c | 12 ++++++++++++ sv.c | 6 +----- t/op/for.t | 8 +++++++- 11 files changed, 75 insertions(+), 24 deletions(-) diff --git a/embed.fnc b/embed.fnc index 5de2f83..7f759eb 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1242,6 +1242,7 @@ Ap |void |savestack_grow_cnt |I32 need Amp |void |save_aelem |NN AV* av|SSize_t idx|NN SV **sptr Ap |void |save_aelem_flags|NN AV* av|SSize_t idx|NN SV **sptr \ |const U32 flags +p |void |save_aliased_sv|NN GV* gv Ap |I32 |save_alloc |I32 size|I32 pad Ap |void |save_aptr |NN AV** aptr Ap |AV* |save_ary |NN GV* gv diff --git a/embed.h b/embed.h index ed04c7c..ebb1e9f 100644 --- a/embed.h +++ b/embed.h @@ -1283,6 +1283,7 @@ #define rsignal_restore(a,b) Perl_rsignal_restore(aTHX_ a,b) #define rsignal_save(a,b,c) Perl_rsignal_save(aTHX_ a,b,c) #define rxres_save(a,b) Perl_rxres_save(aTHX_ a,b) +#define save_aliased_sv(a) Perl_save_aliased_sv(aTHX_ a) #define save_strlen(a) Perl_save_strlen(aTHX_ a) #define sawparens(a) Perl_sawparens(aTHX_ a) #define scalar(a) Perl_scalar(aTHX_ a) diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index c1d7f18..74e4b0e 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -159,6 +159,7 @@ my $testpkgs = { constant => [qw/ ASSIGN CVf_LVALUE CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL + OPf_PARENS OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index fa725a8..1d08755 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -11,7 +11,7 @@ package B::Deparse; use Carp; use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST - OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD + OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER @@ -254,6 +254,9 @@ BEGIN { # in_subst_repl # True when deparsing the replacement part of a substitution. # +# in_refgen +# True when deparsing the argument to \. +# # parens: -p # linenums: -l # unquote: -q @@ -1209,10 +1212,18 @@ sub find_our_type { sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; - my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; - if ($op->private & (OPpLVAL_INTRO|$our_intro)) { - my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; - if( $our_local eq 'our' ) { + my $name = $op->name; + my $our_intro = ($name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/ + && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; + if ((my $priv = $op->private) & (OPpLVAL_INTRO|$our_intro)) { + my @our_local; + push @our_local, "local" if $priv & OPpLVAL_INTRO; + push @our_local, "our" if $priv & $our_intro; + my $our_local = join " ", @our_local; + if( $our_local[-1] eq 'our' ) { if ( $text !~ /^\W(\w+::)*\w+\z/ and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/ ) { @@ -1224,14 +1235,17 @@ sub maybe_local { $our_local .= ' ' . $type; } } - return $text if $self->{'avoid_local'}{$$op}; - if (want_scalar($op)) { + return $need_parens ? "($text)" : $text + if $self->{'avoid_local'}{$$op}; + if ($need_parens) { + return "$our_local($text)"; + } elsif (want_scalar($op)) { return "$our_local $text"; } else { return $self->maybe_parens_func("$our_local", $text, $cx, 16); } } else { - return $text; + return $need_parens ? "($text)" : $text; } } @@ -1256,6 +1270,11 @@ sub padname_sv { sub maybe_my { my $self = shift; my($op, $cx, $text, $padname, $forbid_parens) = @_; + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + my $need_parens = !$forbid_parens && $self->{'in_refgen'} + && $op->name =~ /[ah]v\z/ + && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { my $my = $op->private & OPpPAD_STATE ? $self->keyword("state") @@ -1263,13 +1282,15 @@ sub maybe_my { if ($padname->FLAGS & SVpad_TYPED) { $my .= ' ' . $padname->SvSTASH->NAME; } - if ($forbid_parens || want_scalar($op)) { + if ($need_parens) { + return "$my($text)"; + } elsif ($forbid_parens || want_scalar($op)) { return "$my $text"; } else { return $self->maybe_parens_func($my, $text, $cx, 16); } } else { - return $text; + return $need_parens ? "($text)" : $text; } } @@ -2255,13 +2276,7 @@ sub pp_refgen { return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) }); } elsif ($kid->name eq "pushmark") { my $sib_name = $kid->sibling->name; - if ($sib_name =~ /^(pad|rv2)[ah]v$/ - and not $kid->sibling->flags & OPf_REF) - { - # The @a in \(@a) isn't in ref context, but only when the - # parens are there. - return "\\(" . $self->pp_list($op->first) . ")"; - } elsif ($sib_name eq 'entersub') { + if ($sib_name eq 'entersub') { my $text = $self->deparse($kid->sibling, 1); # Always show parens for \(&func()), but only with -p otherwise $text = "($text)" if $self->{'parens'} @@ -2270,6 +2285,7 @@ sub pp_refgen { } } } + local $self->{'in_refgen'} = 1; $self->pfixop($op, $cx, "\\", 20); } diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 620d430..d79572a 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -362,6 +362,9 @@ my Dog ($foo, @bar, %baz); our Dog ($phoo, @barr, %bazz); state Dog ($fough, @barre, %bazze); #### +# local our +local our $rhubarb; +#### # <> my $foo; $_ .= <ARGV> . <$foo>; @@ -1463,3 +1466,12 @@ $x = $b[1] + $b[126] + $b[127] + $b[128] + $b[255] + $b[256]; #### # 'm' must be preserved in m?? m??; +#### +# \(@array) and \(..., (@array), ...) +my(@array, %hash, @a, @b, %c, %d); +() = \(@array); +() = \(%hash); +() = \(@a, (@b), (%c), %d); +() = \(@Foo::array); +() = \(%Foo::hash); +() = \(@Foo::a, (@Foo::b), (%Foo::c), %Foo::d); diff --git a/op.h b/op.h index df39d33..9d177d0 100644 --- a/op.h +++ b/op.h @@ -109,7 +109,7 @@ Deprecated. Use C<GIMME_V> instead. /* On control verbs, we saw no label */ /* On flipflop, we saw ... instead of .. */ /* On UNOPs, saw bare parens, e.g. eof(). */ - /* On OP_ENTERSUB || OP_NULL, saw a "do". */ + /* On OP_NULL, saw a "do". */ /* On OP_EXISTS, treat av as av, not avhv. */ /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ /* On pushre, rx is used as part of split, e.g. split " " */ diff --git a/pp_ctl.c b/pp_ctl.c index d72ec1c..3d02f3a 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2118,6 +2118,7 @@ PP(pp_enteriter) save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV); *svp = newSV(0); itervar = (void *)gv; + save_aliased_sv(gv); } if (PL_op->op_private & OPpITER_DEF) diff --git a/proto.h b/proto.h index bd6234f..632422d 100644 --- a/proto.h +++ b/proto.h @@ -3670,6 +3670,11 @@ PERL_CALLCONV void Perl_save_aelem_flags(pTHX_ AV* av, SSize_t idx, SV **sptr, c #define PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS \ assert(av); assert(sptr) +PERL_CALLCONV void Perl_save_aliased_sv(pTHX_ GV* gv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SAVE_ALIASED_SV \ + assert(gv) + PERL_CALLCONV I32 Perl_save_alloc(pTHX_ I32 size, I32 pad); PERL_CALLCONV void Perl_save_aptr(pTHX_ AV** aptr) __attribute__nonnull__(pTHX_1); diff --git a/scope.c b/scope.c index ada0a19..1084484 100644 --- a/scope.c +++ b/scope.c @@ -701,6 +701,16 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad) return start; } +void +Perl_save_aliased_sv(pTHX_ GV *gv) +{ + dSS_ADD; + PERL_ARGS_ASSERT_SAVE_ALIASED_SV; + SS_ADD_PTR(gp_ref(GvGP(gv))); + SS_ADD_UV(SAVEt_GP_ALIASED_SV | cBOOL(GvALIASED_SV(gv)) << 8); + SS_ADD_END(2); +} + #define ARG0_SV MUTABLE_SV(arg0.any_ptr) @@ -1231,8 +1241,10 @@ Perl_leave_scope(pTHX_ I32 base) GP * const gp = (GP *)ARG0_PTR; if (gp->gp_refcnt == 1) { GV * const gv = (GV *)sv_2mortal(newSV_type(SVt_PVGV)); + isGV_with_GP_on(gv); GvGP_set(gv,gp); gp_free(gv); + isGV_with_GP_off(gv); } else { gp->gp_refcnt--; diff --git a/sv.c b/sv.c index 5f29137..c3594b2 100644 --- a/sv.c +++ b/sv.c @@ -4093,11 +4093,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) } if (import_flag == GVf_IMPORTED_SV) { if (intro) { - dSS_ADD; - SS_ADD_PTR(gp_ref(GvGP(dstr))); - SS_ADD_UV(SAVEt_GP_ALIASED_SV - | cBOOL(GvALIASED_SV(dstr)) << 8); - SS_ADD_END(2); + save_aliased_sv((GV *)dstr); } /* Turn off the flag if sref is not referenced elsewhere, even by weak refs. (SvRMAGICAL is a pessimistic check for diff --git a/t/op/for.t b/t/op/for.t index 2ac0fc8..36af7fd 100644 --- a/t/op/for.t +++ b/t/op/for.t @@ -4,7 +4,7 @@ BEGIN { require "test.pl"; } -plan(106); +plan(107); # A lot of tests to check that reversed for works. @@ -579,3 +579,9 @@ SKIP: { }->($a[0]); is $@, "", 'vivify_defelem does not croak on &PL_sv_undef elements'; } + +for $x ($y) { + $x = 3; + ($x, my $z) = (1, $y); + is $z, 3, 'list assignment after aliasing via foreach'; +} -- Perl5 Master Repository
