t/op/lvref.t

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