t/op/array.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('.', '../lib');
   7 }
   8
   9 plan (179);
  10
  11 #
  12 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
  13 #
  14
  15 @ary = (1,2,3,4,5);
  16 is(join('',@ary), '12345');
  17
  18 $tmp = $ary[$#ary]; --$#ary;
  19 is($tmp, 5);
  20 is($#ary, 3);
  21 is(join('',@ary), '1234');
  22
  23 @foo = ();
  24 $r = join(',', $#foo, @foo);
  25 is($r, "-1");
  26 $foo[0] = '0';
  27 $r = join(',', $#foo, @foo);
  28 is($r, "0,0");
  29 $foo[2] = '2';
  30 $r = join(',', $#foo, @foo);
  31 is($r, "2,0,,2");
  32 @bar = ();
  33 $bar[0] = '0';
  34 $bar[1] = '1';
  35 $r = join(',', $#bar, @bar);
  36 is($r, "1,0,1");
  37 @bar = ();
  38 $r = join(',', $#bar, @bar);
  39 is($r, "-1");
  40 $bar[0] = '0';
  41 $r = join(',', $#bar, @bar);
  42 is($r, "0,0");
  43 $bar[2] = '2';
  44 $r = join(',', $#bar, @bar);
  45 is($r, "2,0,,2");
  46 reset 'b' if $^O ne 'VMS';
  47 @bar = ();
  48 $bar[0] = '0';
  49 $r = join(',', $#bar, @bar);
  50 is($r, "0,0");
  51 $bar[2] = '2';
  52 $r = join(',', $#bar, @bar);
  53 is($r, "2,0,,2");
  54
  55 $foo = 'now is the time';
  56 ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
  57 is($F1, 'now');
  58 is($F2, 'is');
  59 is($Etc, 'the time');
  60
  61 $foo = 'lskjdf';
  62 ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
  63    or diag("$cnt $F1:$F2:$Etc");
  64
  65 %foo = ('blurfl','dyick','foo','bar','etc.','etc.');
  66 %bar = %foo;
  67 is($bar{'foo'}, 'bar');
  68 %bar = ();
  69 is($bar{'foo'}, undef);
  70 (%bar,$a,$b) = (%foo,'how','now');
  71 is($bar{'foo'}, 'bar');
  72 is($bar{'how'}, 'now');
  73 @bar{keys %foo} = values %foo;
  74 is($bar{'foo'}, 'bar');
  75 is($bar{'how'}, 'now');
  76
  77 @foo = grep(/e/,split(' ','now is the time for all good men to come to'));
  78 is(join(' ',@foo), 'the time men come');
  79
  80 @foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
  81 is(join(' ',@foo), 'now is for all good to to');
  82
  83 $foo = join('',('a','b','c','d','e','f')[0..5]);
  84 is($foo, 'abcdef');
  85
  86 $foo = join('',('a','b','c','d','e','f')[0..1]);
  87 is($foo, 'ab');
  88
  89 $foo = join('',('a','b','c','d','e','f')[6]);
  90 is($foo, '');
  91
  92 @foo = ('a','b','c','d','e','f')[0,2,4];
  93 @bar = ('a','b','c','d','e','f')[1,3,5];
  94 $foo = join('',(@foo,@bar)[0..5]);
  95 is($foo, 'acebdf');
  96
  97 $foo = ('a','b','c','d','e','f')[0,2,4];
  98 is($foo, 'e');
  99
 100 $foo = ('a','b','c','d','e','f')[1];
 101 is($foo, 'b');
 102
 103 @foo = ( 'foo', 'bar', 'burbl', 'blah');
 104
 105 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
 106
 107 #curr_test(37);
 108
 109 @foo = @foo;
 110 is("@foo", "foo bar burbl blah");                               # 37
 111
 112 (undef,@foo) = @foo;
 113 is("@foo", "bar burbl blah");                                   # 38
 114
 115 @foo = ('XXX',@foo, 'YYY');
 116 is("@foo", "XXX bar burbl blah YYY");                           # 39
 117
 118 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
 119 is("@foo", 'foo b\a\r bu\\rbl blah');                           # 40
 120
 121 @bar = @foo = qw(foo bar);                                      # 41
 122 is("@foo", "foo bar");
 123 is("@bar", "foo bar");                                          # 42
 124
 125 # try the same with local
 126 # XXX tie-stdarray fails the tests involving local, so we use
 127 # different variable names to escape the 'tie'
 128
 129 @bee = ( 'foo', 'bar', 'burbl', 'blah');
 130 {
 131
 132     local @bee = @bee;
 133     is("@bee", "foo bar burbl blah");                           # 43
 134     {
 135         local (undef,@bee) = @bee;
 136         is("@bee", "bar burbl blah");                           # 44
 137         {
 138             local @bee = ('XXX',@bee,'YYY');
 139             is("@bee", "XXX bar burbl blah YYY");               # 45
 140             {
 141                 local @bee = local(@bee) = qw(foo bar burbl blah);
 142                 is("@bee", "foo bar burbl blah");               # 46
 143                 {
 144                     local (@bim) = local(@bee) = qw(foo bar);
 145                     is("@bee", "foo bar");                      # 47
 146                     is("@bim", "foo bar");                      # 48
 147                 }
 148                 is("@bee", "foo bar burbl blah");               # 49
 149             }
 150             is("@bee", "XXX bar burbl blah YYY");               # 50
 151         }
 152         is("@bee", "bar burbl blah");                           # 51
 153     }
 154     is("@bee", "foo bar burbl blah");                           # 52
 155 }
 156
 157 # try the same with my
 158 {
 159     my @bee = @bee;
 160     is("@bee", "foo bar burbl blah");                           # 53
 161     {
 162         my (undef,@bee) = @bee;
 163         is("@bee", "bar burbl blah");                           # 54
 164         {
 165             my @bee = ('XXX',@bee,'YYY');
 166             is("@bee", "XXX bar burbl blah YYY");               # 55
 167             {
 168                 my @bee = my @bee = qw(foo bar burbl blah);
 169                 is("@bee", "foo bar burbl blah");               # 56
 170                 {
 171                     my (@bim) = my(@bee) = qw(foo bar);
 172                     is("@bee", "foo bar");                      # 57
 173                     is("@bim", "foo bar");                      # 58
 174                 }
 175                 is("@bee", "foo bar burbl blah");               # 59
 176             }
 177             is("@bee", "XXX bar burbl blah YYY");               # 60
 178         }
 179         is("@bee", "bar burbl blah");                           # 61
 180     }
 181     is("@bee", "foo bar burbl blah");                           # 62
 182 }
 183
 184 # try the same with our (except that previous values aren't restored)
 185 {
 186     our @bee = @bee;
 187     is("@bee", "foo bar burbl blah");
 188     {
 189         our (undef,@bee) = @bee;
 190         is("@bee", "bar burbl blah");
 191         {
 192             our @bee = ('XXX',@bee,'YYY');
 193             is("@bee", "XXX bar burbl blah YYY");
 194             {
 195                 our @bee = our @bee = qw(foo bar burbl blah);
 196                 is("@bee", "foo bar burbl blah");
 197                 {
 198                     our (@bim) = our(@bee) = qw(foo bar);
 199                     is("@bee", "foo bar");
 200                     is("@bim", "foo bar");
 201                 }
 202             }
 203         }
 204     }
 205 }
 206
 207 # make sure reification behaves
 208 my $t = curr_test();
 209 sub reify { $_[1] = $t++; print "@_\n"; }
 210 reify('ok');
 211 reify('ok');
 212
 213 curr_test($t);
 214
 215 # qw() is no longer a runtime split, it's compiletime.
 216 is (qw(foo bar snorfle)[2], 'snorfle');
 217
 218 @ary = (12,23,34,45,56);
 219
 220 is(shift(@ary), 12);
 221 is(pop(@ary), 56);
 222 is(push(@ary,56), 4);
 223 is(unshift(@ary,12), 5);
 224
 225 sub foo { "a" }
 226 @foo=(foo())[0,0];
 227 is ($foo[1], "a");
 228
 229 # bugid #15439 - clearing an array calls destructors which may try
 230 # to modify the array - caused 'Attempt to free unreferenced scalar'
 231
 232 my $got = runperl (
 233         prog => q{
 234                     sub X::DESTROY { @a = () }
 235                     @a = (bless {}, q{X});
 236                     @a = ();
 237                 },
 238         stderr => 1
 239     );
 240
 241 $got =~ s/\n/ /g;
 242 is ($got, '');
 243
 244 # Test negative and funky indices.
 245
 246
 247 {
 248     my @a = 0..4;
 249     is($a[-1], 4);
 250     is($a[-2], 3);
 251     is($a[-5], 0);
 252     ok(!defined $a[-6]);
 253
 254     is($a[2.1]  , 2);
 255     is($a[2.9]  , 2);
 256     is($a[undef], 0);
 257     is($a["3rd"], 3);
 258 }
 259
 260
 261 {
 262     my @a;
 263     eval '$a[-1] = 0';
 264     like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
 265 }
 266
 267 sub test_arylen {
 268     my $ref = shift;
 269     local $^W = 1;
 270     is ($$ref, undef, "\$# on freed array is undef");
 271     my @warn;
 272     local $SIG{__WARN__} = sub {push @warn, "@_"};
 273     $$ref = 1000;
 274     is (scalar @warn, 1);
 275     like ($warn[0], qr/^Attempt to set length of freed array/);
 276 }
 277
 278 {
 279     my $a = \$#{[]};
 280     # Need a new statement to make it go out of scope
 281     test_arylen ($a);
 282     test_arylen (do {my @a; \$#a});
 283 }
 284
 285 {
 286     use vars '@array';
 287
 288     my $outer = \$#array;
 289     is ($$outer, -1);
 290     is (scalar @array, 0);
 291
 292     $$outer = 3;
 293     is ($$outer, 3);
 294     is (scalar @array, 4);
 295
 296     my $ref = \@array;
 297
 298     my $inner;
 299     {
 300         local @array;
 301         $inner = \$#array;
 302
 303         is ($$inner, -1);
 304         is (scalar @array, 0);
 305         $$outer = 6;
 306
 307         is (scalar @$ref, 7);
 308
 309         is ($$inner, -1);
 310         is (scalar @array, 0);
 311
 312         $$inner = 42;
 313     }
 314
 315     is (scalar @array, 7);
 316     is ($$outer, 6);
 317
 318     is ($$inner, undef, "orphaned $#foo is always undef");
 319
 320     is (scalar @array, 7);
 321     is ($$outer, 6);
 322
 323     $$inner = 1;
 324
 325     is (scalar @array, 7);
 326     is ($$outer, 6);
 327
 328     $$inner = 503; # Bang!
 329
 330     is (scalar @array, 7);
 331     is ($$outer, 6);
 332 }
 333
 334 {
 335     # Bug #36211
 336     use vars '@array';
 337     for (1,2) {
 338         {
 339             local @a;
 340             is ($#a, -1);
 341             @a=(1..4)
 342         }
 343     }
 344 }
 345
 346 {
 347     # Bug #37350
 348     my @array = (1..4);
 349     $#{@array} = 7;
 350     is ($#{4}, 7);
 351
 352     my $x;
 353     $#{$x} = 3;
 354     is(scalar @$x, 4);
 355
 356     push @{@array}, 23;
 357     is ($4[8], 23);
 358 }
 359 {
 360     # Bug #37350 -- once more with a global
 361     use vars '@array';
 362     @array = (1..4);
 363     $#{@array} = 7;
 364     is ($#{4}, 7);
 365
 366     my $x;
 367     $#{$x} = 3;
 368     is(scalar @$x, 4);
 369
 370     push @{@array}, 23;
 371     is ($4[8], 23);
 372 }
 373
 374 # more tests for AASSIGN_COMMON
 375
 376 {
 377     our($x,$y,$z) = (1..3);
 378     our($y,$z) = ($x,$y);
 379     is("$x $y $z", "1 1 2");
 380 }
 381 {
 382     our($x,$y,$z) = (1..3);
 383     (our $y, our $z) = ($x,$y);
 384     is("$x $y $z", "1 1 2");
 385 }
 386 {
 387     # AASSIGN_COMMON detection with logical operators
 388     my $true = 1;
 389     our($x,$y,$z) = (1..3);
 390     (our $y, our $z) = $true && ($x,$y);
 391     is("$x $y $z", "1 1 2");
 392 }
 393
 394 # [perl #70171]
 395 {
 396  my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
 397  is(
 398    join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
 399   'bug 70171 (self-assignment via my %x = %$x)'
 400  );
 401  my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
 402  is(
 403   "@y", "1 2 3 4",
 404   'bug 70171 (self-assignment via my @x = @$x)'
 405  );
 406 }
 407
 408 # [perl #70171], [perl #82110]
 409 {
 410     my ($i, $ra, $rh);
 411   again:
 412     my @a = @$ra; # common assignment on 2nd attempt
 413     my %h = %$rh; # common assignment on 2nd attempt
 414     @a = qw(1 2 3 4);
 415     %h = qw(a 1 b 2 c 3 d 4);
 416     $ra = \@a;
 417     $rh = \%h;
 418     goto again unless $i++;
 419
 420     is("@a", "1 2 3 4",
 421         'bug 70171 (self-assignment via my @x = @$x) - goto variant'
 422     );
 423     is(
 424         join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4",
 425         'bug 70171 (self-assignment via my %x = %$x) - goto variant'
 426     );
 427 }
 428
 429
 430 *trit = *scile;  $trit[0];
 431 ok(1, 'aelem_fast on a nonexistent array does not crash');
 432
 433 # [perl #107440]
 434 sub A::DESTROY { $::ra = 0 }
 435 $::ra = [ bless [], 'A' ];
 436 undef @$::ra;
 437 pass 'no crash when freeing array that is being undeffed';
 438 $::ra = [ bless [], 'A' ];
 439 @$::ra = ('a'..'z');
 440 pass 'no crash when freeing array that is being cleared';
 441
 442 # [perl #85670] Copying magic to elements
 443 SKIP: {
 444     skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
 445     require Scalar::Util;
 446     package glelp {
 447         Scalar::Util::weaken ($a = \@ISA);
 448         @ISA = qw(Foo);
 449         Scalar::Util::weaken ($a = \$ISA[0]);
 450         ::is @ISA, 1, 'backref magic is not copied to elements';
 451     }
 452 }
 453 package peen {
 454     $#ISA = -1;
 455     @ISA = qw(Foo);
 456     $ISA[0] = qw(Sphare);
 457
 458     sub Sphare::pling { 'pling' }
 459
 460     ::is eval { pling peen }, 'pling',
 461         'arylen_p magic does not stop isa magic from being copied';
 462 }
 463
 464 # Test that &PL_sv_undef is not special in arrays
 465 sub {
 466     ok exists $_[0],
 467       'exists returns true for &PL_sv_undef elem [perl #7508]';
 468     is \$_[0], \undef, 'undef preserves identity in array [perl #109726]';
 469 }->(undef);
 470 # and that padav also knows how to handle the resulting NULLs
 471 @_ = sub { my @a; $a[1]=1; @a }->();
 472 is join (" ", map $_//"undef", @_), "undef 1",
 473   'returning my @a with nonexistent elements';
 474
 475 # [perl #118691]
 476 @plink=@plunk=();
 477 $plink[3] = 1;
 478 sub {
 479     $_[0] = 2;
 480     is $plink[0], 2, '@_ alias to nonexistent elem within array';
 481     $_[1] = 3;
 482     is $plink[1], 3, '@_ alias to nonexistent neg index within array';
 483     is $_[2], undef, 'reading alias to negative index past beginning';
 484     eval { $_[2] = 42 };
 485     like $@, qr/Modification of non-creatable array value attempted, (?x:
 486                )subscript -5/,
 487          'error when setting alias to negative index past beginning';
 488     is $_[3], undef, 'reading alias to -1 elem of empty array';
 489     eval { $_[3] = 42 };
 490     like $@, qr/Modification of non-creatable array value attempted, (?x:
 491                )subscript -1/,
 492          'error when setting alias to -1 elem of empty array';
 493 }->($plink[0], $plink[-2], $plink[-5], $plunk[-1]);
 494
 495 $_ = \$#{[]};
 496 $$_ = \1;
 497 "$$_";
 498 pass "no assertion failure after assigning ref to arylen when ary is gone";
 499
 500
 501 {
 502     # Test aelemfast for both +ve and -ve indices, both lex and package vars.
 503     # Make especially careful that we don't have any edge cases around
 504     # fitting an I8 into a U8.
 505     my @a = (0..299);
 506     is($a[-256], 300-256, 'lex -256');
 507     is($a[-255], 300-255, 'lex -255');
 508     is($a[-254], 300-254, 'lex -254');
 509     is($a[-129], 300-129, 'lex -129');
 510     is($a[-128], 300-128, 'lex -128');
 511     is($a[-127], 300-127, 'lex -127');
 512     is($a[-126], 300-126, 'lex -126');
 513     is($a[  -1], 300-  1, 'lex   -1');
 514     is($a[   0],       0, 'lex    0');
 515     is($a[   1],       1, 'lex    1');
 516     is($a[ 126],     126, 'lex  126');
 517     is($a[ 127],     127, 'lex  127');
 518     is($a[ 128],     128, 'lex  128');
 519     is($a[ 129],     129, 'lex  129');
 520     is($a[ 254],     254, 'lex  254');
 521     is($a[ 255],     255, 'lex  255');
 522     is($a[ 256],     256, 'lex  256');
 523     @aelem =(0..299);
 524     is($aelem[-256], 300-256, 'pkg -256');
 525     is($aelem[-255], 300-255, 'pkg -255');
 526     is($aelem[-254], 300-254, 'pkg -254');
 527     is($aelem[-129], 300-129, 'pkg -129');
 528     is($aelem[-128], 300-128, 'pkg -128');
 529     is($aelem[-127], 300-127, 'pkg -127');
 530     is($aelem[-126], 300-126, 'pkg -126');
 531     is($aelem[  -1], 300-  1, 'pkg   -1');
 532     is($aelem[   0],       0, 'pkg    0');
 533     is($aelem[   1],       1, 'pkg    1');
 534     is($aelem[ 126],     126, 'pkg  126');
 535     is($aelem[ 127],     127, 'pkg  127');
 536     is($aelem[ 128],     128, 'pkg  128');
 537     is($aelem[ 129],     129, 'pkg  129');
 538     is($aelem[ 254],     254, 'pkg  254');
 539     is($aelem[ 255],     255, 'pkg  255');
 540     is($aelem[ 256],     256, 'pkg  256');
 541 }
 542
 543 # Test aelemfast in list assignment
 544 @ary = ('a','b');
 545 ($ary[0],$ary[1]) = ($ary[1],$ary[0]);
 546 is "@ary", 'b a',
 547    'aelemfast with the same array on both sides of list assignment';
 548
 549 for(scalar $#foo) { $_ = 3 }
 550 is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)';
 551
 552 {
 553     my @a = qw(a b c);
 554     @a = @a;
 555     is "@a", 'a b c', 'assigning to itself';
 556 }
 557
 558 sub { undef *_; shift }->(); # This would crash; no ok() necessary.
 559 sub { undef *_; pop   }->();
 560
 561 # [perl #129164], [perl #129166], [perl #129167]
 562 # splice() with null array entries
 563 # These used to crash.
 564 $#a = -1; $#a++;
 565 () = 0-splice @a; # subtract
 566 $#a = -1; $#a++;
 567 () =  -splice @a; # negate
 568 $#a = -1; $#a++;
 569 () = 0+splice @a; # add
 570 # And with array expansion, too
 571 $#a = -1; $#a++;
 572 () = 0-splice @a, 0, 1, 1, 1;
 573 $#a = -1; $#a++;
 574 () =  -splice @a, 0, 1, 1, 1;
 575 $#a = -1; $#a++;
 576 () = 0+splice @a, 0, 1, 1, 1;
 577
 578 # [perl #8910] lazy creation of array elements used to leak out
 579 {
 580     sub t8910 { $_[1] = 5; $_[2] = 7; }
 581     my @p;
 582     $p[0] = 1;
 583     $p[2] = 2;
 584     t8910(@p);
 585     is "@p", "1 5 7", "lazy element creation with sub call";
 586     my @q;
 587     @q[0] = 1;
 588     @q[2] = 2;
 589     my @qr = \(@q);
 590     is $qr[$_], \$q[$_], "lazy element creation with refgen" foreach 0..2;
 591     isnt $qr[1], \undef, "lazy element creation with refgen";
 592     my @r;
 593     $r[1] = 1;
 594     foreach my $re ((), @r) { $re = 5; }
 595     is join("", @r), "55", "lazy element creation with foreach";
 596 }
 597
 598 "We're included by lib/Tie/Array/std.t so we need to return something true";