diff options
Diffstat (limited to 't')
| -rw-r--r-- | t/op/aassign.t | 265 | ||||
| -rw-r--r-- | t/op/array.t | 8 | ||||
| -rw-r--r-- | t/op/hash.t | 7 | ||||
| -rw-r--r-- | t/op/sort.t | 18 | ||||
| -rw-r--r-- | t/perf/benchmarks | 370 | ||||
| -rw-r--r-- | t/perf/optree.t | 84 |
6 files changed, 731 insertions, 21 deletions
diff --git a/t/op/aassign.t b/t/op/aassign.t new file mode 100644 index 0000000000..622053c004 --- /dev/null +++ b/t/op/aassign.t @@ -0,0 +1,265 @@ +#!./perl -w + +# Some miscellaneous checks for the list assignment operator, OP_AASSIGN. +# +# This file was only added in 2015; before then, such tests were +# typically in various other random places like op/array.t. This test file +# doesn't therefore attempt to be comprehensive; it merely provides a +# central place to new put additional tests, especially those related to +# the trickiness of commonality, e.g. ($a,$b) = ($b,$a). +# +# In particular, it's testing the flags +# OPpASSIGN_COMMON_SCALAR +# OPpASSIGN_COMMON_RC1 +# OPpASSIGN_COMMON_AGG + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} + +use warnings; +use strict; + +# general purpose package vars + +our $pkg_scalar; +our @pkg_array; +our %pkg_hash; + +sub f_ret_14 { return 1..4 } + +# stringify a hash ref + +sub sh { + my $rh = $_[0]; + join ',', map "$_:$rh->{$_}", sort keys %$rh; +} + + +# where the RHS has surplus elements + +{ + my ($a,$b); + ($a,$b) = f_ret_14(); + is("$a:$b", "1:2", "surplus"); +} + +# common with slices + +{ + my @a = (1,2); + @a[0,1] = @a[1,0]; + is("$a[0]:$a[1]", "2:1", "lex array slice"); +} + +# package alias + +{ + my ($a, $b) = 1..2; + for $pkg_scalar ($a) { + ($pkg_scalar, $b) = (3, $a); + is($pkg_scalar, 3, "package alias pkg"); + is("$a:$b", "3:1", "package alias a:b"); + } +} + +# my array/hash populated via closure + +{ + my $ra = f1(); + my ($x, @a) = @$ra; + sub f1 { $x = 1; @a = 2..4; \@a } + is($x, 2, "my: array closure x"); + is("@a", "3 4", "my: array closure a"); + + my $rh = f2(); + my ($k, $v, %h) = (d => 4, %$rh, e => 6); + sub f2 { $k = 'a'; $v = 1; %h = qw(b 2 c 3); \%h } + is("$k:$v", "d:4", "my: hash closure k:v"); + is(sh(\%h), "b:2,c:3,e:6", "my: hash closure h"); +} + + +# various shared element scenarios within a my (...) + +{ + my ($x,$y) = f3(); # $x and $y on both sides + sub f3 : lvalue { ($x,$y) = (1,2); $y, $x } + is ("$x:$y", "2:1", "my: scalar and lvalue sub"); +} + +{ + my $ra = f4(); + my @a = @$ra; # elements of @a on both sides + sub f4 { @a = 1..4; \@a } + is("@a", "1 2 3 4", "my: array and elements"); +} + +{ + my $rh = f5(); + my %h = %$rh; # elements of %h on both sides + sub f5 { %h = qw(a 1 b 2 c 3); \%h } + is(sh(\%h), "a:1,b:2,c:3", "my: hash and elements"); +} + +{ + f6(); + our $xalias6; + my ($x, $y) = (2, $xalias6); + sub f6 { $x = 1; *xalias6 = \$x; } + is ("$x:$y", "2:1", "my: pkg var aliased to lexical"); +} + + +{ + my @a; + f7(); + my ($x,$y) = @a; + is ("$x:$y", "2:1", "my: lex array elements aliased"); + + sub f7 { + ($x, $y) = (1,2); + use feature 'refaliasing'; + no warnings 'experimental'; + \($a[0], $a[1]) = \($y,$x); + } +} + +{ + @pkg_array = (); + f8(); + my ($x,$y) = @pkg_array; + is ("$x:$y", "2:1", "my: pkg array elements aliased"); + + sub f8 { + ($x, $y) = (1,2); + use feature 'refaliasing'; + no warnings 'experimental'; + \($pkg_array[0], $pkg_array[1]) = \($y,$x); + } +} + +{ + f9(); + my ($x,$y) = f9(); + is ("$x:$y", "2:1", "my: pkg scalar alias"); + + our $xalias9; + sub f9 : lvalue { + ($x, $y) = (1,2); + *xalias9 = \$x; + $y, $xalias9; + } +} + +{ + use feature 'refaliasing'; + no warnings 'experimental'; + + f10(); + our $pkg10; + \(my $lex) = \$pkg10; + my @a = ($lex,3); # equivalent to ($a[0],3) + is("@a", "1 3", "my: lex alias of array alement"); + + sub f10 { + @a = (1,2); + \$pkg10 = \$a[0]; + } + +} + +{ + use feature 'refaliasing'; + no warnings 'experimental'; + + f11(); + my @b; + my @a = (@b); + is("@a", "2 1", "my: lex alias of array alements"); + + sub f11 { + @a = (1,2); + \$b[0] = \$a[1]; + \$b[1] = \$a[0]; + } +} + +# package aliasing + +{ + my ($x, $y) = (1,2); + + for $pkg_scalar ($x) { + ($pkg_scalar, $y) = (3, $x); + is("$pkg_scalar,$y", "3,1", "package scalar aliased"); + } +} + +# lvalue subs on LHS + +{ + my @a; + sub f12 : lvalue { @a } + (f12()) = 1..3; + is("@a", "1 2 3", "lvalue sub on RHS returns array"); +} + +{ + my ($x,$y); + sub f13 : lvalue { $x,$y } + (f13()) = 1..3; + is("$x:$y", "1:2", "lvalue sub on RHS returns scalars"); +} + + +# package shared scalar vars + +{ + our $pkg14a = 1; + our $pkg14b = 2; + ($pkg14a,$pkg14b) = ($pkg14b,$pkg14a); + is("$pkg14a:$pkg14b", "2:1", "shared package scalars"); +} + +# lexical shared scalar vars + +{ + my $a = 1; + my $b = 2; + ($a,$b) = ($b,$a); + is("$a:$b", "2:1", "shared lexical scalars"); +} + + +# lexical nested array elem swap + +{ + my @a; + $a[0][0] = 1; + $a[0][1] = 2; + ($a[0][0],$a[0][1]) = ($a[0][1],$a[0][0]); + is("$a[0][0]:$a[0][1]", "2:1", "lexical nested array elem swap"); +} + +# package nested array elem swap + +{ + our @a15; + $a15[0][0] = 1; + $a15[0][1] = 2; + ($a15[0][0],$a15[0][1]) = ($a15[0][1],$a15[0][0]); + is("$a15[0][0]:$a15[0][1]", "2:1", "package nested array elem swap"); +} + +# surplus RHS junk +# +{ + our ($a16, $b16); + ($a16, undef, $b16) = 1..30; + is("$a16:$b16", "1:3", "surplus RHS junk"); +} + +done_testing(); diff --git a/t/op/array.t b/t/op/array.t index 7239d482fc..4f0a772aba 100644 --- a/t/op/array.t +++ b/t/op/array.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan (172); +plan (173); # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -549,4 +549,10 @@ is "@ary", 'b a', for(scalar $#foo) { $_ = 3 } is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)'; +{ + my @a = qw(a b c); + @a = @a; + is "@a", 'a b c', 'assigning to itself'; +} + "We're included by lib/Tie/Array/std.t so we need to return something true"; diff --git a/t/op/hash.t b/t/op/hash.t index 429eb38ce2..b4d6c2585f 100644 --- a/t/op/hash.t +++ b/t/op/hash.t @@ -207,4 +207,11 @@ torture_hash('a .. zz', 'a' .. 'zz'); torture_hash('0 .. 9', 0 .. 9); torture_hash("'Perl'", 'Rules'); +{ + my %h = qw(a x b y c z); + no warnings qw(misc uninitialized); + %h = $h{a}; + is(join(':', %h), 'x:', 'hash self-assign'); +} + done_testing(); diff --git a/t/op/sort.t b/t/op/sort.t index 01227e3ff6..2e3ba68828 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } use warnings; -plan(tests => 190); +plan(tests => 189); # these shouldn't hang { @@ -778,12 +778,16 @@ cmp_ok($answer,'eq','good','sort subr called from other package'); is $@, "", 'abrupt scope exit turns off readonliness'; } -{ - local $TODO = "sort should make sure elements are not freed in the sort block"; - eval { @nomodify_x=(1..8); - our @copy = sort { undef @nomodify_x; 1 } (@nomodify_x, 3); }; - is($@, ""); -} +# I commented out this TODO test because messing with FREEd scalars on the +# stack can have all sorts of strange side-effects, not made safe by eval +# - DAPM. +# +#{ +# local $TODO = "sort should make sure elements are not freed in the sort block"; +# eval { @nomodify_x=(1..8); +# our @copy = sort { undef @nomodify_x; 1 } (@nomodify_x, 3); }; +# is($@, ""); +#} # Sorting shouldn't increase the refcount of a sub diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 144b58cb96..2e58849e38 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -242,4 +242,374 @@ code => 'index $x, "b"', }, + + # list assign, OP_AASSIGN + + + # (....) = () + + 'expr::aassign::ma_empty' => { + desc => 'my array assigned empty', + setup => '', + code => 'my @a = ()', + }, + 'expr::aassign::lax_empty' => { + desc => 'non-empty lexical array assigned empty', + setup => 'my @a = 1..3;', + code => '@a = ()', + }, + 'expr::aassign::llax_empty' => { + desc => 'non-empty lexical var and array assigned empty', + setup => 'my ($x, @a) = 1..4;', + code => '($x, @a) = ()', + }, + 'expr::aassign::3m_empty' => { + desc => 'three my vars assigned empty', + setup => '', + code => 'my ($x,$y,$z) = ()', + }, + 'expr::aassign::3l_empty' => { + desc => 'three lexical vars assigned empty', + setup => 'my ($x,$y,$z)', + code => '($x,$y,$z) = ()', + }, + 'expr::aassign::pa_empty' => { + desc => 'package array assigned empty', + setup => '', + code => '@a = ()', + }, + 'expr::aassign::pax_empty' => { + desc => 'non-empty package array assigned empty', + setup => '@a = (1,2,3)', + code => '@a = ()', + }, + 'expr::aassign::3p_empty' => { + desc => 'three package vars assigned empty', + setup => '($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = ()', + }, + + # (....) = (1,2,3) + + 'expr::aassign::ma_3c' => { + desc => 'my array assigned 3 consts', + setup => '', + code => 'my @a = (1,2,3)', + }, + 'expr::aassign::lax_3c' => { + desc => 'non-empty lexical array assigned 3 consts', + setup => 'my @a = 1..3;', + code => '@a = (1,2,3)', + }, + 'expr::aassign::llax_3c' => { + desc => 'non-empty lexical var and array assigned 3 consts', + setup => 'my ($x, @a) = 1..4;', + code => '($x, @a) = (1,2,3)', + }, + 'expr::aassign::3m_3c' => { + desc => 'three my vars assigned 3 consts', + setup => '', + code => 'my ($x,$y,$z) = (1,2,3)', + }, + 'expr::aassign::3l_3c' => { + desc => 'three lexical vars assigned 3 consts', + setup => 'my ($x,$y,$z)', + code => '($x,$y,$z) = (1,2,3)', + }, + 'expr::aassign::pa_3c' => { + desc => 'package array assigned 3 consts', + setup => '', + code => '@a = (1,2,3)', + }, + 'expr::aassign::pax_3c' => { + desc => 'non-empty package array assigned 3 consts', + setup => '@a = (1,2,3)', + code => '@a = (1,2,3)', + }, + 'expr::aassign::3p_3c' => { + desc => 'three package vars assigned 3 consts', + setup => '($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = (1,2,3)', + }, + + # (....) = @lexical + + 'expr::aassign::ma_la' => { + desc => 'my array assigned lexical array', + setup => 'my @init = 1..3;', + code => 'my @a = @init', + }, + 'expr::aassign::lax_la' => { + desc => 'non-empty lexical array assigned lexical array', + setup => 'my @init = 1..3; my @a = 1..3;', + code => '@a = @init', + }, + 'expr::aassign::llax_la' => { + desc => 'non-empty lexical var and array assigned lexical array', + setup => 'my @init = 1..3; my ($x, @a) = 1..4;', + code => '($x, @a) = @init', + }, + 'expr::aassign::3m_la' => { + desc => 'three my vars assigned lexical array', + setup => 'my @init = 1..3;', + code => 'my ($x,$y,$z) = @init', + }, + 'expr::aassign::3l_la' => { + desc => 'three lexical vars assigned lexical array', + setup => 'my @init = 1..3; my ($x,$y,$z)', + code => '($x,$y,$z) = @init', + }, + 'expr::aassign::pa_la' => { + desc => 'package array assigned lexical array', + setup => 'my @init = 1..3;', + code => '@a = @init', + }, + 'expr::aassign::pax_la' => { + desc => 'non-empty package array assigned lexical array', + setup => 'my @init = 1..3; @a = @init', + code => '@a = @init', + }, + 'expr::aassign::3p_la' => { + desc => 'three package vars assigned lexical array', + setup => 'my @init = 1..3; ($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = @init', + }, + + # (....) = @package + + 'expr::aassign::ma_pa' => { + desc => 'my array assigned package array', + setup => '@init = 1..3;', + code => 'my @a = @init', + }, + 'expr::aassign::lax_pa' => { + desc => 'non-empty lexical array assigned package array', + setup => '@init = 1..3; my @a = 1..3;', + code => '@a = @init', + }, + 'expr::aassign::llax_pa' => { + desc => 'non-empty lexical var and array assigned package array', + setup => '@init = 1..3; my ($x, @a) = 1..4;', + code => '($x, @a) = @init', + }, + 'expr::aassign::3m_pa' => { + desc => 'three my vars assigned package array', + setup => '@init = 1..3;', + code => 'my ($x,$y,$z) = @init', + }, + 'expr::aassign::3l_pa' => { + desc => 'three lexical vars assigned package array', + setup => '@init = 1..3; my ($x,$y,$z)', + code => '($x,$y,$z) = @init', + }, + 'expr::aassign::pa_pa' => { + desc => 'package array assigned package array', + setup => '@init = 1..3;', + code => '@a = @init', + }, + 'expr::aassign::pax_pa' => { + desc => 'non-empty package array assigned package array', + setup => '@init = 1..3; @a = @init', + code => '@a = @init', + }, + 'expr::aassign::3p_pa' => { + desc => 'three package vars assigned package array', + setup => '@init = 1..3; ($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = @init', + }, + + # (....) = @_; + + 'expr::aassign::ma_defary' => { + desc => 'my array assigned @_', + setup => '@_ = 1..3;', + code => 'my @a = @_', + }, + 'expr::aassign::lax_defary' => { + desc => 'non-empty lexical array assigned @_', + setup => '@_ = 1..3; my @a = 1..3;', + code => '@a = @_', + }, + 'expr::aassign::llax_defary' => { + desc => 'non-empty lexical var and array assigned @_', + setup => '@_ = 1..3; my ($x, @a) = 1..4;', + code => '($x, @a) = @_', + }, + 'expr::aassign::3m_defary' => { + desc => 'three my vars assigned @_', + setup => '@_ = 1..3;', + code => 'my ($x,$y,$z) = @_', + }, + 'expr::aassign::3l_defary' => { + desc => 'three lexical vars assigned @_', + setup => '@_ = 1..3; my ($x,$y,$z)', + code => '($x,$y,$z) = @_', + }, + 'expr::aassign::pa_defary' => { + desc => 'package array assigned @_', + setup => '@_ = 1..3;', + code => '@a = @_', + }, + 'expr::aassign::pax_defary' => { + desc => 'non-empty package array assigned @_', + setup => '@_ = 1..3; @a = @_', + code => '@a = @_', + }, + 'expr::aassign::3p_defary' => { + desc => 'three package vars assigned @_', + setup => '@_ = 1..3; ($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = @_', + }, + + + # (....) = ($lex1,$lex2,$lex3); + + 'expr::aassign::ma_3l' => { + desc => 'my array assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3;', + code => 'my @a = ($v1,$v2,$v3)', + }, + 'expr::aassign::lax_3l' => { + desc => 'non-empty lexical array assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3; my @a = 1..3;', + code => '@a = ($v1,$v2,$v3)', + }, + 'expr::aassign::llax_3l' => { + desc => 'non-empty lexical var and array assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3; my ($x, @a) = 1..4;', + code => '($x, @a) = ($v1,$v2,$v3)', + }, + 'expr::aassign::3m_3l' => { + desc => 'three my vars assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3;', + code => 'my ($x,$y,$z) = ($v1,$v2,$v3)', + }, + 'expr::aassign::3l_3l' => { + desc => 'three lexical vars assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3; my ($x,$y,$z)', + code => '($x,$y,$z) = ($v1,$v2,$v3)', + }, + 'expr::aassign::pa_3l' => { + desc => 'package array assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3;', + code => '@a = ($v1,$v2,$v3)', + }, + 'expr::aassign::pax_3l' => { + desc => 'non-empty package array assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3; @a = @_', + code => '@a = ($v1,$v2,$v3)', + }, + 'expr::aassign::3p_3l' => { + desc => 'three package vars assigned lexicals', + setup => 'my ($v1,$v2,$v3) = 1..3; ($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = ($v1,$v2,$v3)', + }, + + + # (....) = ($pkg1,$pkg2,$pkg3); + + 'expr::aassign::ma_3p' => { + desc => 'my array assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3;', + code => 'my @a = ($v1,$v2,$v3)', + }, + 'expr::aassign::lax_3p' => { + desc => 'non-empty lexical array assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3; my @a = 1..3;', + code => '@a = ($v1,$v2,$v3)', + }, + 'expr::aassign::llax_3p' => { + desc => 'non-empty lexical var and array assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3; my ($x, @a) = 1..4;', + code => '($x, @a) = ($v1,$v2,$v3)', + }, + 'expr::aassign::3m_3p' => { + desc => 'three my vars assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3;', + code => 'my ($x,$y,$z) = ($v1,$v2,$v3)', + }, + 'expr::aassign::3l_3p' => { + desc => 'three lexical vars assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3; my ($x,$y,$z)', + code => '($x,$y,$z) = ($v1,$v2,$v3)', + }, + 'expr::aassign::pa_3p' => { + desc => 'package array assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3;', + code => '@a = ($v1,$v2,$v3)', + }, + 'expr::aassign::pax_3p' => { + desc => 'non-empty package array assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3; @a = @_', + code => '@a = ($v1,$v2,$v3)', + }, + 'expr::aassign::3p_3p' => { + desc => 'three package vars assigned 3 package vars', + setup => '($v1,$v2,$v3) = 1..3; ($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = ($v1,$v2,$v3)', + }, + + + # (....) = (1,2,$shared); + + 'expr::aassign::llax_2c1s' => { + desc => 'non-empty lexical var and array assigned 2 consts and 1 shared var', + setup => 'my ($x, @a) = 1..4;', + code => '($x, @a) = (1,2,$x)', + }, + 'expr::aassign::3l_2c1s' => { + desc => 'three lexical vars assigned 2 consts and 1 shared var', + setup => 'my ($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = (1,2,$x)', + }, + 'expr::aassign::3p_2c1s' => { + desc => 'three package vars assigned 2 consts and 1 shared var', + setup => '($x,$y,$z) = 1..3;', + code => '($x,$y,$z) = (1,2,$x)', + }, + + + # ($a,$b) = ($b,$a); + + 'expr::aassign::2l_swap' => { + desc => 'swap two lexical vars', + setup => 'my ($a,$b) = (1,2)', + code => '($a,$b) = ($b,$a)', + }, + 'expr::aassign::2p_swap' => { + desc => 'swap two package vars', + setup => '($a,$b) = (1,2)', + code => '($a,$b) = ($b,$a)', + }, + 'expr::aassign::2laelem_swap' => { + desc => 'swap two lexical vars', + setup => 'my @a = (1,2)', + code => '($a[0],$a[1]) = ($a[1],$a[0])', + }, + + # misc list assign + + 'expr::aassign::5l_4l1s' => { + desc => 'long list of lexical vars, 1 shared', + setup => 'my ($a,$b,$c,$d,$e) = 1..5', + code => '($a,$b,$c,$d,$e) = ($a,$a,$c,$d,$e)', + }, + + 'expr::aassign::5p_4p1s' => { + desc => 'long list of package vars, 1 shared', + setup => '($a,$b,$c,$d,$e) = 1..5', + code => '($a,$b,$c,$d,$e) = ($a,$a,$c,$d,$e)', + }, + 'expr::aassign::5l_defary' => { + desc => 'long list of lexical vars to assign @_ to', + setup => '@_ = 1..5', + code => 'my ($a,$b,$c,$d,$e) = @_', + }, + 'expr::aassign::5l1la_defary' => { + desc => 'long list of lexical vars plus long slurp to assign @_ to', + setup => '@_ = 1..20', + code => 'my ($a,$b,$c,$d,$e,@rest) = @_', + }, + + ]; diff --git a/t/perf/optree.t b/t/perf/optree.t index 7e3a06e14a..40d2091ac7 100644 --- a/t/perf/optree.t +++ b/t/perf/optree.t @@ -10,26 +10,84 @@ BEGIN { @INC = '../lib'; } -plan 24; +plan 51; use v5.10; # state -use B qw 'svref_2object OPpASSIGN_COMMON'; - +use B qw(svref_2object + OPpASSIGN_COMMON_SCALAR + OPpASSIGN_COMMON_RC1 + OPpASSIGN_COMMON_AGG + ); + + +# Test that OP_AASSIGN gets the appropriate +# OPpASSIGN_COMMON* flags set. +# +# Too few flags set is likely to cause code to misbehave; +# too many flags set unnecessarily slows things down. +# See also the tests in t/op/aassign.t + +for my $test ( + # Each anon array contains: + # [ + # expected flags: + # a 3 char string, each char showing whether we expect a + # particular flag to be set: + # '-' indicates any char not set, while + # 'S': char 0: OPpASSIGN_COMMON_SCALAR, + # 'R': char 1: OPpASSIGN_COMMON_RC1, + # 'A' char 2: OPpASSIGN_COMMON_AGG, + # code to eval, + # description, + # ] + + [ "---", '() = (1, $x, my $y, @z, f($p))', 'no LHS' ], + [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = ()', 'no RHS' ], + [ "---", '(undef, $x, my $y, @z, ($a ? $b : $c)) = (1,2)', 'safe RHS' ], + [ "---", 'my @a = (1,2)', 'safe RHS: my array' ], + [ "---", 'my %h = (1,2)', 'safe RHS: my hash' ], + [ "---", 'my ($a,$b,$c,$d) = 1..6; ($a,$b) = ($c,$d);', 'non-common lex' ], + [ "---", '($x,$y) = (1,2)', 'pkg var LHS only' ], + [ "---", 'my $p; my ($x,$y) = ($p, $p)', 'my; dup lex var on RHS' ], + [ "---", 'my $p; my ($x,$y); ($x,$y) = ($p, $p)', 'dup lex var on RHS' ], + [ "-R-", 'my ($self) = @_', 'LHS lex scalar only' ], + [ "-RA", 'my ($self, @rest) = @_', 'LHS lex mixed' ], + [ "-R-", 'my ($x,$y) = ($p, $q)', 'pkg var RHS only' ], + [ "S--", '($x,$y) = ($p, $q)', 'pkg scalar both sides' ], + [ "--A", 'my (@a, @b); @a = @b', 'lex ary both sides' ], + [ "-R-", 'my ($x,$y,$z,@a); ($x,$y,$z) = @a ', 'lex vars to lex ary' ], + [ "--A", '@a = @b', 'pkg ary both sides' ], + [ "--A", 'my (%a,%b); %a = %b', 'lex hash both sides' ], + [ "--A", '%a = %b', 'pkg hash both sides' ], + [ "--A", 'my $x; @a = ($a[0], $a[$x])', 'common ary' ], + [ "--A", 'my ($x,@a); @a = ($a[0], $a[$x])', 'common lex ary' ], + [ "S-A", 'my $x; ($a[$x], $a[0]) = ($a[0], $a[$x])', 'common ary elems' ], + [ "S-A", 'my ($x,@a); ($a[$x], $a[0]) = ($a[0], $a[$x])', + 'common lex ary elems' ], + [ "--A", 'my $x; my @a = @$x', 'lex ary may have stuff' ], + [ "-RA", 'my $x; my ($b, @a) = @$x', 'lex ary may have stuff' ], + [ "--A", 'my $x; my %a = @$x', 'lex hash may have stuff' ], + [ "-RA", 'my $x; my ($b, %a) = @$x', 'lex hash may have stuff' ], + [ "--A", 'my (@a,@b); @a = ($b[0])', 'lex ary and elem' ], + [ "S-A", 'my @a; ($a[1],$a[0]) = @a', 'lex ary and elem' ], + [ "--A", 'my @x; @y = $x[0]', 'pkg ary from lex elem' ], +) { + my ($exp, $code, $desc) = @$test; + my $sub = eval "sub { $code }" + or die + "aassign eval('$code') failed: this test needs to be rewritten:\n" + . $@; -# aassign with no common vars -for ('my ($self) = @_', - 'my @x; @y = $x[0]', # aelemfast_lex - ) -{ - my $sub = eval "sub { $_ }"; - my $last_expr = - svref_2object($sub)->ROOT->first->last; + my $last_expr = svref_2object($sub)->ROOT->first->last; if ($last_expr->name ne 'aassign') { die "Expected aassign but found ", $last_expr->name, "; this test needs to be rewritten" } - is $last_expr->private & OPpASSIGN_COMMON, 0, - "no ASSIGN_COMMON for $_"; + my $got = + (($last_expr->private & OPpASSIGN_COMMON_SCALAR) ? 'S' : '-') + . (($last_expr->private & OPpASSIGN_COMMON_RC1) ? 'R' : '-') + . (($last_expr->private & OPpASSIGN_COMMON_AGG) ? 'A' : '-'); + is $got, $exp, "OPpASSIGN_COMMON: $desc: '$code'"; } |