156d68f1eSafresh1#!perl 2b8851fccSafresh1BEGIN { 3b8851fccSafresh1 chdir 't'; 4b8851fccSafresh1 require './test.pl'; 5b8851fccSafresh1 set_up_inc("../lib"); 6b8851fccSafresh1} 7b8851fccSafresh1 8*3d61058aSafresh1plan 201; 9b8851fccSafresh1 10b8851fccSafresh1eval '\$x = \$y'; 11b8851fccSafresh1like $@, qr/^Experimental aliasing via reference not enabled/, 12b8851fccSafresh1 'error when feature is disabled'; 13b8851fccSafresh1eval '\($x) = \$y'; 14b8851fccSafresh1like $@, qr/^Experimental aliasing via reference not enabled/, 15b8851fccSafresh1 'error when feature is disabled (aassign)'; 16b8851fccSafresh1 17b8851fccSafresh1use feature 'refaliasing', 'state'; 18b8851fccSafresh1 19b8851fccSafresh1{ 20b8851fccSafresh1 my($w,$c); 21b8851fccSafresh1 local $SIG{__WARN__} = sub { $c++; $w = shift }; 22b8851fccSafresh1 eval '\$x = \$y'; 23b8851fccSafresh1 is $c, 1, 'one warning from lv ref assignment'; 24b8851fccSafresh1 like $w, qr/^Aliasing via reference is experimental/, 25b8851fccSafresh1 'experimental warning'; 26b8851fccSafresh1 undef $c; 27b8851fccSafresh1 eval '\($x) = \$y'; 28b8851fccSafresh1 is $c, 1, 'one warning from lv ref list assignment'; 29b8851fccSafresh1 like $w, qr/^Aliasing via reference is experimental/, 30b8851fccSafresh1 'experimental warning'; 31b8851fccSafresh1} 32b8851fccSafresh1 33b8851fccSafresh1no warnings 'experimental::refaliasing'; 34b8851fccSafresh1 35b8851fccSafresh1# Scalars 36b8851fccSafresh1 37b8851fccSafresh1\$x = \$y; 38b8851fccSafresh1is \$x, \$y, '\$pkg_scalar = ...'; 39b8851fccSafresh1my $m; 40b8851fccSafresh1\$m = \$y; 41b8851fccSafresh1is \$m, \$y, '\$lexical = ...'; 42b8851fccSafresh1\my $n = \$y; 43b8851fccSafresh1is \$n, \$y, '\my $lexical = ...'; 44b8851fccSafresh1@_ = \$_; 45b8851fccSafresh1\($x) = @_; 46b8851fccSafresh1is \$x, \$_, '\($pkgvar) = ... gives list context'; 47b8851fccSafresh1undef *x; 48b8851fccSafresh1(\$x) = @_; 49b8851fccSafresh1is \$x, \$_, '(\$pkgvar) = ... gives list context'; 50b8851fccSafresh1my $o; 51b8851fccSafresh1\($o) = @_; 52b8851fccSafresh1is \$o, \$_, '\($lexical) = ... gives list cx'; 53b8851fccSafresh1my $q; 54b8851fccSafresh1(\$q) = @_; 55b8851fccSafresh1is \$q, \$_, '(\$lexical) = ... gives list cx'; 56b8851fccSafresh1\(my $p) = @_; 57b8851fccSafresh1is \$p, \$_, '\(my $lexical) = ... gives list cx'; 58b8851fccSafresh1(\my $r) = @_; 59b8851fccSafresh1is \$r, \$_, '(\my $lexical) = ... gives list cx'; 60b8851fccSafresh1\my($s) = @_; 61b8851fccSafresh1is \$s, \$_, '\my($lexical) = ... gives list cx'; 62b8851fccSafresh1\($_a, my $a) = @{[\$b, \$c]}; 63b8851fccSafresh1is \$_a, \$b, 'package scalar in \(...)'; 64b8851fccSafresh1is \$a, \$c, 'lex scalar in \(...)'; 65b8851fccSafresh1(\$_b, \my $b) = @{[\$b, \$c]}; 66b8851fccSafresh1is \$_b, \$::b, 'package scalar in (\$foo, \$bar)'; 67b8851fccSafresh1is \$b, \$c, 'lex scalar in (\$foo, \$bar)'; 68b8851fccSafresh1is do { \local $l = \3; $l }, 3, '\local $scalar assignment'; 69b8851fccSafresh1is $l, undef, 'localisation unwound'; 70b8851fccSafresh1is do { \(local $l) = \4; $l }, 4, '\(local $scalar) assignment'; 71b8851fccSafresh1is $l, undef, 'localisation unwound'; 72b8851fccSafresh1\$foo = \*bar; 73b8851fccSafresh1is *foo{SCALAR}, *bar{GLOB}, 'globref-to-scalarref assignment'; 74b8851fccSafresh1for (1,2) { 75b8851fccSafresh1 \my $x = \3, 76b8851fccSafresh1 \my($y) = \3, 77b8851fccSafresh1 \state $a = \3, 78b8851fccSafresh1 \state($b) = \3 if $_ == 1; 79*3d61058aSafresh1 \state $c = \$_; 80b8851fccSafresh1 if ($_ == 2) { 81b8851fccSafresh1 is $x, undef, '\my $x = ... clears $x on scope exit'; 82b8851fccSafresh1 is $y, undef, '\my($x) = ... clears $x on scope exit'; 83b8851fccSafresh1 is $a, 3, '\state $x = ... does not clear $x on scope exit'; 84b8851fccSafresh1 is $b, 3, '\state($x) = ... does not clear $x on scope exit'; 85*3d61058aSafresh1 is $c, 1, '\state $x = ... can be used with refaliasing'; 86b8851fccSafresh1 } 87b8851fccSafresh1} 88b8851fccSafresh1 89*3d61058aSafresh1# Scalars in lvalue context 90*3d61058aSafresh1 91*3d61058aSafresh1{ 92*3d61058aSafresh1 my $s = 3; 93*3d61058aSafresh1 my $t = 5; 94*3d61058aSafresh1 95*3d61058aSafresh1 sub foo1 { 96*3d61058aSafresh1 ok ref($_[0]), "foo1(alias) passes ref"; 97*3d61058aSafresh1 is ${$_[0]}, 5, "foo1(alias) passes ref to t"; 98*3d61058aSafresh1 ${$_[0]} = 7; 99*3d61058aSafresh1 } 100*3d61058aSafresh1 foo1(\$s = \$t); 101*3d61058aSafresh1 is $s, 7, "foo1(alias) passes ref to t" 102*3d61058aSafresh1} 103*3d61058aSafresh1 104*3d61058aSafresh1 105*3d61058aSafresh1 106b8851fccSafresh1# Array Elements 107b8851fccSafresh1 108b8851fccSafresh1sub expect_scalar_cx { wantarray ? 0 : \$_ } 109b8851fccSafresh1sub expect_list_cx { wantarray ? (\$_,\$_) : 0 } 110b8851fccSafresh1\$a[0] = expect_scalar_cx; 111b8851fccSafresh1is \$a[0], \$_, '\$array[0]'; 112b8851fccSafresh1\($a[1]) = expect_list_cx; 113b8851fccSafresh1is \$a[1], \$_, '\($array[0])'; 114b8851fccSafresh1{ 115b8851fccSafresh1 my @a; 116b8851fccSafresh1 \$a[0] = expect_scalar_cx; 117b8851fccSafresh1 is \$a[0], \$_, '\$lexical_array[0]'; 118b8851fccSafresh1 \($a[1]) = expect_list_cx; 119b8851fccSafresh1 is \$a[1], \$_, '\($lexical_array[0])'; 120b8851fccSafresh1 my $tmp; 121b8851fccSafresh1 { 122b8851fccSafresh1 \local $a[0] = \$tmp; 123b8851fccSafresh1 is \$a[0], \$tmp, '\local $a[0]'; 124b8851fccSafresh1 } 125b8851fccSafresh1 is \$a[0], \$_, '\local $a[0] unwound'; 126b8851fccSafresh1 { 127b8851fccSafresh1 \local ($a[1]) = \$tmp; 128b8851fccSafresh1 is \$a[1], \$tmp, '\local ($a[0])'; 129b8851fccSafresh1 } 130b8851fccSafresh1 is \$a[1], \$_, '\local $a[0] unwound'; 131b8851fccSafresh1} 132b8851fccSafresh1{ 133b8851fccSafresh1 my @a; 134b8851fccSafresh1 \@a[0,1] = expect_list_cx; 135b8851fccSafresh1 is \$a[0].\$a[1], \$_.\$_, '\@array[indices]'; 136b8851fccSafresh1 \(@a[2,3]) = expect_list_cx; 137b8851fccSafresh1 is \$a[0].\$a[1], \$_.\$_, '\(@array[indices])'; 138b8851fccSafresh1 my $tmp; 139b8851fccSafresh1 { 140b8851fccSafresh1 \local @a[0,1] = (\$tmp)x2; 141b8851fccSafresh1 is \$a[0].\$a[1], \$tmp.\$tmp, '\local @a[indices]'; 142b8851fccSafresh1 } 143b8851fccSafresh1 is \$a[0].\$a[1], \$_.\$_, '\local @a[indices] unwound'; 144b8851fccSafresh1} 145b8851fccSafresh1 146b8851fccSafresh1# Hash Elements 147b8851fccSafresh1 148b8851fccSafresh1\$h{a} = expect_scalar_cx; 149b8851fccSafresh1is \$h{a}, \$_, '\$hash{a}'; 150b8851fccSafresh1\($h{b}) = expect_list_cx; 151b8851fccSafresh1is \$h{b}, \$_, '\($hash{a})'; 152b8851fccSafresh1{ 153b8851fccSafresh1 my %h; 154b8851fccSafresh1 \$h{a} = expect_scalar_cx; 155b8851fccSafresh1 is \$h{a}, \$_, '\$lexical_array{a}'; 156b8851fccSafresh1 \($h{b}) = expect_list_cx; 157b8851fccSafresh1 is \$h{b}, \$_, '\($lexical_array{a})'; 158b8851fccSafresh1 my $tmp; 159b8851fccSafresh1 { 160b8851fccSafresh1 \local $h{a} = \$tmp; 161b8851fccSafresh1 is \$h{a}, \$tmp, '\local $h{a}'; 162b8851fccSafresh1 } 163b8851fccSafresh1 is \$h{a}, \$_, '\local $h{a} unwound'; 164b8851fccSafresh1 { 165b8851fccSafresh1 \local ($h{b}) = \$tmp; 166b8851fccSafresh1 is \$h{b}, \$tmp, '\local ($h{a})'; 167b8851fccSafresh1 } 168b8851fccSafresh1 is \$h{b}, \$_, '\local $h{a} unwound'; 169b8851fccSafresh1} 170b8851fccSafresh1{ 171b8851fccSafresh1 my %h; 172b8851fccSafresh1 \@h{"a","b"} = expect_list_cx; 173b8851fccSafresh1 is \$h{a}.\$h{b}, \$_.\$_, '\@hash{indices}'; 174b8851fccSafresh1 \(@h{2,3}) = expect_list_cx; 175b8851fccSafresh1 is \$h{a}.\$h{b}, \$_.\$_, '\(@hash{indices})'; 176b8851fccSafresh1 my $tmp; 177b8851fccSafresh1 { 178b8851fccSafresh1 \local @h{"a","b"} = (\$tmp)x2; 179b8851fccSafresh1 is \$h{a}.\$h{b}, \$tmp.\$tmp, '\local @h{indices}'; 180b8851fccSafresh1 } 181b8851fccSafresh1 is \$h{a}.\$h{b}, \$_.\$_, '\local @h{indices} unwound'; 182b8851fccSafresh1} 183b8851fccSafresh1 184b8851fccSafresh1# Arrays 185b8851fccSafresh1 186b8851fccSafresh1package ArrayTest { 187b8851fccSafresh1 BEGIN { *is = *main::is } 188b8851fccSafresh1 sub expect_scalar_cx { wantarray ? 0 : \@ThatArray } 189b8851fccSafresh1 sub expect_list_cx { wantarray ? (\$_,\$_) : 0 } 190b8851fccSafresh1 sub expect_list_cx_a { wantarray ? (\@ThatArray)x2 : 0 } 191b8851fccSafresh1 \@a = expect_scalar_cx; 192b8851fccSafresh1 is \@a, \@ThatArray, '\@pkg'; 193b8851fccSafresh1 my @a; 194b8851fccSafresh1 \@a = expect_scalar_cx; 195b8851fccSafresh1 is \@a, \@ThatArray, '\@lexical'; 196b8851fccSafresh1 (\@b) = expect_list_cx_a; 197b8851fccSafresh1 is \@b, \@ThatArray, '(\@pkg)'; 198b8851fccSafresh1 my @b; 199b8851fccSafresh1 (\@b) = expect_list_cx_a; 200b8851fccSafresh1 is \@b, \@ThatArray, '(\@lexical)'; 201b8851fccSafresh1 \my @c = expect_scalar_cx; 202b8851fccSafresh1 is \@c, \@ThatArray, '\my @lexical'; 203b8851fccSafresh1 (\my @d) = expect_list_cx_a; 204b8851fccSafresh1 is \@d, \@ThatArray, '(\my @lexical)'; 205b8851fccSafresh1 \(@e) = expect_list_cx; 206b8851fccSafresh1 is \$e[0].\$e[1], \$_.\$_, '\(@pkg)'; 207b8851fccSafresh1 my @e; 208b8851fccSafresh1 \(@e) = expect_list_cx; 209b8851fccSafresh1 is \$e[0].\$e[1], \$_.\$_, '\(@lexical)'; 210b8851fccSafresh1 \(my @f) = expect_list_cx; 211b8851fccSafresh1 is \$f[0].\$f[1], \$_.\$_, '\(my @lexical)'; 212b8851fccSafresh1 \my(@g) = expect_list_cx; 213b8851fccSafresh1 is \$g[0].\$g[1], \$_.\$_, '\my(@lexical)'; 214b8851fccSafresh1 my $old = \@h; 215b8851fccSafresh1 { 216b8851fccSafresh1 \local @h = \@ThatArray; 217b8851fccSafresh1 is \@h, \@ThatArray, '\local @a'; 218b8851fccSafresh1 } 219b8851fccSafresh1 is \@h, $old, '\local @a unwound'; 220b8851fccSafresh1 $old = \@i; 221b8851fccSafresh1 { 222b8851fccSafresh1 (\local @i) = \@ThatArray; 223b8851fccSafresh1 is \@i, \@ThatArray, '(\local @a)'; 224b8851fccSafresh1 } 225b8851fccSafresh1 is \@i, $old, '(\local @a) unwound'; 226b8851fccSafresh1} 227*3d61058aSafresh1 228*3d61058aSafresh1# Test list assignments in both lval and rval list context 229*3d61058aSafresh1# 230*3d61058aSafresh1# Note that these tests essentially just codify current behaviour. 231*3d61058aSafresh1# Whether that behaviour is sane is a debatable point. (See 232*3d61058aSafresh1# http://nntp.perl.org/group/perl.perl5.porters/267074 233*3d61058aSafresh1# "refaliasing list assignment in list context") 234*3d61058aSafresh1 235*3d61058aSafresh1{ 236*3d61058aSafresh1 # First, confirm behaviour in void context 237*3d61058aSafresh1 238*3d61058aSafresh1 { 239*3d61058aSafresh1 my (@a, @b, $p); 240*3d61058aSafresh1 my ($x, $y, $z) = qw(X Y Z); 241*3d61058aSafresh1 242*3d61058aSafresh1 (\$p, \(@a)) = (\$x, \$y, \$z); 243*3d61058aSafresh1 244*3d61058aSafresh1 is \$p, \$x, '(\$p, \(@a)) = ...; $p is alias'; 245*3d61058aSafresh1 is \$a[0], \$y, '(\$p, \(@a)) = ...; $a[0] is alias'; 246*3d61058aSafresh1 is \$a[1], \$z, '(\$p, \(@a)) = ...; $a[1] is alias'; 247*3d61058aSafresh1 } 248*3d61058aSafresh1 249*3d61058aSafresh1 # then confirm behaviour in scalar context 250*3d61058aSafresh1 251*3d61058aSafresh1 { 252*3d61058aSafresh1 my (@a, @b, $p); 253*3d61058aSafresh1 my ($x, $y, $z) = qw(X Y Z); 254*3d61058aSafresh1 255*3d61058aSafresh1 my $n = ((\$p, \(@a)) = (\$x, \$y, \$z)); 256*3d61058aSafresh1 257*3d61058aSafresh1 is \$p, \$x, '$n = (\$p, \(@a)) = ...; $p is alias'; 258*3d61058aSafresh1 is \$a[0], \$y, '$n = (\$p, \(@a)) = ...; $a[0] is alias'; 259*3d61058aSafresh1 is \$a[1], \$z, '$n = (\$p, \(@a)) = ...; $a[1] is alias'; 260*3d61058aSafresh1 is $n, 3, '$n = (\$p, \(@a)) = ...; n is 3'; 261*3d61058aSafresh1 } 262*3d61058aSafresh1 263*3d61058aSafresh1 # Now the real tests, first in rvalue list context 264*3d61058aSafresh1 265*3d61058aSafresh1 { 266*3d61058aSafresh1 my (@a, @b, $p); 267*3d61058aSafresh1 my ($x, $y, $z) = qw(X Y Z); 268*3d61058aSafresh1 269*3d61058aSafresh1 @b = ((\$p, \(@a)) = (\$x, \$y, \$z)); 270*3d61058aSafresh1 271*3d61058aSafresh1 is \$p, \$x, '@b = (\$p, \(@a) = ...); $p is alias'; 272*3d61058aSafresh1 is \$a[0], \$y, '@b = (\$p, \(@a) = ...); $a[0] is alias'; 273*3d61058aSafresh1 is \$a[1], \$z, '@b = (\$p, \(@a) = ...); $a[1] is alias'; 274*3d61058aSafresh1 ok ref $b[0], '@b = (\$p, \(@a) = ...); $b[0] is ref'; 275*3d61058aSafresh1 ok ref $b[1], '@b = (\$p, \(@a) = ...); $b[1] is ref'; 276*3d61058aSafresh1 ok ref $b[2], '@b = (\$p, \(@a) = ...); $b[2] is ref'; 277*3d61058aSafresh1 is $b[0], \$x, '@b = (\$p, \(@a) = ...); $b[0] is ref to alias'; 278*3d61058aSafresh1 is $b[1], \$y, '@b = (\$p, \(@a) = ...); $b[1] is ref to alias'; 279*3d61058aSafresh1 is $b[2], \$z, '@b = (\$p, \(@a) = ...); $b[2] is ref to alias'; 280*3d61058aSafresh1 } 281*3d61058aSafresh1 282*3d61058aSafresh1 # The same, now in lvalue list context 283*3d61058aSafresh1 # 284*3d61058aSafresh1 # Note that the outer assign just (uselessly) modifies temporary 285*3d61058aSafresh1 # references to $x etc; it doesn't do any aliasing. 286*3d61058aSafresh1 287*3d61058aSafresh1 { 288*3d61058aSafresh1 my (@a, @b, $p); 289*3d61058aSafresh1 my ($x, $y, $z) = qw(X Y Z); 290*3d61058aSafresh1 my ($rx, $ry, $rz) = \($x, $y, $z); 291*3d61058aSafresh1 292*3d61058aSafresh1 ((\$p, \(@a)) = ($rx, $ry, $rz)) = \(qw(A B C)); 293*3d61058aSafresh1 294*3d61058aSafresh1 is \$p, \$x, '(\$p, \(@a) = ...) = @b; $p is alias'; 295*3d61058aSafresh1 is \$a[0], \$y, '(\$p, \(@a) = ...) = @b; $a[0] is alias'; 296*3d61058aSafresh1 is \$a[1], \$z, '(\$p, \(@a) = ...) = @b; $a[1] is alias'; 297*3d61058aSafresh1 ok ref $rx, '(\$p, \(@a) = ...) = @b; $rx is still ref'; 298*3d61058aSafresh1 ok ref $ry, '(\$p, \(@a) = ...) = @b; $ry is still ref'; 299*3d61058aSafresh1 ok ref $rz, '(\$p, \(@a) = ...) = @b; $ry is still ref'; 300*3d61058aSafresh1 is $rx, \$x, '(\$p, \(@a) = ...) = @b; $rx is still ref to $x'; 301*3d61058aSafresh1 is $ry, \$y, '(\$p, \(@a) = ...) = @b; $ry is still ref to $y'; 302*3d61058aSafresh1 is $rz, \$z, '(\$p, \(@a) = ...) = @b; $rz is still ref to $z'; 303*3d61058aSafresh1 is $x, 'X', '(\$p, \(@a) = ...) = @b; $x is still X'; 304*3d61058aSafresh1 is $y, 'Y', '(\$p, \(@a) = ...) = @b; $y is still Y'; 305*3d61058aSafresh1 is $z, 'Z', '(\$p, \(@a) = ...) = @b; $z is still Z'; 306*3d61058aSafresh1 } 307*3d61058aSafresh1} 308*3d61058aSafresh1 309*3d61058aSafresh1 310b8851fccSafresh1for (1,2) { 311b8851fccSafresh1 \my @x = [1..3], 312b8851fccSafresh1 \my(@y) = \3, 313b8851fccSafresh1 \state @a = [1..3], 314b8851fccSafresh1 \state(@b) = \3 if $_ == 1; 315*3d61058aSafresh1 \state @c = [$_]; 316b8851fccSafresh1 if ($_ == 2) { 317b8851fccSafresh1 is @x, 0, '\my @x = ... clears @x on scope exit'; 318b8851fccSafresh1 is @y, 0, '\my(@x) = ... clears @x on scope exit'; 319b8851fccSafresh1 is "@a", "1 2 3", '\state @x = ... does not clear @x on scope exit'; 320b8851fccSafresh1 is "@b", 3, '\state(@x) = ... does not clear @x on scope exit'; 321*3d61058aSafresh1 is $c[0], 1, '\state @x = ... can be used with refaliasing'; 322b8851fccSafresh1 } 323b8851fccSafresh1} 324b8851fccSafresh1 325b8851fccSafresh1# Hashes 326b8851fccSafresh1 327b8851fccSafresh1package HashTest { 328b8851fccSafresh1 BEGIN { *is = *main::is } 329b8851fccSafresh1 sub expect_scalar_cx { wantarray ? 0 : \%ThatHash } 330b8851fccSafresh1 sub expect_list_cx { wantarray ? (\%ThatHash)x2 : 0 } 331b8851fccSafresh1 \%a = expect_scalar_cx; 332b8851fccSafresh1 is \%a, \%ThatHash, '\%pkg'; 333b8851fccSafresh1 my %a; 334b8851fccSafresh1 \%a = expect_scalar_cx; 335b8851fccSafresh1 is \%a, \%ThatHash, '\%lexical'; 336b8851fccSafresh1 (\%b) = expect_list_cx; 337b8851fccSafresh1 is \%b, \%ThatHash, '(\%pkg)'; 338b8851fccSafresh1 my %b; 339b8851fccSafresh1 (\%b) = expect_list_cx; 340b8851fccSafresh1 is \%b, \%ThatHash, '(\%lexical)'; 341b8851fccSafresh1 \my %c = expect_scalar_cx; 342b8851fccSafresh1 is \%c, \%ThatHash, '\my %lexical'; 343b8851fccSafresh1 (\my %d) = expect_list_cx; 344b8851fccSafresh1 is \%d, \%ThatHash, '(\my %lexical)'; 345b8851fccSafresh1 my $old = \%h; 346b8851fccSafresh1 { 347b8851fccSafresh1 \local %h = \%ThatHash; 348b8851fccSafresh1 is \%h, \%ThatHash, '\local %a'; 349b8851fccSafresh1 } 350b8851fccSafresh1 is \%h, $old, '\local %a unwound'; 351b8851fccSafresh1 $old = \%i; 352b8851fccSafresh1 { 353b8851fccSafresh1 (\local %i) = \%ThatHash; 354b8851fccSafresh1 is \%i, \%ThatHash, '(\local %a)'; 355b8851fccSafresh1 } 356b8851fccSafresh1 is \%i, $old, '(\local %a) unwound'; 357b8851fccSafresh1} 358b8851fccSafresh1for (1,2) { 359b8851fccSafresh1 \state %y = {1,2}, 360b8851fccSafresh1 \my %x = {1,2} if $_ == 1; 361*3d61058aSafresh1 \state %c = {X => $_}; 362b8851fccSafresh1 if ($_ == 2) { 363b8851fccSafresh1 is %x, 0, '\my %x = ... clears %x on scope exit'; 364b8851fccSafresh1 is "@{[%y]}", "1 2", '\state %x = ... does not clear %x on scope exit'; 365*3d61058aSafresh1 is $c{X}, 1, '\state %x = ... can be used with refaliasing'; 366b8851fccSafresh1 } 367b8851fccSafresh1} 368b8851fccSafresh1 369b8851fccSafresh1# Subroutines 370b8851fccSafresh1 371b8851fccSafresh1package CodeTest { 372b8851fccSafresh1 BEGIN { *is = *main::is; } 373b8851fccSafresh1 use feature 'lexical_subs'; 374b8851fccSafresh1 no warnings 'experimental::lexical_subs'; 375b8851fccSafresh1 sub expect_scalar_cx { wantarray ? 0 : \&ThatSub } 376b8851fccSafresh1 sub expect_list_cx { wantarray ? (\&ThatSub)x2 : 0 } 377b8851fccSafresh1 \&a = expect_scalar_cx; 378b8851fccSafresh1 is \&a, \&ThatSub, '\&pkg'; 379b8851fccSafresh1 my sub a; 380b8851fccSafresh1 \&a = expect_scalar_cx; 381b8851fccSafresh1 is \&a, \&ThatSub, '\&mysub'; 382b8851fccSafresh1 state sub as; 383b8851fccSafresh1 \&as = expect_scalar_cx; 384b8851fccSafresh1 is \&as, \&ThatSub, '\&statesub'; 385b8851fccSafresh1 (\&b) = expect_list_cx; 386b8851fccSafresh1 is \&b, \&ThatSub, '(\&pkg)'; 387b8851fccSafresh1 my sub b; 388b8851fccSafresh1 (\&b) = expect_list_cx; 389b8851fccSafresh1 is \&b, \&ThatSub, '(\&mysub)'; 390b8851fccSafresh1 my sub bs; 391b8851fccSafresh1 (\&bs) = expect_list_cx; 392b8851fccSafresh1 is \&bs, \&ThatSub, '(\&statesub)'; 393b8851fccSafresh1 \(&c) = expect_list_cx; 394b8851fccSafresh1 is \&c, \&ThatSub, '\(&pkg)'; 395b8851fccSafresh1 my sub b; 396b8851fccSafresh1 \(&c) = expect_list_cx; 397b8851fccSafresh1 is \&c, \&ThatSub, '\(&mysub)'; 398b8851fccSafresh1 my sub bs; 399b8851fccSafresh1 \(&cs) = expect_list_cx; 400b8851fccSafresh1 is \&cs, \&ThatSub, '\(&statesub)'; 40156d68f1eSafresh1 40256d68f1eSafresh1 package main { 40356d68f1eSafresh1 # this is only a problem in main:: due to 1e2cfe157ca 40456d68f1eSafresh1 sub sx { "x" } 40556d68f1eSafresh1 sub sy { "y" } 40656d68f1eSafresh1 is sx(), "x", "check original"; 40756d68f1eSafresh1 my $temp = \&sx; 40856d68f1eSafresh1 \&sx = \&sy; 40956d68f1eSafresh1 is sx(), "y", "aliased"; 41056d68f1eSafresh1 \&sx = $temp; 41156d68f1eSafresh1 is sx(), "x", "and restored"; 41256d68f1eSafresh1 } 413b8851fccSafresh1} 414b8851fccSafresh1 415b8851fccSafresh1# Mixed List Assignments 416b8851fccSafresh1 417b8851fccSafresh1(\$tahi, $rua) = \(1,2); 418b8851fccSafresh1is join(' ', $tahi, $$rua), '1 2', 419b8851fccSafresh1 'mixed scalar ref and scalar list assignment'; 420b8851fccSafresh1$_ = 1; 421b8851fccSafresh1\($bb, @cc, %dd, &ee, $_==1 ? $ff : @ff, $_==2 ? $gg : @gg, (@hh)) = 422b8851fccSafresh1 (\$BB, \@CC, \%DD, \&EE, \$FF, \@GG, \1, \2, \3); 423b8851fccSafresh1is \$bb, \$BB, '\$scalar in list assignment'; 424b8851fccSafresh1is \@cc, \@CC, '\@array in list assignment'; 425b8851fccSafresh1is \%dd, \%DD, '\%hash in list assignment'; 426b8851fccSafresh1is \&ee, \&EE, '\&code in list assignment'; 427b8851fccSafresh1is \$ff, \$FF, '$scalar in \ternary in list assignment'; 428b8851fccSafresh1is \@gg, \@GG, '@gg in \ternary in list assignment'; 429b8851fccSafresh1is "@hh", '1 2 3', '\(@array) in list assignment'; 430b8851fccSafresh1 431b8851fccSafresh1# Conditional expressions 432b8851fccSafresh1 433b8851fccSafresh1$_ = 3; 434b8851fccSafresh1$_ == 3 ? \$tahi : $rua = \3; 435b8851fccSafresh1is $tahi, 3, 'cond assignment resolving to scalar ref'; 436b8851fccSafresh1$_ == 0 ? \$toru : $wha = \3; 437b8851fccSafresh1is $$wha, 3, 'cond assignment resolving to scalar'; 438b8851fccSafresh1$_ == 3 ? \$rima : \$ono = \5; 439b8851fccSafresh1is $rima, 5, 'cond assignment with refgens on both branches'; 440b8851fccSafresh1\($_ == 3 ? $whitu : $waru) = \5; 441b8851fccSafresh1is $whitu, 5, '\( ?: ) assignment'; 442b8851fccSafresh1\($_ == 3 ? $_ < 4 ? $ii : $_ : $_) = \$_; 443b8851fccSafresh1is \$ii, \$_, 'nested \ternary assignment'; 444b8851fccSafresh1 445b8851fccSafresh1# Foreach 446b8851fccSafresh1 447b8851fccSafresh1for \my $topic (\$for1, \$for2) { 448b8851fccSafresh1 push @for, \$topic; 449b8851fccSafresh1} 450b8851fccSafresh1is "@for", \$for1 . ' ' . \$for2, 'foreach \my $a'; 451b8851fccSafresh1is \$topic, \$::topic, 'for \my scoping'; 452b8851fccSafresh1 453b8851fccSafresh1@for = (); 454b8851fccSafresh1for \$::a(\$for1, \$for2) { 455b8851fccSafresh1 push @for, \$::a; 456b8851fccSafresh1} 457b8851fccSafresh1is "@for", \$for1 . ' ' . \$for2, 'foreach \$::a'; 458b8851fccSafresh1 459b8851fccSafresh1@for = (); 460b8851fccSafresh1for \my @a([1,2], [3,4]) { 461b8851fccSafresh1 push @for, @a; 462b8851fccSafresh1} 463b8851fccSafresh1is "@for", "1 2 3 4", 'foreach \my @a [perl #22335]'; 464b8851fccSafresh1 465b8851fccSafresh1@for = (); 466b8851fccSafresh1for \@::a([1,2], [3,4]) { 467b8851fccSafresh1 push @for, @::a; 468b8851fccSafresh1} 469b8851fccSafresh1is "@for", "1 2 3 4", 'foreach \@::a [perl #22335]'; 470b8851fccSafresh1 471b8851fccSafresh1@for = (); 472b8851fccSafresh1for \my %a({5,6}, {7,8}) { 473b8851fccSafresh1 push @for, %a; 474b8851fccSafresh1} 475b8851fccSafresh1is "@for", "5 6 7 8", 'foreach \my %a [perl #22335]'; 476b8851fccSafresh1 477b8851fccSafresh1@for = (); 478b8851fccSafresh1for \%::a({5,6}, {7,8}) { 479b8851fccSafresh1 push @for, %::a; 480b8851fccSafresh1} 481b8851fccSafresh1is "@for", "5 6 7 8", 'foreach \%::a [perl #22335]'; 482b8851fccSafresh1 483b8851fccSafresh1@for = (); 484b8851fccSafresh1{ 485b8851fccSafresh1 use feature 'lexical_subs'; 486b8851fccSafresh1 no warnings 'experimental::lexical_subs'; 487b8851fccSafresh1 my sub a; 488b8851fccSafresh1 for \&a(sub {9}, sub {10}) { 489b8851fccSafresh1 push @for, &a; 490b8851fccSafresh1 } 491b8851fccSafresh1} 492b8851fccSafresh1is "@for", "9 10", 'foreach \&padcv'; 493b8851fccSafresh1 494b8851fccSafresh1@for = (); 495b8851fccSafresh1for \&::a(sub {9}, sub {10}) { 496b8851fccSafresh1 push @for, &::a; 497b8851fccSafresh1} 498b8851fccSafresh1is "@for", "9 10", 'foreach \&rv2cv'; 499b8851fccSafresh1 500b8851fccSafresh1# Errors 501b8851fccSafresh1 502b8851fccSafresh1eval { my $x; \$x = 3 }; 503b8851fccSafresh1like $@, qr/^Assigned value is not a reference at/, 'assigning non-ref'; 504b8851fccSafresh1eval { my $x; \$x = [] }; 505b8851fccSafresh1like $@, qr/^Assigned value is not a SCALAR reference at/, 506b8851fccSafresh1 'assigning non-scalar ref to scalar ref'; 507b8851fccSafresh1eval { \$::x = [] }; 508b8851fccSafresh1like $@, qr/^Assigned value is not a SCALAR reference at/, 509b8851fccSafresh1 'assigning non-scalar ref to package scalar ref'; 510b8851fccSafresh1eval { my @x; \@x = {} }; 511b8851fccSafresh1like $@, qr/^Assigned value is not an ARRAY reference at/, 512b8851fccSafresh1 'assigning non-array ref to array ref'; 513b8851fccSafresh1eval { \@::x = {} }; 514b8851fccSafresh1like $@, qr/^Assigned value is not an ARRAY reference at/, 515b8851fccSafresh1 'assigning non-array ref to package array ref'; 516b8851fccSafresh1eval { my %x; \%x = [] }; 517b8851fccSafresh1like $@, qr/^Assigned value is not a HASH reference at/, 518b8851fccSafresh1 'assigning non-hash ref to hash ref'; 519b8851fccSafresh1eval { \%::x = [] }; 520b8851fccSafresh1like $@, qr/^Assigned value is not a HASH reference at/, 521b8851fccSafresh1 'assigning non-hash ref to package hash ref'; 522b8851fccSafresh1eval { use feature 'lexical_subs'; 523b8851fccSafresh1 no warnings 'experimental::lexical_subs'; 524b8851fccSafresh1 my sub x; \&x = [] }; 525b8851fccSafresh1like $@, qr/^Assigned value is not a CODE reference at/, 526b8851fccSafresh1 'assigning non-code ref to lexical code ref'; 527b8851fccSafresh1eval { \&::x = [] }; 528b8851fccSafresh1like $@, qr/^Assigned value is not a CODE reference at/, 529b8851fccSafresh1 'assigning non-code ref to package code ref'; 530b8851fccSafresh1 531b8851fccSafresh1eval { my $x; (\$x) = 3 }; 532b8851fccSafresh1like $@, qr/^Assigned value is not a reference at/, 533b8851fccSafresh1 'list-assigning non-ref'; 534b8851fccSafresh1eval { my $x; (\$x) = [] }; 535b8851fccSafresh1like $@, qr/^Assigned value is not a SCALAR reference at/, 536b8851fccSafresh1 'list-assigning non-scalar ref to scalar ref'; 537b8851fccSafresh1eval { (\$::x = []) }; 538b8851fccSafresh1like $@, qr/^Assigned value is not a SCALAR reference at/, 539b8851fccSafresh1 'list-assigning non-scalar ref to package scalar ref'; 540b8851fccSafresh1eval { my @x; (\@x) = {} }; 541b8851fccSafresh1like $@, qr/^Assigned value is not an ARRAY reference at/, 542b8851fccSafresh1 'list-assigning non-array ref to array ref'; 543b8851fccSafresh1eval { (\@::x) = {} }; 544b8851fccSafresh1like $@, qr/^Assigned value is not an ARRAY reference at/, 545b8851fccSafresh1 'list-assigning non-array ref to package array ref'; 546b8851fccSafresh1eval { my %x; (\%x) = [] }; 547b8851fccSafresh1like $@, qr/^Assigned value is not a HASH reference at/, 548b8851fccSafresh1 'list-assigning non-hash ref to hash ref'; 549b8851fccSafresh1eval { (\%::x) = [] }; 550b8851fccSafresh1like $@, qr/^Assigned value is not a HASH reference at/, 551b8851fccSafresh1 'list-assigning non-hash ref to package hash ref'; 552b8851fccSafresh1eval { use feature 'lexical_subs'; 553b8851fccSafresh1 no warnings 'experimental::lexical_subs'; 554b8851fccSafresh1 my sub x; (\&x) = [] }; 555b8851fccSafresh1like $@, qr/^Assigned value is not a CODE reference at/, 556b8851fccSafresh1 'list-assigning non-code ref to lexical code ref'; 557b8851fccSafresh1eval { (\&::x) = [] }; 558b8851fccSafresh1like $@, qr/^Assigned value is not a CODE reference at/, 559b8851fccSafresh1 'list-assigning non-code ref to package code ref'; 560b8851fccSafresh1 561b8851fccSafresh1eval '(\do{}) = 42'; 562b8851fccSafresh1like $@, qr/^Can't modify reference to do block in list assignment at /, 563b8851fccSafresh1 "Can't modify reference to do block in list assignment"; 564b8851fccSafresh1eval '(\pos) = 42'; 565b8851fccSafresh1like $@, 566b8851fccSafresh1 qr/^Can't modify reference to match position in list assignment at /, 567b8851fccSafresh1 "Can't modify ref to some scalar-returning op in list assignment"; 568b8851fccSafresh1eval '(\glob) = 42'; 569b8851fccSafresh1like $@, 570b8851fccSafresh1 qr/^Can't modify reference to glob in list assignment at /, 571b8851fccSafresh1 "Can't modify reference to some list-returning op in list assignment"; 572b8851fccSafresh1eval '\pos = 42'; 573b8851fccSafresh1like $@, 574b8851fccSafresh1 qr/^Can't modify reference to match position in scalar assignment at /, 575b8851fccSafresh1 "Can't modify ref to some scalar-returning op in scalar assignment"; 576b8851fccSafresh1eval '\(local @b) = 42'; 577b8851fccSafresh1like $@, 578b8851fccSafresh1 qr/^Can't modify reference to localized parenthesized array in list(?x: 579b8851fccSafresh1 ) assignment at /, 580b8851fccSafresh1 q"Can't modify \(local @array) in list assignment"; 581b8851fccSafresh1eval '\local(@b) = 42'; 582b8851fccSafresh1like $@, 583b8851fccSafresh1 qr/^Can't modify reference to localized parenthesized array in list(?x: 584b8851fccSafresh1 ) assignment at /, 585b8851fccSafresh1 q"Can't modify \local(@array) in list assignment"; 586b8851fccSafresh1eval '\local(@{foo()}) = 42'; 587b8851fccSafresh1like $@, 588b8851fccSafresh1 qr/^Can't modify reference to array dereference in list assignment at/, 589b8851fccSafresh1 q"'Array deref' error takes prec. over 'local paren' error"; 590b8851fccSafresh1eval '\(%b) = 42'; 591b8851fccSafresh1like $@, 592b8851fccSafresh1 qr/^Can't modify reference to parenthesized hash in list assignment a/, 593b8851fccSafresh1 "Can't modify ref to parenthesized package hash in scalar assignment"; 594b8851fccSafresh1eval '\(my %b) = 42'; 595b8851fccSafresh1like $@, 596b8851fccSafresh1 qr/^Can't modify reference to parenthesized hash in list assignment a/, 597b8851fccSafresh1 "Can't modify ref to parenthesized hash (\(my %b)) in list assignment"; 598b8851fccSafresh1eval '\my(%b) = 42'; 599b8851fccSafresh1like $@, 600b8851fccSafresh1 qr/^Can't modify reference to parenthesized hash in list assignment a/, 601b8851fccSafresh1 "Can't modify ref to parenthesized hash (\my(%b)) in list assignment"; 602b8851fccSafresh1eval '\%{"42"} = 42'; 603b8851fccSafresh1like $@, 604b8851fccSafresh1 qr/^Can't modify reference to hash dereference in scalar assignment a/, 605b8851fccSafresh1 "Can't modify reference to hash dereference in scalar assignment"; 606b8851fccSafresh1eval '$foo ? \%{"42"} : \%43 = 42'; 607b8851fccSafresh1like $@, 608b8851fccSafresh1 qr/^Can't modify reference to hash dereference in scalar assignment a/, 609b8851fccSafresh1 "Can't modify ref to whatever in scalar assignment via cond expr"; 6105759b3d2Safresh1eval '\$0=~y///=0'; 6115759b3d2Safresh1like $@, 6125759b3d2Safresh1 qr#^Can't modify transliteration \(tr///\) in scalar assignment a#, 6135759b3d2Safresh1 "Can't modify transliteration (tr///) in scalar assignment"; 614b8851fccSafresh1 615b8851fccSafresh1# Miscellaneous 616b8851fccSafresh1 617b8851fccSafresh1{ 618b8851fccSafresh1 local $::TODO = ' '; 619b8851fccSafresh1 my($x,$y); 620b8851fccSafresh1 sub { 621b8851fccSafresh1 sub { 622b8851fccSafresh1 \$x = \$y; 623b8851fccSafresh1 }->(); 624b8851fccSafresh1 is \$x, \$y, 'lexical alias affects outer closure'; 625b8851fccSafresh1 }->(); 626b8851fccSafresh1 is \$x, \$y, 'lexical alias affects outer sub where vars are declared'; 627b8851fccSafresh1} 628b8851fccSafresh1 629b8851fccSafresh1{ # PADSTALE has a double meaning 630b8851fccSafresh1 use feature 'lexical_subs', 'signatures'; 631b8851fccSafresh1 no warnings 'experimental'; 632b8851fccSafresh1 my $c; 633b8851fccSafresh1 my sub s ($arg) { 634b8851fccSafresh1 state $x = ++$c; 635b8851fccSafresh1 if ($arg == 3) { return $c } 636b8851fccSafresh1 goto skip if $arg == 2; 637b8851fccSafresh1 my $y; 638b8851fccSafresh1 skip: 639b8851fccSafresh1 # $y is PADSTALE the 2nd time 640b8851fccSafresh1 \$x = \$y if $arg == 2; 641b8851fccSafresh1 } 642b8851fccSafresh1 s(1); 643b8851fccSafresh1 s(2); 644b8851fccSafresh1 is s(3), 1, 'padstale alias should not reset state' 645b8851fccSafresh1} 646b8851fccSafresh1 647eac174f2Safresh1{ 648b8851fccSafresh1 my $a; 649eac174f2Safresh1 no warnings 'experimental::builtin'; 650eac174f2Safresh1 builtin::weaken($r = \$a); 651b8851fccSafresh1 \$a = $r; 652b8851fccSafresh1 pass 'no crash when assigning \$lex = $weakref_to_lex' 653b8851fccSafresh1} 654b8851fccSafresh1 655b8851fccSafresh1{ 656b8851fccSafresh1 \my $x = \my $y; 657b8851fccSafresh1 $x = 3; 658b8851fccSafresh1 ($x, my $z) = (1, $y); 659b8851fccSafresh1 is $z, 3, 'list assignment after aliasing lexical scalars'; 660b8851fccSafresh1} 661b8851fccSafresh1{ 662b8851fccSafresh1 (\my $x) = \my $y; 663b8851fccSafresh1 $x = 3; 664b8851fccSafresh1 ($x, my $z) = (1, $y); 665b8851fccSafresh1 is $z, 3, 666b8851fccSafresh1 'regular list assignment after aliasing via list assignment'; 667b8851fccSafresh1} 668b8851fccSafresh1{ 669b8851fccSafresh1 my $y; 670b8851fccSafresh1 goto do_aliasing; 671b8851fccSafresh1 672b8851fccSafresh1 do_test: 673b8851fccSafresh1 $y = 3; 674b8851fccSafresh1 my($x,$z) = (1, $y); 675b8851fccSafresh1 is $z, 3, 'list assignment "before" aliasing lexical scalars'; 676b8851fccSafresh1 last; 677b8851fccSafresh1 678b8851fccSafresh1 do_aliasing: 679b8851fccSafresh1 \$x = \$y; 680b8851fccSafresh1 goto do_test; 681b8851fccSafresh1} 682b8851fccSafresh1{ 683b8851fccSafresh1 my $y; 684b8851fccSafresh1 goto do_aliasing2; 685b8851fccSafresh1 686b8851fccSafresh1 do_test2: 687b8851fccSafresh1 $y = 3; 688b8851fccSafresh1 my($x,$z) = (1, $y); 689b8851fccSafresh1 is $z, 3, 690b8851fccSafresh1 'list assignment "before" aliasing lex scalars via list assignment'; 691b8851fccSafresh1 last; 692b8851fccSafresh1 693b8851fccSafresh1 do_aliasing2: 694b8851fccSafresh1 \($x) = \$y; 695b8851fccSafresh1 goto do_test2; 696b8851fccSafresh1} 697b8851fccSafresh1{ 698b8851fccSafresh1 my @a; 699b8851fccSafresh1 goto do_aliasing3; 700b8851fccSafresh1 701b8851fccSafresh1 do_test3: 702b8851fccSafresh1 @a[0,1] = qw<a b>; 703b8851fccSafresh1 my($y,$x) = ($a[0],$a[1]); 704b8851fccSafresh1 is "@a", 'b a', 705b8851fccSafresh1 'aelemfast_lex-to-scalar list assignment "before" aliasing'; 706b8851fccSafresh1 last; 707b8851fccSafresh1 708b8851fccSafresh1 do_aliasing3: 709b8851fccSafresh1 \(@a) = \($x,$y); 710b8851fccSafresh1 goto do_test3; 711b8851fccSafresh1} 712b8851fccSafresh1 713b8851fccSafresh1# Used to fail an assertion [perl #123821] 714b8851fccSafresh1eval '\(&$0)=0'; 7155759b3d2Safresh1pass("RT #123821"); 7165759b3d2Safresh1 7175759b3d2Safresh1# Used to fail an assertion [perl #128252] 7185759b3d2Safresh1{ 7195759b3d2Safresh1 no feature 'refaliasing'; 7205759b3d2Safresh1 use warnings; 7215759b3d2Safresh1 eval q{sub{\@0[0]=0};}; 7225759b3d2Safresh1 pass("RT #128252"); 7235759b3d2Safresh1} 724b46d8ef2Safresh1 725b46d8ef2Safresh1# RT #133538 slices were inadvertently always localising 726b46d8ef2Safresh1 727b46d8ef2Safresh1{ 728b46d8ef2Safresh1 use feature 'refaliasing'; 729b46d8ef2Safresh1 no warnings 'experimental'; 730b46d8ef2Safresh1 731b46d8ef2Safresh1 my @src = (100,200,300); 732b46d8ef2Safresh1 733b46d8ef2Safresh1 my @a = (1,2,3); 734b46d8ef2Safresh1 my %h = qw(one 10 two 20 three 30); 735b46d8ef2Safresh1 736b46d8ef2Safresh1 { 737b46d8ef2Safresh1 use feature 'declared_refs'; 738b46d8ef2Safresh1 local \(@a[0,1,2]) = \(@src); 739b46d8ef2Safresh1 local \(@h{qw(one two three)}) = \(@src); 740b46d8ef2Safresh1 $src[0]++; 741b46d8ef2Safresh1 is("@a", "101 200 300", "rt #133538 \@a aliased"); 742b46d8ef2Safresh1 is("$h{one} $h{two} $h{three}", "101 200 300", "rt #133538 %h aliased"); 743b46d8ef2Safresh1 } 744b46d8ef2Safresh1 is("@a", "1 2 3", "rt #133538 \@a restored"); 745b46d8ef2Safresh1 is("$h{one} $h{two} $h{three}", "10 20 30", "rt #133538 %h restored"); 746b46d8ef2Safresh1 747b46d8ef2Safresh1 { 748b46d8ef2Safresh1 \(@a[0,1,2]) = \(@src); 749b46d8ef2Safresh1 \(@h{qw(one two three)}) = \(@src); 750b46d8ef2Safresh1 $src[0]++; 751b46d8ef2Safresh1 is("@a", "102 200 300", "rt #133538 \@a aliased try 2"); 752b46d8ef2Safresh1 is("$h{one} $h{two} $h{three}", "102 200 300", 753b46d8ef2Safresh1 "rt #133538 %h aliased try 2"); 754b46d8ef2Safresh1 } 755b46d8ef2Safresh1 $src[2]++; 756b46d8ef2Safresh1 is("@a", "102 200 301", "rt #133538 \@a still aliased"); 757b46d8ef2Safresh1 is("$h{one} $h{two} $h{three}", "102 200 301", "rt #133538 %h still aliased"); 758b46d8ef2Safresh1 759b46d8ef2Safresh1} 760