t/op/lvref.t

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