t/op/lvref.t

   1 BEGIN {
   2     chdir 't';
   3     require './test.pl';
   4     set_up_inc("../lib");
   5 }
   6
   7 plan 153;
   8
   9 eval '\$x = \$y';
  10 like $@, qr/^Experimental aliasing via reference not enabled/,
  11     'error when feature is disabled';
  12 eval '\($x) = \$y';
  13 like $@, qr/^Experimental aliasing via reference not enabled/,
  14     'error when feature is disabled (aassign)';
  15
  16 use feature 'refaliasing', 'state';
  17
  18 {
  19     my($w,$c);
  20     local $SIG{__WARN__} = sub { $c++; $w = shift };
  21     eval '\$x = \$y';
  22     is $c, 1, 'one warning from lv ref assignment';
  23     like $w, qr/^Aliasing via reference is experimental/,
  24         'experimental warning';
  25     undef $c;
  26     eval '\($x) = \$y';
  27     is $c, 1, 'one warning from lv ref list assignment';
  28     like $w, qr/^Aliasing via reference is experimental/,
  29         'experimental warning';
  30 }
  31
  32 no warnings 'experimental::refaliasing';
  33
  34 # Scalars
  35
  36 \$x = \$y;
  37 is \$x, \$y, '\$pkg_scalar = ...';
  38 my $m;
  39 \$m = \$y;
  40 is \$m, \$y, '\$lexical = ...';
  41 \my $n = \$y;
  42 is \$n, \$y, '\my $lexical = ...';
  43 @_ = \$_;
  44 \($x) = @_;
  45 is \$x, \$_, '\($pkgvar) = ... gives list context';
  46 undef *x;
  47 (\$x) = @_;
  48 is \$x, \$_, '(\$pkgvar) = ... gives list context';
  49 my $o;
  50 \($o) = @_;
  51 is \$o, \$_, '\($lexical) = ... gives list cx';
  52 my $q;
  53 (\$q) = @_;
  54 is \$q, \$_, '(\$lexical) = ... gives list cx';
  55 \(my $p) = @_;
  56 is \$p, \$_, '\(my $lexical) = ... gives list cx';
  57 (\my $r) = @_;
  58 is \$r, \$_, '(\my $lexical) = ... gives list cx';
  59 \my($s) = @_;
  60 is \$s, \$_, '\my($lexical) = ... gives list cx';
  61 \($_a, my $a) = @{[\$b, \$c]};
  62 is \$_a, \$b, 'package scalar in \(...)';
  63 is \$a, \$c, 'lex scalar in \(...)';
  64 (\$_b, \my $b) = @{[\$b, \$c]};
  65 is \$_b, \$::b, 'package scalar in (\$foo, \$bar)';
  66 is \$b, \$c, 'lex scalar in (\$foo, \$bar)';
  67 is do { \local $l = \3; $l }, 3, '\local $scalar assignment';
  68 is $l, undef, 'localisation unwound';
  69 is do { \(local $l) = \4; $l }, 4, '\(local $scalar) assignment';
  70 is $l, undef, 'localisation unwound';
  71 \$foo = \*bar;
  72 is *foo{SCALAR}, *bar{GLOB}, 'globref-to-scalarref assignment';
  73 for (1,2) {
  74   \my $x = \3,
  75   \my($y) = \3,
  76   \state $a = \3,
  77   \state($b) = \3 if $_ == 1;
  78   if ($_ == 2) {
  79     is $x, undef, '\my $x = ... clears $x on scope exit';
  80     is $y, undef, '\my($x) = ... clears $x on scope exit';
  81     is $a, 3, '\state $x = ... does not clear $x on scope exit';
  82     is $b, 3, '\state($x) = ... does not clear $x on scope exit';
  83   }
  84 }
  85
  86 # Array Elements
  87
  88 sub expect_scalar_cx { wantarray ? 0 : \$_ }
  89 sub expect_list_cx { wantarray ? (\$_,\$_) : 0 }
  90 \$a[0] = expect_scalar_cx;
  91 is \$a[0], \$_, '\$array[0]';
  92 \($a[1]) = expect_list_cx;
  93 is \$a[1], \$_, '\($array[0])';
  94 {
  95   my @a;
  96   \$a[0] = expect_scalar_cx;
  97   is \$a[0], \$_, '\$lexical_array[0]';
  98   \($a[1]) = expect_list_cx;
  99   is \$a[1], \$_, '\($lexical_array[0])';
 100   my $tmp;
 101   {
 102     \local $a[0] = \$tmp;
 103     is \$a[0], \$tmp, '\local $a[0]';
 104   }
 105   is \$a[0], \$_, '\local $a[0] unwound';
 106   {
 107     \local ($a[1]) = \$tmp;
 108     is \$a[1], \$tmp, '\local ($a[0])';
 109   }
 110   is \$a[1], \$_, '\local $a[0] unwound';
 111 }
 112 {
 113   my @a;
 114   \@a[0,1] = expect_list_cx;
 115   is \$a[0].\$a[1], \$_.\$_, '\@array[indices]';
 116   \(@a[2,3]) = expect_list_cx;
 117   is \$a[0].\$a[1], \$_.\$_, '\(@array[indices])';
 118   my $tmp;
 119   {
 120     \local @a[0,1] = (\$tmp)x2;
 121     is \$a[0].\$a[1], \$tmp.\$tmp, '\local @a[indices]';
 122   }
 123   is \$a[0].\$a[1], \$_.\$_, '\local @a[indices] unwound';
 124 }
 125
 126 # Hash Elements
 127
 128 \$h{a} = expect_scalar_cx;
 129 is \$h{a}, \$_, '\$hash{a}';
 130 \($h{b}) = expect_list_cx;
 131 is \$h{b}, \$_, '\($hash{a})';
 132 {
 133   my %h;
 134   \$h{a} = expect_scalar_cx;
 135   is \$h{a}, \$_, '\$lexical_array{a}';
 136   \($h{b}) = expect_list_cx;
 137   is \$h{b}, \$_, '\($lexical_array{a})';
 138   my $tmp;
 139   {
 140     \local $h{a} = \$tmp;
 141     is \$h{a}, \$tmp, '\local $h{a}';
 142   }
 143   is \$h{a}, \$_, '\local $h{a} unwound';
 144   {
 145     \local ($h{b}) = \$tmp;
 146     is \$h{b}, \$tmp, '\local ($h{a})';
 147   }
 148   is \$h{b}, \$_, '\local $h{a} unwound';
 149 }
 150 {
 151   my %h;
 152   \@h{"a","b"} = expect_list_cx;
 153   is \$h{a}.\$h{b}, \$_.\$_, '\@hash{indices}';
 154   \(@h{2,3}) = expect_list_cx;
 155   is \$h{a}.\$h{b}, \$_.\$_, '\(@hash{indices})';
 156   my $tmp;
 157   {
 158     \local @h{"a","b"} = (\$tmp)x2;
 159     is \$h{a}.\$h{b}, \$tmp.\$tmp, '\local @h{indices}';
 160   }
 161   is \$h{a}.\$h{b}, \$_.\$_, '\local @h{indices} unwound';
 162 }
 163
 164 # Arrays
 165
 166 package ArrayTest {
 167   BEGIN { *is = *main::is }
 168   sub expect_scalar_cx { wantarray ? 0 : \@ThatArray }
 169   sub expect_list_cx   { wantarray ? (\$_,\$_) : 0 }
 170   sub expect_list_cx_a { wantarray ? (\@ThatArray)x2 : 0 }
 171   \@a = expect_scalar_cx;
 172   is \@a, \@ThatArray, '\@pkg';
 173   my @a;
 174   \@a = expect_scalar_cx;
 175   is \@a, \@ThatArray, '\@lexical';
 176   (\@b) = expect_list_cx_a;
 177   is \@b, \@ThatArray, '(\@pkg)';
 178   my @b;
 179   (\@b) = expect_list_cx_a;
 180   is \@b, \@ThatArray, '(\@lexical)';
 181   \my @c = expect_scalar_cx;
 182   is \@c, \@ThatArray, '\my @lexical';
 183   (\my @d) = expect_list_cx_a;
 184   is \@d, \@ThatArray, '(\my @lexical)';
 185   \(@e) = expect_list_cx;
 186   is \$e[0].\$e[1], \$_.\$_, '\(@pkg)';
 187   my @e;
 188   \(@e) = expect_list_cx;
 189   is \$e[0].\$e[1], \$_.\$_, '\(@lexical)';
 190   \(my @f) = expect_list_cx;
 191   is \$f[0].\$f[1], \$_.\$_, '\(my @lexical)';
 192   \my(@g) = expect_list_cx;
 193   is \$g[0].\$g[1], \$_.\$_, '\my(@lexical)';
 194   my $old = \@h;
 195   {
 196     \local @h = \@ThatArray;
 197     is \@h, \@ThatArray, '\local @a';
 198   }
 199   is \@h, $old, '\local @a unwound';
 200   $old = \@i;
 201   {
 202     (\local @i) = \@ThatArray;
 203     is \@i, \@ThatArray, '(\local @a)';
 204   }
 205   is \@i, $old, '(\local @a) unwound';
 206 }
 207 for (1,2) {
 208   \my @x = [1..3],
 209   \my(@y) = \3,
 210   \state @a = [1..3],
 211   \state(@b) = \3 if $_ == 1;
 212   if ($_ == 2) {
 213     is @x, 0, '\my @x = ... clears @x on scope exit';
 214     is @y, 0, '\my(@x) = ... clears @x on scope exit';
 215     is "@a", "1 2 3", '\state @x = ... does not clear @x on scope exit';
 216     is "@b", 3, '\state(@x) = ... does not clear @x on scope exit';
 217   }
 218 }
 219
 220 # Hashes
 221
 222 package HashTest {
 223   BEGIN { *is = *main::is }
 224   sub expect_scalar_cx { wantarray ? 0 : \%ThatHash }
 225   sub expect_list_cx   { wantarray ? (\%ThatHash)x2 : 0 }
 226   \%a = expect_scalar_cx;
 227   is \%a, \%ThatHash, '\%pkg';
 228   my %a;
 229   \%a = expect_scalar_cx;
 230   is \%a, \%ThatHash, '\%lexical';
 231   (\%b) = expect_list_cx;
 232   is \%b, \%ThatHash, '(\%pkg)';
 233   my %b;
 234   (\%b) = expect_list_cx;
 235   is \%b, \%ThatHash, '(\%lexical)';
 236   \my %c = expect_scalar_cx;
 237   is \%c, \%ThatHash, '\my %lexical';
 238   (\my %d) = expect_list_cx;
 239   is \%d, \%ThatHash, '(\my %lexical)';
 240   my $old = \%h;
 241   {
 242     \local %h = \%ThatHash;
 243     is \%h, \%ThatHash, '\local %a';
 244   }
 245   is \%h, $old, '\local %a unwound';
 246   $old = \%i;
 247   {
 248     (\local %i) = \%ThatHash;
 249     is \%i, \%ThatHash, '(\local %a)';
 250   }
 251   is \%i, $old, '(\local %a) unwound';
 252 }
 253 for (1,2) {
 254   \state %y = {1,2},
 255   \my %x = {1,2} if $_ == 1;
 256   if ($_ == 2) {
 257     is %x, 0, '\my %x = ... clears %x on scope exit';
 258     is "@{[%y]}", "1 2", '\state %x = ... does not clear %x on scope exit';
 259   }
 260 }
 261
 262 # Subroutines
 263
 264 package CodeTest {
 265   BEGIN { *is = *main::is; }
 266   use feature 'lexical_subs';
 267   no warnings 'experimental::lexical_subs';
 268   sub expect_scalar_cx { wantarray ? 0 : \&ThatSub }
 269   sub expect_list_cx   { wantarray ? (\&ThatSub)x2 : 0 }
 270   \&a = expect_scalar_cx;
 271   is \&a, \&ThatSub, '\&pkg';
 272   my sub a;
 273   \&a = expect_scalar_cx;
 274   is \&a, \&ThatSub, '\&mysub';
 275   state sub as;
 276   \&as = expect_scalar_cx;
 277   is \&as, \&ThatSub, '\&statesub';
 278   (\&b) = expect_list_cx;
 279   is \&b, \&ThatSub, '(\&pkg)';
 280   my sub b;
 281   (\&b) = expect_list_cx;
 282   is \&b, \&ThatSub, '(\&mysub)';
 283   my sub bs;
 284   (\&bs) = expect_list_cx;
 285   is \&bs, \&ThatSub, '(\&statesub)';
 286   \(&c) = expect_list_cx;
 287   is \&c, \&ThatSub, '\(&pkg)';
 288   my sub b;
 289   \(&c) = expect_list_cx;
 290   is \&c, \&ThatSub, '\(&mysub)';
 291   my sub bs;
 292   \(&cs) = expect_list_cx;
 293   is \&cs, \&ThatSub, '\(&statesub)';
 294 }
 295
 296 # Mixed List Assignments
 297
 298 (\$tahi, $rua) = \(1,2);
 299 is join(' ', $tahi, $$rua), '1 2',
 300   'mixed scalar ref and scalar list assignment';
 301 $_ = 1;
 302 \($bb, @cc, %dd, &ee, $_==1 ? $ff : @ff, $_==2 ? $gg : @gg, (@hh)) =
 303     (\$BB, \@CC, \%DD, \&EE, \$FF, \@GG, \1, \2, \3);
 304 is \$bb, \$BB, '\$scalar in list assignment';
 305 is \@cc, \@CC, '\@array in list assignment';
 306 is \%dd, \%DD, '\%hash in list assignment';
 307 is \&ee, \&EE, '\&code in list assignment';
 308 is \$ff, \$FF, '$scalar in \ternary in list assignment';
 309 is \@gg, \@GG, '@gg in \ternary in list assignment';
 310 is "@hh", '1 2 3', '\(@array) in list assignment';
 311
 312 # Conditional expressions
 313
 314 $_ = 3;
 315 $_ == 3 ? \$tahi : $rua = \3;
 316 is $tahi, 3, 'cond assignment resolving to scalar ref';
 317 $_ == 0 ? \$toru : $wha = \3;
 318 is $$wha, 3, 'cond assignment resolving to scalar';
 319 $_ == 3 ? \$rima : \$ono = \5;
 320 is $rima, 5, 'cond assignment with refgens on both branches';
 321 \($_ == 3 ? $whitu : $waru) = \5;
 322 is $whitu, 5, '\( ?: ) assignment';
 323 \($_ == 3 ? $_ < 4 ? $ii : $_ : $_) = \$_;
 324 is \$ii, \$_, 'nested \ternary assignment';
 325
 326 # Foreach
 327
 328 for \my $topic (\$for1, \$for2) {
 329     push @for, \$topic;
 330 }
 331 is "@for", \$for1 . ' ' . \$for2, 'foreach \my $a';
 332 is \$topic, \$::topic, 'for \my scoping';
 333
 334 @for = ();
 335 for \$::a(\$for1, \$for2) {
 336     push @for, \$::a;
 337 }
 338 is "@for", \$for1 . ' ' . \$for2, 'foreach \$::a';
 339
 340 @for = ();
 341 for \my @a([1,2], [3,4]) {
 342     push @for, @a;
 343 }
 344 is "@for", "1 2 3 4", 'foreach \my @a [perl #22335]';
 345
 346 @for = ();
 347 for \@::a([1,2], [3,4]) {
 348     push @for, @::a;
 349 }
 350 is "@for", "1 2 3 4", 'foreach \@::a [perl #22335]';
 351
 352 @for = ();
 353 for \my %a({5,6}, {7,8}) {
 354     push @for, %a;
 355 }
 356 is "@for", "5 6 7 8", 'foreach \my %a [perl #22335]';
 357
 358 @for = ();
 359 for \%::a({5,6}, {7,8}) {
 360     push @for, %::a;
 361 }
 362 is "@for", "5 6 7 8", 'foreach \%::a [perl #22335]';
 363
 364 @for = ();
 365 {
 366   use feature 'lexical_subs';
 367   no warnings 'experimental::lexical_subs';
 368   my sub a;
 369   for \&a(sub {9}, sub {10}) {
 370     push @for, &a;
 371   }
 372 }
 373 is "@for", "9 10", 'foreach \&padcv';
 374
 375 @for = ();
 376 for \&::a(sub {9}, sub {10}) {
 377   push @for, &::a;
 378 }
 379 is "@for", "9 10", 'foreach \&rv2cv';
 380
 381 # Errors
 382
 383 eval { my $x; \$x = 3 };
 384 like $@, qr/^Assigned value is not a reference at/, 'assigning non-ref';
 385 eval { my $x; \$x = [] };
 386 like $@, qr/^Assigned value is not a SCALAR reference at/,
 387     'assigning non-scalar ref to scalar ref';
 388 eval { \$::x = [] };
 389 like $@, qr/^Assigned value is not a SCALAR reference at/,
 390     'assigning non-scalar ref to package scalar ref';
 391 eval { my @x; \@x = {} };
 392 like $@, qr/^Assigned value is not an ARRAY reference at/,
 393     'assigning non-array ref to array ref';
 394 eval { \@::x = {} };
 395 like $@, qr/^Assigned value is not an ARRAY reference at/,
 396     'assigning non-array ref to package array ref';
 397 eval { my %x; \%x = [] };
 398 like $@, qr/^Assigned value is not a HASH reference at/,
 399     'assigning non-hash ref to hash ref';
 400 eval { \%::x = [] };
 401 like $@, qr/^Assigned value is not a HASH reference at/,
 402     'assigning non-hash ref to package hash ref';
 403 eval { use feature 'lexical_subs';
 404        no warnings 'experimental::lexical_subs';
 405        my sub x; \&x = [] };
 406 like $@, qr/^Assigned value is not a CODE reference at/,
 407     'assigning non-code ref to lexical code ref';
 408 eval { \&::x = [] };
 409 like $@, qr/^Assigned value is not a CODE reference at/,
 410     'assigning non-code ref to package code ref';
 411
 412 eval { my $x; (\$x) = 3 };
 413 like $@, qr/^Assigned value is not a reference at/,
 414     'list-assigning non-ref';
 415 eval { my $x; (\$x) = [] };
 416 like $@, qr/^Assigned value is not a SCALAR reference at/,
 417     'list-assigning non-scalar ref to scalar ref';
 418 eval { (\$::x = []) };
 419 like $@, qr/^Assigned value is not a SCALAR reference at/,
 420     'list-assigning non-scalar ref to package scalar ref';
 421 eval { my @x; (\@x) = {} };
 422 like $@, qr/^Assigned value is not an ARRAY reference at/,
 423     'list-assigning non-array ref to array ref';
 424 eval { (\@::x) = {} };
 425 like $@, qr/^Assigned value is not an ARRAY reference at/,
 426     'list-assigning non-array ref to package array ref';
 427 eval { my %x; (\%x) = [] };
 428 like $@, qr/^Assigned value is not a HASH reference at/,
 429     'list-assigning non-hash ref to hash ref';
 430 eval { (\%::x) = [] };
 431 like $@, qr/^Assigned value is not a HASH reference at/,
 432     'list-assigning non-hash ref to package hash ref';
 433 eval { use feature 'lexical_subs';
 434        no warnings 'experimental::lexical_subs';
 435        my sub x; (\&x) = [] };
 436 like $@, qr/^Assigned value is not a CODE reference at/,
 437     'list-assigning non-code ref to lexical code ref';
 438 eval { (\&::x) = [] };
 439 like $@, qr/^Assigned value is not a CODE reference at/,
 440     'list-assigning non-code ref to package code ref';
 441
 442 eval '(\do{}) = 42';
 443 like $@, qr/^Can't modify reference to do block in list assignment at /,
 444     "Can't modify reference to do block in list assignment";
 445 eval '(\pos) = 42';
 446 like $@,
 447      qr/^Can't modify reference to match position in list assignment at /,
 448     "Can't modify ref to some scalar-returning op in list assignment";
 449 eval '(\glob) = 42';
 450 like $@,
 451      qr/^Can't modify reference to glob in list assignment at /,
 452     "Can't modify reference to some list-returning op in list assignment";
 453 eval '\pos = 42';
 454 like $@,
 455     qr/^Can't modify reference to match position in scalar assignment at /,
 456    "Can't modify ref to some scalar-returning op in scalar assignment";
 457 eval '\(local @b) = 42';
 458 like $@,
 459     qr/^Can't modify reference to localized parenthesized array in list(?x:
 460       ) assignment at /,
 461    q"Can't modify \(local @array) in list assignment";
 462 eval '\local(@b) = 42';
 463 like $@,
 464     qr/^Can't modify reference to localized parenthesized array in list(?x:
 465       ) assignment at /,
 466    q"Can't modify \local(@array) in list assignment";
 467 eval '\local(@{foo()}) = 42';
 468 like $@,
 469     qr/^Can't modify reference to array dereference in list assignment at/,
 470    q"'Array deref' error takes prec. over 'local paren' error";
 471 eval '\(%b) = 42';
 472 like $@,
 473     qr/^Can't modify reference to parenthesized hash in list assignment a/,
 474    "Can't modify ref to parenthesized package hash in scalar assignment";
 475 eval '\(my %b) = 42';
 476 like $@,
 477     qr/^Can't modify reference to parenthesized hash in list assignment a/,
 478    "Can't modify ref to parenthesized hash (\(my %b)) in list assignment";
 479 eval '\my(%b) = 42';
 480 like $@,
 481     qr/^Can't modify reference to parenthesized hash in list assignment a/,
 482    "Can't modify ref to parenthesized hash (\my(%b)) in list assignment";
 483 eval '\%{"42"} = 42';
 484 like $@,
 485     qr/^Can't modify reference to hash dereference in scalar assignment a/,
 486    "Can't modify reference to hash dereference in scalar assignment";
 487 eval '$foo ? \%{"42"} : \%43 = 42';
 488 like $@,
 489     qr/^Can't modify reference to hash dereference in scalar assignment a/,
 490    "Can't modify ref to whatever in scalar assignment via cond expr";
 491
 492 # Miscellaneous
 493
 494 {
 495   local $::TODO = ' ';
 496   my($x,$y);
 497   sub {
 498     sub {
 499       \$x = \$y;
 500     }->();
 501     is \$x, \$y, 'lexical alias affects outer closure';
 502   }->();
 503   is \$x, \$y, 'lexical alias affects outer sub where vars are declared';
 504 }
 505
 506 { # PADSTALE has a double meaning
 507   use feature 'lexical_subs', 'signatures';
 508   no warnings 'experimental';
 509   my $c;
 510   my sub s ($arg) {
 511     state $x = ++$c;
 512     if ($arg == 3) { return $c }
 513     goto skip if $arg == 2;
 514     my $y;
 515    skip:
 516     # $y is PADSTALE the 2nd time
 517     \$x = \$y if $arg == 2;
 518   }
 519   s(1);
 520   s(2);
 521   is s(3), 1, 'padstale alias should not reset state'
 522 }
 523
 524 SKIP: {
 525     skip_without_dynamic_extension('List/Util');
 526     require Scalar::Util;
 527     my $a;
 528     Scalar::Util::weaken($r = \$a);
 529     \$a = $r;
 530     pass 'no crash when assigning \$lex = $weakref_to_lex'
 531 }
 532
 533 {
 534     \my $x = \my $y;
 535     $x = 3;
 536     ($x, my $z) = (1, $y);
 537     is $z, 3, 'list assignment after aliasing lexical scalars';
 538 }
 539 {
 540     (\my $x) = \my $y;
 541     $x = 3;
 542     ($x, my $z) = (1, $y);
 543     is $z, 3,
 544       'regular list assignment after aliasing via list assignment';
 545 }
 546 {
 547     my $y;
 548     goto do_aliasing;
 549
 550    do_test:
 551     $y = 3;
 552     my($x,$z) = (1, $y);
 553     is $z, 3, 'list assignment "before" aliasing lexical scalars';
 554     last;
 555
 556    do_aliasing:
 557     \$x = \$y;
 558     goto do_test;
 559 }
 560 {
 561     my $y;
 562     goto do_aliasing2;
 563
 564    do_test2:
 565     $y = 3;
 566     my($x,$z) = (1, $y);
 567     is $z, 3,
 568      'list assignment "before" aliasing lex scalars via list assignment';
 569     last;
 570
 571    do_aliasing2:
 572     \($x) = \$y;
 573     goto do_test2;
 574 }
 575 {
 576     my @a;
 577     goto do_aliasing3;
 578
 579    do_test3:
 580     @a[0,1] = qw<a b>;
 581     my($y,$x) = ($a[0],$a[1]);
 582     is "@a", 'b a',
 583        'aelemfast_lex-to-scalar list assignment "before" aliasing';
 584     last;
 585
 586    do_aliasing3:
 587     \(@a) = \($x,$y);
 588     goto do_test3;
 589 }
 590
 591 # Used to fail an assertion [perl #123821]
 592 eval '\(&$0)=0';