t/op/array.t

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