In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/23b7025ebc631174249ce95dd496a0f82b55701a?hp=a6dc34f13cb655734fde4d3a1aa6827cedf93e60>
- Log ----------------------------------------------------------------- commit 23b7025ebc631174249ce95dd496a0f82b55701a Merge: 6d70c68 1d2b392 Author: Father Chrysostomos <[email protected]> Date: Tue Dec 11 08:59:56 2012 -0800 [Merge] hash assignment fixes and speedup In <CAMOxC8vCaYk3GD0NRH=jxgmnku+bmktrykr2nsrgu6wei+x...@mail.gmail.com> Ruslan Zakirov wrote: > I've finished my work on pp_aassign. I find it ready for review. > Each commit has plenty of details, but here is short description: > > * scalar(%h = (1,1,1,1)) returns 4, not 2 > * warn on ($s,%h) = (1,{}) as on (%h) = ({}) > * (%h = (1)) in list context returns (1, $h{1}) > instead of (1) > * return of (%h = (1,1,1)) in list context was incorrect > * in list context returned keys was aliased to RHS scalars > of aassign > * returned list from ((%h, @a) = ...), hash on LHS followed by > array or hash, was incorrect > * implemented right to left algorithm for not magic hash assignment > in scalar and void context > * use less mortals is list context > * in list context hash assignment return keys aliased to RHS > when it's ok (it's not LVALUE context) commit 1d2b3927543a3fa4089c1cee10f3a1a546a02cfe Author: Hugo van der Sanden <[email protected]> Date: Tue Dec 11 06:17:26 2012 -0800 pp_hot.c: Comments to clarify pp_aassign [The committer took these from <[email protected]> and turned them into a patch.] M pp_hot.c commit 3d2de69e2d8b4ab2d3b4e978957fce16e6597548 Author: Father Chrysostomos <[email protected]> Date: Tue Dec 11 05:59:00 2012 -0800 hashassign.t: Suppress oddball warnings M t/op/hashassign.t commit 14da5e9ef04c8dab84c9c1e5818ec57fbae6fca0 Author: Father Chrysostomos <[email protected]> Date: Tue Dec 11 05:57:41 2012 -0800 hashassign.t: Test undef explicitly thereby eliminating uninit warnings M t/op/hashassign.t commit 631dbaa279974476f7c2a388b50c77dace949921 Author: Father Chrysostomos <[email protected]> Date: Wed Oct 24 18:04:20 2012 -0700 Copy keys for aassign in lvalue sub Checking LVRET (which pp_aassign does, as of a few commits ago) has no effect if OPpMAYBE_LVSUB is not set on the op. This com- mit changes op.c:op_lvalue_flags to set this flag on aassign ops. This makes sub:lvalue{%h=($x,$x)} behave correctly if the return values of the sub are assigned to ($x is unmodfied). M dump.c M op.c M t/op/hashassign.t commit fb8f4cf83c7112774ede7101826d438234894195 Author: Ruslan Zakirov <[email protected]> Date: Sat Oct 20 14:40:13 2012 +0400 hash argument is not used anymore in do_oddball rename arguments to make more clear what function takes M embed.fnc M embed.h M pp_hot.c M proto.h commit 632b9d6f6a19a87ee168ebb81494b7df13c2eeb0 Author: Father Chrysostomos <[email protected]> Date: Mon Dec 10 05:43:41 2012 -0800 pp_hot.c:pp_aassign: mortalise variable only if we have to This affects the hash-assignment path. Donât mortalise the value to protect it from a magical key making the hv_store_ent call die, as that could unduly extend the mortals stack. Instead, copy the key if it is magical. Based on a patch by Ruslan Zakirov. M pp_hot.c commit 88e2091baeacd9a40eab4dac8601e88b3797e385 Author: Ruslan Zakirov <[email protected]> Date: Wed Oct 17 20:04:58 2012 +0400 don't create a copy of keys if it's not LVALUE context Making another copy slows things down. We can avoid it if aassign is not expected to return LVALUEs. M pp_hot.c commit 1c4ea38437d309ec547e78e6f14940e799920be3 Author: Ruslan Zakirov <[email protected]> Date: Sun Oct 14 04:41:35 2012 +0400 refactor aassign move populating stack with return values. Place it into main loop right after we stored values. This allow us to delete special if blocks for hash/array on LHS followed by other hash/array. Also, clearing HV out of ENTER/LEAVE block is bad - segfaults in corner cases. Don't use goto for odd elements case. store undef on stack for odd case. we can avoid NULL checks in the loop and use assert like array assignment does. use SvSETMAGIC rather than repeate what it means. for array and hash assignment "while (relem <= SP)" loop at the end was always empty. Put it into else branch. M pp_hot.c commit 4ff6ceafd69f873d6db07cde3cb7c5cb6e8fef2d Author: Ruslan Zakirov <[email protected]> Date: Sat Oct 13 21:28:10 2012 +0400 ary/hash/firsthashelem should be set only once Only once for first hash or array, otherwise (%h,@a) = ... assignment returns wrong results for duplicates and/or number of elements on RHS. M pp_hot.c commit a88bf2bcaa12203b1be20c254990b132faf927dd Author: Ruslan Zakirov <[email protected]> Date: Sat Oct 13 21:27:12 2012 +0400 we need duplicates counter only in list context M pp_hot.c commit b1babc516d40c1a9d24a2eabf3c7649c4c3e7a00 Author: Ruslan Zakirov <[email protected]> Date: Wed Oct 10 02:43:40 2012 +0400 test return values of aassign with various elements on LHS * hash on LHS followed by array, other hash or scalar, for example (%h, @a) = (...); * above with normal RHS, with duplicates, odd elements and combination. * inspect elements returned by aassign for lvaluedness * assign doesn't return elements that were just cleared M t/op/hashassign.t commit 139e2abeba926fdfd45724ed2ab5117bfabdb350 Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 22:50:50 2012 +0400 hash assign in list context should copy key as well if we don't then returned keys are aliases for RHS values and can result in unexpected changes M pp_hot.c commit 96e574609cc4b7f8d8969f8da065712307311f41 Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 22:48:52 2012 +0400 make sure hash assignment is proper lvalue M t/op/hashassign.t commit 1baa394bebe0d74f5a4f14772cc9000d6bdc99f7 Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 17:32:24 2012 +0400 fix issues in hash assignment with odd elements 1) unify code path of processing odd case with regular loop that process pairs. fixes memory leak when key is magic and dies on fetch. 2) in list context put undef that we added to compensate odd elements into returned values, so (%h = (1)) returns (1, $h{1}) rather than (1). This is documented in perldoc perlop: a list assignment in list context produces the list of lvalues assigned to. Here can be a dispute, but: * that key without value on RHS is still assigned with undef * consider (%h = (1,2,3,4,5,6,3)). Returning (1,2,3,undef,5,6) is much easier than (1,2,5,6,3). * order of returned elements follows cases with even number of elements on RHS and duplicates 3) hash assignment with duplicates and odd elements on RHS was returning wrong results in list context. Now (%h = (1,1,1)) returns (1,$h{1}). M pp_hot.c commit 499ace3b7bbe6fb3aa489db1fb760ac0a6dbbd1b Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 17:26:43 2012 +0400 test hash assignment with odd elements for leaks if key scalar is tied and dies on fetch then hash assignment is leaking a key value M t/op/svleak.t commit be1092b8b2529803333f6d1be2025b9af797f010 Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 02:41:06 2012 +0400 warn on ($s,%h) = (1,{}) as on %h = {} Latter results in "Reference found where even-sized list expected" message while former produces "Reference found where even-sized list expected". Quite inconsistent. M pp_hot.c commit 3e125adaaf6d41df6a78e92e6682685224048aba Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 02:35:22 2012 +0400 test "Odd number of elements in hash assignment" M t/op/hashassign.t commit 231cbeb24ba077cbde643fc4d5178055c1464f5c Author: Ruslan Zakirov <[email protected]> Date: Mon Oct 8 02:30:54 2012 +0400 scalar(%h = (1,1,1,1)) should return 4, not 2 perldoc perlop says: a list assignment in scalar context returns the number of elements produced by the expression on the right hand side of the assignment Behaviour was changed as side effect of ca65944e8ff8fff6e36ea7476ba807be16cfe2a9 where goal was to fix return value in list context. M ext/Hash-Util-FieldHash/t/11_hashassign.t M pp_hot.c M t/op/hashassign.t commit 6d70c686156da1532212fbc817c63c0a02bf894a Author: Father Chrysostomos <[email protected]> Date: Sun Dec 9 05:03:50 2012 -0800 t/op/lex.t: Fix test It was a copied-and-pasted repeat of another test, both of which I added in commit 67a057d6d. I know it used to crash and the commit fixed it, as I tested it at the time with one-liners. M t/op/lex.t ----------------------------------------------------------------------- Summary of changes: dump.c | 8 +- embed.fnc | 2 +- embed.h | 2 +- ext/Hash-Util-FieldHash/t/11_hashassign.t | 4 +- op.c | 5 +- pp_hot.c | 131 +++++++++--------- proto.h | 7 +- t/op/hashassign.t | 220 ++++++++++++++++++++++++++++- t/op/lex.t | 3 +- t/op/svleak.t | 1 + 10 files changed, 302 insertions(+), 81 deletions(-) diff --git a/dump.c b/dump.c index 9d5811c..c802732 100644 --- a/dump.c +++ b/dump.c @@ -778,7 +778,6 @@ const struct flag_to_name op_sassign_names[] = { {(flag), (name)} \ } -OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON"); OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED"); OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST"); OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE"); @@ -801,7 +800,6 @@ const struct op_private_by_op op_private_names[] = { {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, - {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names }, {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names }, {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names }, {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names }, @@ -940,6 +938,12 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { if (oppriv & OPpFT_AFTER_t) \ sv_catpv(tmpsv, ",AFTER_t"); \ } \ + else if (o->op_type == OP_AASSIGN) { \ + if (oppriv & OPpASSIGN_COMMON) \ + sv_catpvs(tmpsv, ",COMMON"); \ + if (oppriv & OPpMAYBE_LVSUB) \ + sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \ + } \ if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \ sv_catpv(tmpsv, ",INTRO"); \ if (o->op_type == OP_PADRANGE) \ diff --git a/embed.fnc b/embed.fnc index 6d6befe..0a382f6 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1904,7 +1904,7 @@ s |OP* |do_smartmatch |NULLOK HV* seen_this \ #endif #if defined(PERL_IN_PP_HOT_C) -s |void |do_oddball |NN HV *hash|NN SV **relem|NN SV **firstrelem +s |void |do_oddball |NN SV **oddkey|NN SV **firstkey sR |SV* |method_common |NN SV* meth|NULLOK U32* hashp #endif diff --git a/embed.h b/embed.h index fbb49f6..d6b1c2f 100644 --- a/embed.h +++ b/embed.h @@ -1497,7 +1497,7 @@ #define save_lines(a,b) S_save_lines(aTHX_ a,b) # endif # if defined(PERL_IN_PP_HOT_C) -#define do_oddball(a,b,c) S_do_oddball(aTHX_ a,b,c) +#define do_oddball(a,b) S_do_oddball(aTHX_ a,b) #define method_common(a,b) S_method_common(aTHX_ a,b) # endif # if defined(PERL_IN_PP_PACK_C) diff --git a/ext/Hash-Util-FieldHash/t/11_hashassign.t b/ext/Hash-Util-FieldHash/t/11_hashassign.t index e492fa2..d3e45d3 100644 --- a/ext/Hash-Util-FieldHash/t/11_hashassign.t +++ b/ext/Hash-Util-FieldHash/t/11_hashassign.t @@ -282,9 +282,9 @@ foreach my $chr (60, 200, 600, 6000, 60000) { fieldhash %h; is( (join ':', %h = (1) x 8), '1:1', 'hash assignment in list context removes duplicates' ); - is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2, + is( scalar( %h = (1,2,1,3,1,4,1,5) ), 8, 'hash assignment in scalar context' ); - is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3, + is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 9, 'scalar + hash assignment in scalar context' ); $ar = [ %h = (1,2,1,3,1,4,1,5) ]; is( $#$ar, 1, 'hash assignment in list context' ); diff --git a/op.c b/op.c index fd114b1..60184b6 100644 --- a/op.c +++ b/op.c @@ -2071,11 +2071,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) /* FALL THROUGH */ case OP_ASLICE: case OP_HSLICE: - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; localize = 1; /* FALL THROUGH */ case OP_AASSIGN: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALL THROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; diff --git a/pp_hot.c b/pp_hot.c index feba395..64f8406 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -950,22 +950,19 @@ PP(pp_rv2av) } STATIC void -S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) +S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) { dVAR; PERL_ARGS_ASSERT_DO_ODDBALL; - if (*relem) { - SV *tmpstr; - const HE *didstore; - + if (*oddkey) { if (ckWARN(WARN_MISC)) { const char *err; - if (relem == firstrelem && - SvROK(*relem) && - (SvTYPE(SvRV(*relem)) == SVt_PVAV || - SvTYPE(SvRV(*relem)) == SVt_PVHV)) + if (oddkey == firstkey && + SvROK(*oddkey) && + (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || + SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) { err = "Reference found where even-sized list expected"; } @@ -974,15 +971,6 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); } - tmpstr = newSV(0); - didstore = hv_store_ent(hash,*relem,tmpstr,0); - if (SvMAGICAL(hash)) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - if (!didstore) - sv_2mortal(tmpstr); - } - TAINT_NOT; } } @@ -1004,11 +992,12 @@ PP(pp_aassign) HV *hash; I32 i; int magic; - int duplicates = 0; - SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */ + U32 lval = 0; PL_delaymagic = DM_DELAY; /* catch simultaneous items */ gimme = GIMME_V; + if (gimme == G_ARRAY) + lval = PL_op->op_flags & OPf_MOD || LVRET; /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't @@ -1086,48 +1075,76 @@ PP(pp_aassign) break; case SVt_PVHV: { /* normal hash */ SV *tmpstr; + int odd; + int duplicates = 0; SV** topelem = relem; + SV **firsthashrelem = relem; hash = MUTABLE_HV(sv); magic = SvMAGICAL(hash) != 0; + + odd = ((lastrelem - firsthashrelem)&1)? 0 : 1; + if ( odd ) { + do_oddball(lastrelem, firsthashrelem); + /* we have firstlelem to reuse, it's not needed anymore + */ + *(lastrelem+1) = &PL_sv_undef; + } + ENTER; SAVEFREESV(SvREFCNT_inc_simple_NN(sv)); hv_clear(hash); - firsthashrelem = relem; - - while (relem < lastrelem) { /* gobble up all the rest */ + while (relem < lastrelem+odd) { /* gobble up all the rest */ HE *didstore; - sv = *relem ? *relem : &PL_sv_no; - relem++; - tmpstr = sv_newmortal(); - if (*relem) - sv_setsv(tmpstr,*relem); /* value */ + assert(*relem); + /* Copy the key if aassign is called in lvalue context, + to avoid having the next op modify our rhs. Copy + it also if it is gmagical, lest it make the + hv_store_ent call below croak, leaking the value. */ + sv = lval || SvGMAGICAL(*relem) + ? sv_mortalcopy(*relem) + : *relem; relem++; - if (gimme != G_VOID) { + assert(*relem); + SvGETMAGIC(*relem); + tmpstr = newSV(0); + sv_setsv_nomg(tmpstr,*relem++); /* value */ + if (gimme == G_ARRAY) { if (hv_exists_ent(hash, sv, 0)) /* key overwrites an existing entry */ duplicates += 2; - else - if (gimme == G_ARRAY) { + else { /* copy element back: possibly to an earlier - * stack location if we encountered dups earlier */ + * stack location if we encountered dups earlier, + * possibly to a later stack location if odd */ *topelem++ = sv; *topelem++ = tmpstr; } } didstore = hv_store_ent(hash,sv,tmpstr,0); - if (didstore) SvREFCNT_inc_simple_void_NN(tmpstr); if (magic) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - } + if (!didstore) sv_2mortal(tmpstr); + SvSETMAGIC(tmpstr); + } TAINT_NOT; } - if (relem == lastrelem) { - do_oddball(hash, relem, firstrelem); - relem++; - } LEAVE; + if (duplicates && gimme == G_ARRAY) { + /* at this point we have removed the duplicate key/value + * pairs from the stack, but the remaining values may be + * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed + * the (a 2), but the stack now probably contains + * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) } + * obliterates the earlier key. So refresh all values. */ + lastrelem -= duplicates; + relem = firsthashrelem; + while (relem < lastrelem+odd) { + HE *he; + he = hv_fetch_ent(hash, *relem++, 0, 0); + *relem++ = (he ? HeVAL(he) : &PL_sv_undef); + } + } + if (odd && gimme == G_ARRAY) lastrelem++; } break; default: @@ -1234,35 +1251,19 @@ PP(pp_aassign) else if (gimme == G_SCALAR) { dTARGET; SP = firstrelem; - SETi(lastrelem - firstrelem + 1 - duplicates); + SETi(lastrelem - firstrelem + 1); } else { - if (ary) - SP = lastrelem; - else if (hash) { - if (duplicates) { - /* at this point we have removed the duplicate key/value - * pairs from the stack, but the remaining values may be - * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed - * the (a 2), but the stack now probably contains - * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) } - * obliterates the earlier key. So refresh all values. */ - lastrelem -= duplicates; - relem = firsthashrelem; - while (relem < lastrelem) { - HE *he; - sv = *relem++; - he = hv_fetch_ent(hash, sv, 0, 0); - *relem++ = (he ? HeVAL(he) : &PL_sv_undef); - } - } + if (ary || hash) + /* note that in this case *firstlelem may have been overwritten + by sv_undef in the odd hash case */ SP = lastrelem; - } - else + else { SP = firstrelem + (lastlelem - firstlelem); - lelem = firstlelem + (relem - firstrelem); - while (relem <= SP) - *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; + lelem = firstlelem + (relem - firstrelem); + while (relem <= SP) + *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; + } } RETURN; diff --git a/proto.h b/proto.h index 2875e76..7f4942e 100644 --- a/proto.h +++ b/proto.h @@ -6158,12 +6158,11 @@ STATIC void S_save_lines(pTHX_ AV *array, SV *sv) #endif #if defined(PERL_IN_PP_HOT_C) -STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) +STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2) - __attribute__nonnull__(pTHX_3); + __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_ODDBALL \ - assert(hash); assert(relem); assert(firstrelem) + assert(oddkey); assert(firstkey) STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp) __attribute__warn_unused_result__ diff --git a/t/op/hashassign.t b/t/op/hashassign.t index 37a7674..57a625c 100644 --- a/t/op/hashassign.t +++ b/t/op/hashassign.t @@ -8,7 +8,7 @@ BEGIN { # use strict; -plan tests => 218; +plan tests => 309; my @comma = ("key", "value"); @@ -280,9 +280,9 @@ foreach my $chr (60, 200, 600, 6000, 60000) { 'hash assignment in list context removes duplicates' ); is( (join ':', %h = qw(a 1 a 2 b 3 c 4 d 5 d 6)), 'a:2:b:3:c:4:d:6', 'hash assignment in list context removes duplicates 2' ); - is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2, + is( scalar( %h = (1,2,1,3,1,4,1,5) ), 8, 'hash assignment in scalar context' ); - is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3, + is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 9, 'scalar + hash assignment in scalar context' ); $ar = [ %h = (1,2,1,3,1,4,1,5) ]; is( $#$ar, 1, 'hash assignment in list context' ); @@ -320,3 +320,217 @@ SKIP: { undef %tb; is $p, \%tb, "hash undef should not zap weak refs"; } + +# test odd hash assignment warnings +{ + my ($s, %h); + warning_like(sub {%h = (1..3)}, qr/^Odd number of elements in hash assignment/); + warning_like(sub {%h = ({})}, qr/^Reference found where even-sized list expected/); + + warning_like(sub { ($s, %h) = (1..4)}, qr/^Odd number of elements in hash assignment/); + warning_like(sub { ($s, %h) = (1, {})}, qr/^Reference found where even-sized list expected/); +} + +# hash assignment in scalar and list context with odd number of elements +{ + no warnings 'misc', 'uninitialized'; + my %h; my $x; + is( join( ':', %h = (1..3)), '1:2:3:', + 'odd hash assignment in list context' ); + ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" ); + is( scalar( %h = (1..3) ), 3, + 'odd hash assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" ); + is( join(':', ($x,%h) = (0,1,2,3) ), '0:1:2:3:', + 'scalar + odd hash assignment in list context' ); + ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" ); + is( scalar( ($x,%h) = (0,1,2,3) ), 4, + 'scalar + odd hash assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" ); +} + +# hash assignment in scalar and list context with odd number of elements +# and duplicates +{ + no warnings 'misc', 'uninitialized'; + my %h; my $x; + is( (join ':', %h = (1,1,1)), '1:', + 'odd hash assignment in list context with duplicates' ); + ok( eq_hash( \%h, {1 => undef} ), "correct value stored" ); + is( scalar(%h = (1,1,1)), 3, + 'odd hash assignment in scalar context with duplicates' ); + ok( eq_hash( \%h, {1 => undef} ), "correct value stored" ); + is( join(':', ($x,%h) = (0,1,1,1) ), '0:1:', + 'scalar + odd hash assignment in list context with duplicates' ); + ok( eq_hash( \%h, {1 => undef} ), "correct value stored" ); + is( scalar( ($x,%h) = (0,1,1,1) ), 4, + 'scalar + odd hash assignment in scalar context with duplicates' ); + ok( eq_hash( \%h, {1 => undef} ), "correct value stored" ); +} + +# hash followed by more elements on LHS of list assignment +# (%h, ...) = ...; +{ + my (%h, %x, @x, $x); + is( scalar( (%h,$x) = (1,2,3,4)), 4, + 'hash+scalar assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" ); + is( $x, undef, "correct scalar" ); + # this arguable, but this is how it works + is( join(':', (%h,$x) = (1,2,3,4)), '1:2:3:4', + 'hash+scalar assignment in list context' ); + ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" ); + is( $x, undef, "correct scalar" ); + + is( scalar( (%h,%x) = (1,2,3,4)), 4, + 'hash+hash assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" ); + ok( eq_hash( \%x, {} ), "correct hash" ); + is( join(':', (%h,%x) = (1,2,3,4)), '1:2:3:4', + 'hash+hash assignment in list context' ); + ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" ); + ok( eq_hash( \%x, {} ), "correct hash" ); + + is( scalar( (%h,@x) = (1,2,3,4)), 4, + 'hash+array assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" ); + ok( eq_array( \@x, [] ), "correct array" ); + is( join(':', (%h,@x) = (1,2,3,4)), '1:2:3:4', + 'hash+hash assignment in list context' ); + ok( eq_hash( \%h, {1 => 2, 3 => 4} ), "correct hash" ); + ok( eq_array( \@x, [] ), "correct array" ); +} + +# hash followed by more elements on LHS of list assignment +# and duplicates on RHS +# (%h, ...) = (1)x10; +{ + my (%h, %x, @x, $x); + is( scalar( (%h,$x) = (1,2,1,4)), 4, + 'hash+scalar assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 4} ), "correct hash" ); + is( $x, undef, "correct scalar" ); + # this arguable, but this is how it works + is( join(':', (%h,$x) = (1,2,1,4)), '1:4', + 'hash+scalar assignment in list context' ); + ok( eq_hash( \%h, {1 => 4} ), "correct hash" ); + is( $x, undef, "correct scalar" ); + + is( scalar( (%h,%x) = (1,2,1,4)), 4, + 'hash+hash assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 4} ), "correct hash" ); + ok( eq_hash( \%x, {} ), "correct hash" ); + is( join(':', (%h,%x) = (1,2,1,4)), '1:4', + 'hash+hash assignment in list context' ); + ok( eq_hash( \%h, {1 => 4} ), "correct hash" ); + ok( eq_hash( \%x, {} ), "correct hash" ); + + is( scalar( (%h,@x) = (1,2,1,4)), 4, + 'hash+array assignment in scalar context' ); + ok( eq_hash( \%h, {1 => 4} ), "correct hash" ); + ok( eq_array( \@x, [] ), "correct array" ); + is( join(':', (%h,@x) = (1,2,1,4)), '1:4', + 'hash+hash assignment in list context' ); + ok( eq_hash( \%h, {1 => 4} ), "correct hash" ); + ok( eq_array( \@x, [] ), "correct array" ); +} + +# hash followed by more elements on LHS of list assignment +# and duplicates with odd number of elements on RHS +# (%h, ...) = (1,2,3,4,1); +{ + no warnings 'misc'; # suppress oddball warnings + my (%h, %x, @x, $x); + is( scalar( (%h,$x) = (1,2,3,4,1)), 5, + 'hash+scalar assignment in scalar context' ); + ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" ); + is( $x, undef, "correct scalar" ); + # this arguable, but this is how it works + is( join(':', map $_//'undef', (%h,$x) = (1,2,3,4,1)), '1:undef:3:4', + 'hash+scalar assignment in list context' ); + ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" ); + is( $x, undef, "correct scalar" ); + + is( scalar( (%h,%x) = (1,2,3,4,1)), 5, + 'hash+hash assignment in scalar context' ); + ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" ); + ok( eq_hash( \%x, {} ), "correct hash" ); + is( join(':', map $_//'undef', (%h,%x) = (1,2,3,4,1)), '1:undef:3:4', + 'hash+hash assignment in list context' ); + ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" ); + ok( eq_hash( \%x, {} ), "correct hash" ); + + is( scalar( (%h,@x) = (1,2,3,4,1)), 5, + 'hash+array assignment in scalar context' ); + ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" ); + ok( eq_array( \@x, [] ), "correct array" ); + is( join(':', map $_//'undef', (%h,@x) = (1,2,3,4,1)), '1:undef:3:4', + 'hash+hash assignment in list context' ); + ok( eq_hash( \%h, {1 => undef, 3 => 4} ), "correct hash" ); + ok( eq_array( \@x, [] ), "correct array" ); +} + + +# not enough elements on rhs +# ($x,$y,$z,...) = (1); +{ + my ($x,$y,$z,@a,%h); + is( join(':', ($x, $y, %h) = (1)), '1', + 'only assigned elements are returned in list context'); + is( join(':', ($x, $y, %h) = (1,1)), '1:1', + 'only assigned elements are returned in list context'); + no warnings 'misc'; # suppress oddball warnings + is( join(':', map $_//'undef', ($x, $y, %h) = (1,1,1)), '1:1:1:undef', + 'only assigned elements are returned in list context'); + is( join(':', ($x, $y, %h) = (1,1,1,1)), '1:1:1:1', + 'only assigned elements are returned in list context'); + is( join(':', map $_//'undef', ($x, %h, $y) = (1,2,3,4)), + '1:2:3:4:undef', + 'only assigned elements are returned in list context'); + is( join(':', ($x, $y, @h) = (1)), '1', + 'only assigned elements are returned in list context'); + is( join(':', ($x, @h, $y) = (1,2,3,4)), '1:2:3:4', + 'only assigned elements are returned in list context'); +} + +# lvaluedness of list context +{ + my %h; my ($x, $y, $z); + $_++ foreach %h = (1,2,3,4); + ok( eq_hash( \%h, {1 => 3, 3 => 5} ), "aassign in list context returns lvalues" ); + + $_++ foreach %h = (1,2,1,4); + ok( eq_hash( \%h, {1 => 5} ), "the same for assignment with duplicates" ); + + $_++ foreach ($x, %h) = (0,1,2,3,4); + is( $x, 1, "... and leading scalar" ); + ok( eq_hash( \%h, {1 => 3, 3 => 5} ), "... scalar followed by hash" ); + + { + no warnings 'misc'; + $_++ foreach %h = (1,2,3); + ok( eq_hash( \%h, {1 => 3, 3 => 1} ), "odd elements also lvalued" ); + } + + $x = 0; + $_++ foreach %h = ($x,$x); + is($x, 0, "returned values are not aliased to RHS of the assignment operation"); + + %h = (); + $x = 0; + $_++ foreach sub :lvalue { %h = ($x,$x) }->(); + is($x, 0, + "returned values are not aliased to RHS of assignment in lvalue sub"); + + $_++ foreach ($x,$y,%h,$z) = (0); + ok( eq_array([$x,$y,%h,$z], [1,undef,undef]), "only assigned values are returned" ); + + $_++ foreach ($x,$y,%h,$z) = (0,1); + ok( eq_array([$x,$y,%h,$z], [1,2,undef]), "only assigned values are returned" ); + + no warnings 'misc'; # suppress oddball warnings + $_++ foreach ($x,$y,%h,$z) = (0,1,2); + ok( eq_array([$x,$y,%h,$z], [1,2,2,1,undef]), "only assigned values are returned" ); +} + + diff --git a/t/op/lex.t b/t/op/lex.t index c009f2d..7601b95 100644 --- a/t/op/lex.t +++ b/t/op/lex.t @@ -62,7 +62,8 @@ fresh_perl_is( 'no crash when charnames cannot load and %^H holds string' ); fresh_perl_is( - 'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"} } "\N{a}"', + 'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"}; + $^H{charnames} = \"foo" } "\N{a}"', 'Constant(\N{a}) unknown at - line 1, within string' . "\n" ."Execution of - aborted due to compilation errors.\n", { stderr => 1 }, diff --git a/t/op/svleak.t b/t/op/svleak.t index e7c5988..b4a3fcf 100644 --- a/t/op/svleak.t +++ b/t/op/svleak.t @@ -329,6 +329,7 @@ leak(2, 0, sub { eval {%a = ($die_on_fetch, 0)}; # key eval {%a = (0, $die_on_fetch)}; # value eval {%a = ($die_on_fetch, $die_on_fetch)}; # both + eval {%a = ($die_on_fetch)}; # key, odd elements }, 'hash assignment does not leak'); leak(2, 0, sub { eval {@a = ($die_on_fetch)}; -- Perl5 Master Repository
