t/op/array.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = ('.', '../lib');
   6     require 'test.pl';
   7 }
   8
   9 plan (137);
  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');
 104 {
 105     no warnings 'deprecated';
 106     push(foo, 'blah');
 107 }
 108 is($#foo, 3);
 109
 110 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
 111
 112 #curr_test(38);
 113
 114 @foo = @foo;
 115 is("@foo", "foo bar burbl blah");                               # 38
 116
 117 (undef,@foo) = @foo;
 118 is("@foo", "bar burbl blah");                                   # 39
 119
 120 @foo = ('XXX',@foo, 'YYY');
 121 is("@foo", "XXX bar burbl blah YYY");                           # 40
 122
 123 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
 124 is("@foo", 'foo b\a\r bu\\rbl blah');                           # 41
 125
 126 @bar = @foo = qw(foo bar);                                      # 42
 127 is("@foo", "foo bar");
 128 is("@bar", "foo bar");                                          # 43
 129
 130 # try the same with local
 131 # XXX tie-stdarray fails the tests involving local, so we use
 132 # different variable names to escape the 'tie'
 133
 134 @bee = ( 'foo', 'bar', 'burbl', 'blah');
 135 {
 136
 137     local @bee = @bee;
 138     is("@bee", "foo bar burbl blah");                           # 44
 139     {
 140         local (undef,@bee) = @bee;
 141         is("@bee", "bar burbl blah");                           # 45
 142         {
 143             local @bee = ('XXX',@bee,'YYY');
 144             is("@bee", "XXX bar burbl blah YYY");               # 46
 145             {
 146                 local @bee = local(@bee) = qw(foo bar burbl blah);
 147                 is("@bee", "foo bar burbl blah");               # 47
 148                 {
 149                     local (@bim) = local(@bee) = qw(foo bar);
 150                     is("@bee", "foo bar");                      # 48
 151                     is("@bim", "foo bar");                      # 49
 152                 }
 153                 is("@bee", "foo bar burbl blah");               # 50
 154             }
 155             is("@bee", "XXX bar burbl blah YYY");               # 51
 156         }
 157         is("@bee", "bar burbl blah");                           # 52
 158     }
 159     is("@bee", "foo bar burbl blah");                           # 53
 160 }
 161
 162 # try the same with my
 163 {
 164     my @bee = @bee;
 165     is("@bee", "foo bar burbl blah");                           # 54
 166     {
 167         my (undef,@bee) = @bee;
 168         is("@bee", "bar burbl blah");                           # 55
 169         {
 170             my @bee = ('XXX',@bee,'YYY');
 171             is("@bee", "XXX bar burbl blah YYY");               # 56
 172             {
 173                 my @bee = my @bee = qw(foo bar burbl blah);
 174                 is("@bee", "foo bar burbl blah");               # 57
 175                 {
 176                     my (@bim) = my(@bee) = qw(foo bar);
 177                     is("@bee", "foo bar");                      # 58
 178                     is("@bim", "foo bar");                      # 59
 179                 }
 180                 is("@bee", "foo bar burbl blah");               # 60
 181             }
 182             is("@bee", "XXX bar burbl blah YYY");               # 61
 183         }
 184         is("@bee", "bar burbl blah");                           # 62
 185     }
 186     is("@bee", "foo bar burbl blah");                           # 63
 187 }
 188
 189 # try the same with our (except that previous values aren't restored)
 190 {
 191     our @bee = @bee;
 192     is("@bee", "foo bar burbl blah");
 193     {
 194         our (undef,@bee) = @bee;
 195         is("@bee", "bar burbl blah");
 196         {
 197             our @bee = ('XXX',@bee,'YYY');
 198             is("@bee", "XXX bar burbl blah YYY");
 199             {
 200                 our @bee = our @bee = qw(foo bar burbl blah);
 201                 is("@bee", "foo bar burbl blah");
 202                 {
 203                     our (@bim) = our(@bee) = qw(foo bar);
 204                     is("@bee", "foo bar");
 205                     is("@bim", "foo bar");
 206                 }
 207             }
 208         }
 209     }
 210 }
 211
 212 # make sure reification behaves
 213 my $t = curr_test();
 214 sub reify { $_[1] = $t++; print "@_\n"; }
 215 reify('ok');
 216 reify('ok');
 217
 218 curr_test($t);
 219
 220 # qw() is no longer a runtime split, it's compiletime.
 221 is (qw(foo bar snorfle)[2], 'snorfle');
 222
 223 @ary = (12,23,34,45,56);
 224
 225 is(shift(@ary), 12);
 226 is(pop(@ary), 56);
 227 is(push(@ary,56), 4);
 228 is(unshift(@ary,12), 5);
 229
 230 sub foo { "a" }
 231 @foo=(foo())[0,0];
 232 is ($foo[1], "a");
 233
 234 # bugid #15439 - clearing an array calls destructors which may try
 235 # to modify the array - caused 'Attempt to free unreferenced scalar'
 236
 237 my $got = runperl (
 238         prog => q{
 239                     sub X::DESTROY { @a = () }
 240                     @a = (bless {}, q{X});
 241                     @a = ();
 242                 },
 243         stderr => 1
 244     );
 245
 246 $got =~ s/\n/ /g;
 247 is ($got, '');
 248
 249 # Test negative and funky indices.
 250
 251
 252 {
 253     my @a = 0..4;
 254     is($a[-1], 4);
 255     is($a[-2], 3);
 256     is($a[-5], 0);
 257     ok(!defined $a[-6]);
 258
 259     is($a[2.1]  , 2);
 260     is($a[2.9]  , 2);
 261     is($a[undef], 0);
 262     is($a["3rd"], 3);
 263 }
 264
 265
 266 {
 267     my @a;
 268     eval '$a[-1] = 0';
 269     like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
 270 }
 271
 272 sub test_arylen {
 273     my $ref = shift;
 274     local $^W = 1;
 275     is ($$ref, undef, "\$# on freed array is undef");
 276     my @warn;
 277     local $SIG{__WARN__} = sub {push @warn, "@_"};
 278     $$ref = 1000;
 279     is (scalar @warn, 1);
 280     like ($warn[0], qr/^Attempt to set length of freed array/);
 281 }
 282
 283 {
 284     my $a = \$#{[]};
 285     # Need a new statement to make it go out of scope
 286     test_arylen ($a);
 287     test_arylen (do {my @a; \$#a});
 288 }
 289
 290 {
 291     use vars '@array';
 292
 293     my $outer = \$#array;
 294     is ($$outer, -1);
 295     is (scalar @array, 0);
 296
 297     $$outer = 3;
 298     is ($$outer, 3);
 299     is (scalar @array, 4);
 300
 301     my $ref = \@array;
 302
 303     my $inner;
 304     {
 305         local @array;
 306         $inner = \$#array;
 307
 308         is ($$inner, -1);
 309         is (scalar @array, 0);
 310         $$outer = 6;
 311
 312         is (scalar @$ref, 7);
 313
 314         is ($$inner, -1);
 315         is (scalar @array, 0);
 316
 317         $$inner = 42;
 318     }
 319
 320     is (scalar @array, 7);
 321     is ($$outer, 6);
 322
 323     is ($$inner, undef, "orphaned $#foo is always undef");
 324
 325     is (scalar @array, 7);
 326     is ($$outer, 6);
 327
 328     $$inner = 1;
 329
 330     is (scalar @array, 7);
 331     is ($$outer, 6);
 332
 333     $$inner = 503; # Bang!
 334
 335     is (scalar @array, 7);
 336     is ($$outer, 6);
 337 }
 338
 339 {
 340     # Bug #36211
 341     use vars '@array';
 342     for (1,2) {
 343         {
 344             local @a;
 345             is ($#a, -1);
 346             @a=(1..4)
 347         }
 348     }
 349 }
 350
 351 {
 352     # Bug #37350
 353     my @array = (1..4);
 354     $#{@array} = 7;
 355     is ($#{4}, 7);
 356
 357     my $x;
 358     $#{$x} = 3;
 359     is(scalar @$x, 4);
 360
 361     push @{@array}, 23;
 362     is ($4[8], 23);
 363 }
 364 {
 365     # Bug #37350 -- once more with a global
 366     use vars '@array';
 367     @array = (1..4);
 368     $#{@array} = 7;
 369     is ($#{4}, 7);
 370
 371     my $x;
 372     $#{$x} = 3;
 373     is(scalar @$x, 4);
 374
 375     push @{@array}, 23;
 376     is ($4[8], 23);
 377 }
 378
 379 # more tests for AASSIGN_COMMON
 380
 381 {
 382     our($x,$y,$z) = (1..3);
 383     our($y,$z) = ($x,$y);
 384     is("$x $y $z", "1 1 2");
 385 }
 386 {
 387     our($x,$y,$z) = (1..3);
 388     (our $y, our $z) = ($x,$y);
 389     is("$x $y $z", "1 1 2");
 390 }
 391 {
 392     # AASSIGN_COMMON detection with logical operators
 393     my $true = 1;
 394     our($x,$y,$z) = (1..3);
 395     (our $y, our $z) = $true && ($x,$y);
 396     is("$x $y $z", "1 1 2");
 397 }
 398
 399 # [perl #70171]
 400 {
 401  my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
 402  is(
 403    join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
 404   'bug 70171 (self-assignment via my %x = %$x)'
 405  );
 406  my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
 407  is(
 408   "@y", "1 2 3 4",
 409   'bug 70171 (self-assignment via my @x = @$x)'
 410  );
 411 }
 412
 413 # [perl #70171], [perl #82110]
 414 {
 415     my ($i, $ra, $rh);
 416   again:
 417     my @a = @$ra; # common assignment on 2nd attempt
 418     my %h = %$rh; # common assignment on 2nd attempt
 419     @a = qw(1 2 3 4);
 420     %h = qw(a 1 b 2 c 3 d 4);
 421     $ra = \@a;
 422     $rh = \%h;
 423     goto again unless $i++;
 424
 425     is("@a", "1 2 3 4",
 426         'bug 70171 (self-assignment via my @x = @$x) - goto variant'
 427     );
 428     is(
 429         join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4",
 430         'bug 70171 (self-assignment via my %x = %$x) - goto variant'
 431     );
 432 }
 433
 434
 435 *trit = *scile;  $trit[0];
 436 ok(1, 'aelem_fast on a nonexistent array does not crash');
 437
 438 # [perl #107440]
 439 sub A::DESTROY { $::ra = 0 }
 440 $::ra = [ bless [], 'A' ];
 441 undef @$::ra;
 442 pass 'no crash when freeing array that is being undeffed';
 443 $::ra = [ bless [], 'A' ];
 444 @$::ra = ('a'..'z');
 445 pass 'no crash when freeing array that is being cleared';
 446
 447 # [perl #85670] Copying magic to elements
 448 SKIP: {
 449     skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
 450     require Scalar::Util;
 451     package glelp {
 452         Scalar::Util::weaken ($a = \@ISA);
 453         @ISA = qw(Foo);
 454         Scalar::Util::weaken ($a = \$ISA[0]);
 455         ::is @ISA, 1, 'backref magic is not copied to elements';
 456     }
 457 }
 458 package peen {
 459     $#ISA = -1;
 460     @ISA = qw(Foo);
 461     $ISA[0] = qw(Sphare);
 462
 463     sub Sphare::pling { 'pling' }
 464
 465     ::is eval { pling peen }, 'pling',
 466         'arylen_p magic does not stop isa magic from being copied';
 467 }
 468
 469 # Test that &PL_sv_undef is not special in arrays
 470 sub {
 471     ok exists $_[0],
 472       'exists returns true for &PL_sv_undef elem [perl #7508]';
 473     is \$_[0], \undef, 'undef preserves identity in array [perl #109726]';
 474 }->(undef);
 475 # and that padav also knows how to handle the resulting NULLs
 476 @_ = sub { my @a; $a[1]=1; @a }->();
 477 is join (" ", map $_//"undef", @_), "undef 1",
 478   'returning my @a with nonexistent elements';
 479
 480 # [perl #118691]
 481 @plink=@plunk=();
 482 $plink[3] = 1;
 483 sub {
 484     $_[0] = 2;
 485     is $plink[0], 2, '@_ alias to nonexistent elem within array';
 486     $_[1] = 3;
 487     is $plink[1], 3, '@_ alias to nonexistent neg index within array';
 488     is $_[2], undef, 'reading alias to negative index past beginning';
 489     eval { $_[2] = 42 };
 490     like $@, qr/Modification of non-creatable array value attempted, (?x:
 491                )subscript -5/,
 492          'error when setting alias to negative index past beginning';
 493     is $_[3], undef, 'reading alias to -1 elem of empty array';
 494     eval { $_[3] = 42 };
 495     like $@, qr/Modification of non-creatable array value attempted, (?x:
 496                )subscript -1/,
 497          'error when setting alias to -1 elem of empty array';
 498 }->($plink[0], $plink[-2], $plink[-5], $plunk[-1]);
 499
 500 $_ = \$#{[]};
 501 $$_ = \1;
 502 "$$_";
 503 pass "no assertion failure after assigning ref to arylen when ary is gone";
 504
 505 "We're included by lib/Tie/Array/std.t so we need to return something true";