t/op/lvref.t

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