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