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