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