t/op/aassign.t

   1 #!./perl -w
   2
   3 # Some miscellaneous checks for the list assignment operator, OP_AASSIGN.
   4 #
   5 # This file was only added in 2015; before then, such tests were
   6 # typically in various other random places like op/array.t. This test file
   7 # doesn't therefore attempt to be comprehensive; it merely provides a
   8 # central place to new put additional tests, especially those related to
   9 # the trickiness of commonality, e.g. ($a,$b) = ($b,$a).
  10 #
  11 # In particular, it's testing the flags
  12 #    OPpASSIGN_COMMON_SCALAR
  13 #    OPpASSIGN_COMMON_RC1
  14 #    OPpASSIGN_COMMON_AGG
  15
  16 BEGIN {
  17     chdir 't' if -d 't';
  18     @INC = '../lib';
  19     require './test.pl';
  20 }
  21
  22 use warnings;
  23 use strict;
  24
  25 # general purpose package vars
  26
  27 our $pkg_scalar;
  28 our @pkg_array;
  29 our %pkg_hash;
  30
  31 sub f_ret_14 { return 1..4 }
  32
  33 # stringify a hash ref
  34
  35 sub sh {
  36     my $rh = $_[0];
  37     join ',', map "$_:$rh->{$_}", sort keys %$rh;
  38 }
  39
  40
  41 # where the RHS has surplus elements
  42
  43 {
  44     my ($a,$b);
  45     ($a,$b) = f_ret_14();
  46     is("$a:$b", "1:2", "surplus");
  47 }
  48
  49 # common with slices
  50
  51 {
  52     my @a = (1,2);
  53     @a[0,1] = @a[1,0];
  54     is("$a[0]:$a[1]", "2:1", "lex array slice");
  55 }
  56
  57 # package alias
  58
  59 {
  60     my ($a, $b) = 1..2;
  61     for $pkg_scalar ($a) {
  62         ($pkg_scalar, $b) = (3, $a);
  63         is($pkg_scalar, 3, "package alias pkg");
  64         is("$a:$b", "3:1", "package alias a:b");
  65     }
  66 }
  67
  68 # my array/hash populated via closure
  69
  70 {
  71     my $ra = f1();
  72     my ($x, @a) = @$ra;
  73     sub f1 { $x = 1; @a = 2..4; \@a }
  74     is($x,       2, "my: array closure x");
  75     is("@a", "3 4", "my: array closure a");
  76
  77     my $rh = f2();
  78     my ($k, $v, %h) = (d => 4, %$rh, e => 6);
  79     sub f2 { $k = 'a'; $v = 1; %h = qw(b 2 c 3); \%h }
  80     is("$k:$v", "d:4", "my: hash closure k:v");
  81     is(sh(\%h), "b:2,c:3,e:6", "my: hash closure h");
  82 }
  83
  84
  85 # various shared element scenarios within a my (...)
  86
  87 {
  88     my ($x,$y) = f3(); # $x and $y on both sides
  89     sub f3 : lvalue { ($x,$y) = (1,2); $y, $x }
  90     is ("$x:$y", "2:1", "my: scalar and lvalue sub");
  91 }
  92
  93 {
  94     my $ra = f4();
  95     my @a = @$ra;  # elements of @a on both sides
  96     sub f4 { @a = 1..4; \@a }
  97     is("@a", "1 2 3 4", "my: array and elements");
  98 }
  99
 100 {
 101     my $rh = f5();
 102     my %h = %$rh;  # elements of %h on both sides
 103     sub f5 { %h = qw(a 1 b 2 c 3); \%h }
 104     is(sh(\%h), "a:1,b:2,c:3", "my: hash and elements");
 105 }
 106
 107 {
 108     f6();
 109     our $xalias6;
 110     my ($x, $y) = (2, $xalias6);
 111     sub f6 { $x = 1; *xalias6 = \$x; }
 112     is ("$x:$y", "2:1", "my: pkg var aliased to lexical");
 113 }
 114
 115
 116 {
 117     my @a;
 118     f7();
 119     my ($x,$y) = @a;
 120     is ("$x:$y", "2:1", "my: lex array elements aliased");
 121
 122     sub f7 {
 123         ($x, $y) = (1,2);
 124         use feature 'refaliasing';
 125         no warnings 'experimental';
 126         \($a[0], $a[1]) = \($y,$x);
 127     }
 128 }
 129
 130 {
 131     @pkg_array = ();
 132     f8();
 133     my ($x,$y) = @pkg_array;
 134     is ("$x:$y", "2:1", "my: pkg array elements aliased");
 135
 136     sub f8 {
 137         ($x, $y) = (1,2);
 138         use feature 'refaliasing';
 139         no warnings 'experimental';
 140         \($pkg_array[0], $pkg_array[1]) = \($y,$x);
 141     }
 142 }
 143
 144 {
 145     f9();
 146     my ($x,$y) = f9();
 147     is ("$x:$y", "2:1", "my: pkg scalar alias");
 148
 149     our $xalias9;
 150     sub f9 : lvalue {
 151         ($x, $y) = (1,2);
 152         *xalias9 = \$x;
 153         $y, $xalias9;
 154     }
 155 }
 156
 157 {
 158     use feature 'refaliasing';
 159     no warnings 'experimental';
 160
 161     f10();
 162     our $pkg10;
 163     \(my $lex) = \$pkg10;
 164     my @a = ($lex,3); # equivalent to ($a[0],3)
 165     is("@a", "1 3", "my: lex alias of array alement");
 166
 167     sub f10 {
 168         @a = (1,2);
 169         \$pkg10 = \$a[0];
 170     }
 171
 172 }
 173
 174 {
 175     use feature 'refaliasing';
 176     no warnings 'experimental';
 177
 178     f11();
 179     my @b;
 180     my @a = (@b);
 181     is("@a", "2 1", "my: lex alias of array alements");
 182
 183     sub f11 {
 184         @a = (1,2);
 185         \$b[0] = \$a[1];
 186         \$b[1] = \$a[0];
 187     }
 188 }
 189
 190 # package aliasing
 191
 192 {
 193     my ($x, $y) = (1,2);
 194
 195     for $pkg_scalar ($x) {
 196         ($pkg_scalar, $y) = (3, $x);
 197         is("$pkg_scalar,$y", "3,1", "package scalar aliased");
 198     }
 199 }
 200
 201 # lvalue subs on LHS
 202
 203 {
 204     my @a;
 205     sub f12 : lvalue { @a }
 206     (f12()) = 1..3;
 207     is("@a", "1 2 3", "lvalue sub on RHS returns array");
 208 }
 209
 210 {
 211     my ($x,$y);
 212     sub f13 : lvalue { $x,$y }
 213     (f13()) = 1..3;
 214     is("$x:$y", "1:2", "lvalue sub on RHS returns scalars");
 215 }
 216
 217
 218 # package shared scalar vars
 219
 220 {
 221     our $pkg14a = 1;
 222     our $pkg14b = 2;
 223     ($pkg14a,$pkg14b) = ($pkg14b,$pkg14a);
 224     is("$pkg14a:$pkg14b", "2:1", "shared package scalars");
 225 }
 226
 227 # lexical shared scalar vars
 228
 229 {
 230     my $a = 1;
 231     my $b = 2;
 232     ($a,$b) = ($b,$a);
 233     is("$a:$b", "2:1", "shared lexical scalars");
 234 }
 235
 236
 237 # lexical nested array elem swap
 238
 239 {
 240     my @a;
 241     $a[0][0] = 1;
 242     $a[0][1] = 2;
 243     ($a[0][0],$a[0][1]) =  ($a[0][1],$a[0][0]);
 244     is("$a[0][0]:$a[0][1]", "2:1", "lexical nested array elem swap");
 245 }
 246
 247 # package nested array elem swap
 248
 249 {
 250     our @a15;
 251     $a15[0][0] = 1;
 252     $a15[0][1] = 2;
 253     ($a15[0][0],$a15[0][1]) =  ($a15[0][1],$a15[0][0]);
 254     is("$a15[0][0]:$a15[0][1]", "2:1", "package nested array elem swap");
 255 }
 256
 257 # surplus RHS junk
 258 #
 259 {
 260     our ($a16, $b16);
 261     ($a16, undef, $b16) = 1..30;
 262     is("$a16:$b16", "1:3", "surplus RHS junk");
 263 }
 264
 265 # my ($scalar,....) = @_
 266 #
 267 # technically this is an unsafe usage commonality-wise, but
 268 # a) you have to try really hard to break it, as this test shows;
 269 # b) it's such an important usage that for performance reasons we
 270 #    mark it as safe even though it isn't really. Hence it's a TODO.
 271
 272 SKIP: {
 273     use Config;
 274     # debugging builds will detect this failure and panic
 275     skip "DEBUGGING build" if $::Config{ccflags} =~ /DEBUGGING/
 276                               or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y';
 277     local $::TODO = 'cheat and optimise my (....) = @_';
 278     local @_ = 1..3;
 279     &f17;
 280     my ($a, @b) = @_;
 281     is("($a)(@b)", "(3)(2 1)", 'my (....) = @_');
 282
 283     sub f17 {
 284         use feature 'refaliasing';
 285         no warnings 'experimental';
 286         ($a, @b) = @_;
 287         \($_[2], $_[1], $_[0]) = \($a, $b[0], $b[1]);
 288     }
 289 }
 290
 291 # single scalar on RHS that's in an aggregate on LHS
 292
 293 {
 294     my @a = 1..3;
 295     for my $x ($a[0]) {
 296         (@a) = ($x);
 297         is ("(@a)", "(1)", 'single scalar on RHS, agg');
 298     }
 299 }
 300
 301 # TEMP buffer stealing.
 302 # In something like
 303 #    (...) = (f())[0,0]
 304 # the same TEMP RHS element may be used more than once, so when copying
 305 # it, we mustn't steal its buffer.
 306
 307 {
 308     # a string long enough for COW and buffer stealing to be enabled
 309     my $long = 'def' . ('x' x 2000);
 310
 311     # a sub that is intended to return a TEMP string that isn't COW
 312     # the concat returns a non-COW PADTMP; pp_leavesub sees a long
 313     # stealable string, so creates a TEMP with the stolen buffer from the
 314     # PADTMP - hence it returns a non-COW string
 315     sub f18 {
 316         my $x = "abc";
 317         $x . $long;
 318     }
 319
 320     my @a;
 321
 322     # with @a initially empty,the code path creates a new copy of each
 323     # RHS element to store in the array
 324
 325     @a = (f18())[0,0];
 326     is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL empty $a[0]');
 327     is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL empty $a[1]');
 328
 329     # with @a initially non-empty, it takes a different code path that
 330     # makes a mortal copy of each RHS element
 331     @a = 1..3;
 332     @a = (f18())[0,0];
 333     is (substr($a[0], 0, 7), "abcdefx", 'NOSTEAL non-empty $a[0]');
 334     is (substr($a[1], 0, 7), "abcdefx", 'NOSTEAL non-empty $a[1]');
 335
 336 }
 337
 338 {
 339     my $x = 1;
 340     my $y = 2;
 341     ($x,$y) = (undef, $x);
 342     is($x, undef, 'single scalar on RHS, but two on LHS: x');
 343     is($y, 1, 'single scalar on RHS, but two on LHS: y');
 344 }
 345
 346 { # magic handling, see #126633
 347     use v5.22;
 348     my $set;
 349     package ArrayProxy {
 350         sub TIEARRAY { bless [ $_[1] ] }
 351         sub STORE { $_[0][0]->[$_[1]] = $_[2]; $set = 1 }
 352         sub FETCH { $_[0][0]->[$_[1]] }
 353         sub CLEAR { @{$_[0][0]} = () }
 354         sub EXTEND {}
 355     };
 356     my @base = ( "a", "b" );
 357     my @real = @base;
 358     my @proxy;
 359     my $temp;
 360     tie @proxy, "ArrayProxy", \@real;
 361     @proxy[0, 1] = @real[1, 0];
 362     is($real[0], "b", "tied left first");
 363     is($real[1], "a", "tied left second");
 364     @real = @base;
 365     @real[0, 1] = @proxy[1, 0];
 366     is($real[0], "b", "tied right first");
 367     is($real[1], "a", "tied right second");
 368     @real = @base;
 369     @proxy[0, 1] = @proxy[1, 0];
 370     is($real[0], "b", "tied both first");
 371     is($real[1], "a", "tied both second");
 372     @real = @base;
 373     ($temp, @real) = @proxy[1, 0];
 374     is($real[0], "a", "scalar/array tied right");
 375     @real = @base;
 376     ($temp, @proxy) = @real[1, 0];
 377     is($real[0], "a", "scalar/array tied left");
 378     @real = @base;
 379     ($temp, @proxy) = @proxy[1, 0];
 380     is($real[0], "a", "scalar/array tied both");
 381     $set = 0;
 382     my $orig;
 383     ($proxy[0], $orig) = (1, $set);
 384     is($orig, 0, 'previous value of $set');
 385
 386     # from cpan #110278
 387   SKIP: {
 388       skip "no List::Util::min on miniperl", 2, if is_miniperl;
 389       require List::Util;
 390       my $x = 1;
 391       my $y = 2;
 392       ( $x, $y ) = ( List::Util::min($y), List::Util::min($x) );
 393       is($x, 2, "check swap for \$x");
 394       is($y, 1, "check swap for \$y");
 395     }
 396 }
 397
 398 done_testing();