t/op/array.t

   1 #!./perl
   2
   3
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     @INC = '../lib';
   7 }
   8
   9 print "1..73\n";
  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 if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
  17
  18 $tmp = $ary[$#ary]; --$#ary;
  19 if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
  20 if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
  21 if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
  22
  23 $[ = 1;
  24 @ary = (1,2,3,4,5);
  25 if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
  26
  27 $tmp = $ary[$#ary]; --$#ary;
  28 if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
  29 if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
  30 if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
  31
  32 if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
  33
  34 $#ary += 1;     # see if element 5 gone for good
  35 if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";}
  36 if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";}
  37
  38 $[ = 0;
  39 @foo = ();
  40 $r = join(',', $#foo, @foo);
  41 if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
  42 $foo[0] = '0';
  43 $r = join(',', $#foo, @foo);
  44 if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
  45 $foo[2] = '2';
  46 $r = join(',', $#foo, @foo);
  47 if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
  48 @bar = ();
  49 $bar[0] = '0';
  50 $bar[1] = '1';
  51 $r = join(',', $#bar, @bar);
  52 if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
  53 @bar = ();
  54 $r = join(',', $#bar, @bar);
  55 if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
  56 $bar[0] = '0';
  57 $r = join(',', $#bar, @bar);
  58 if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
  59 $bar[2] = '2';
  60 $r = join(',', $#bar, @bar);
  61 if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
  62 reset 'b';
  63 @bar = ();
  64 $bar[0] = '0';
  65 $r = join(',', $#bar, @bar);
  66 if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
  67 $bar[2] = '2';
  68 $r = join(',', $#bar, @bar);
  69 if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
  70
  71 $foo = 'now is the time';
  72 if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
  73     if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
  74         print "ok 21\n";
  75     }
  76     else {
  77         print "not ok 21\n";
  78     }
  79 }
  80 else {
  81     print "not ok 21\n";
  82 }
  83
  84 $foo = 'lskjdf';
  85 if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
  86     print "not ok 22 $cnt $F1:$F2:$Etc\n";
  87 }
  88 else {
  89     print "ok 22\n";
  90 }
  91
  92 %foo = ('blurfl','dyick','foo','bar','etc.','etc.');
  93 %bar = %foo;
  94 print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
  95 %bar = ();
  96 print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
  97 (%bar,$a,$b) = (%foo,'how','now');
  98 print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
  99 print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
 100 @bar{keys %foo} = values %foo;
 101 print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
 102 print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
 103
 104 @foo = grep(/e/,split(' ','now is the time for all good men to come to'));
 105 print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
 106
 107 @foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
 108 print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
 109
 110 $foo = join('',('a','b','c','d','e','f')[0..5]);
 111 print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n";
 112
 113 $foo = join('',('a','b','c','d','e','f')[0..1]);
 114 print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n";
 115
 116 $foo = join('',('a','b','c','d','e','f')[6]);
 117 print $foo eq '' ? "ok 33\n" : "not ok 33\n";
 118
 119 @foo = ('a','b','c','d','e','f')[0,2,4];
 120 @bar = ('a','b','c','d','e','f')[1,3,5];
 121 $foo = join('',(@foo,@bar)[0..5]);
 122 print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n";
 123
 124 $foo = ('a','b','c','d','e','f')[0,2,4];
 125 print $foo eq 'e' ? "ok 35\n" : "not ok 35\n";
 126
 127 $foo = ('a','b','c','d','e','f')[1];
 128 print $foo eq 'b' ? "ok 36\n" : "not ok 36\n";
 129
 130 @foo = ( 'foo', 'bar', 'burbl');
 131 push(foo, 'blah');
 132 print $#foo == 3 ? "ok 37\n" : "not ok 37\n";
 133
 134 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
 135
 136 $test = 37;
 137 sub t { ++$test; print "not " unless $_[0]; print "ok $test\n"; }
 138
 139 @foo = @foo;
 140 t("@foo" eq "foo bar burbl blah");                              # 38
 141
 142 (undef,@foo) = @foo;
 143 t("@foo" eq "bar burbl blah");                                  # 39
 144
 145 @foo = ('XXX',@foo, 'YYY');
 146 t("@foo" eq "XXX bar burbl blah YYY");                          # 40
 147
 148 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
 149 t("@foo" eq 'foo b\a\r bu\\rbl blah');                          # 41
 150
 151 @bar = @foo = qw(foo bar);                                      # 42
 152 t("@foo" eq "foo bar");
 153 t("@bar" eq "foo bar");                                         # 43
 154
 155 # try the same with local
 156 # XXX tie-stdarray fails the tests involving local, so we use
 157 # different variable names to escape the 'tie'
 158
 159 @bee = ( 'foo', 'bar', 'burbl', 'blah');
 160 {
 161
 162     local @bee = @bee;
 163     t("@bee" eq "foo bar burbl blah");                          # 44
 164     {
 165         local (undef,@bee) = @bee;
 166         t("@bee" eq "bar burbl blah");                          # 45
 167         {
 168             local @bee = ('XXX',@bee,'YYY');
 169             t("@bee" eq "XXX bar burbl blah YYY");              # 46
 170             {
 171                 local @bee = local(@bee) = qw(foo bar burbl blah);
 172                 t("@bee" eq "foo bar burbl blah");              # 47
 173                 {
 174                     local (@bim) = local(@bee) = qw(foo bar);
 175                     t("@bee" eq "foo bar");                     # 48
 176                     t("@bim" eq "foo bar");                     # 49
 177                 }
 178                 t("@bee" eq "foo bar burbl blah");              # 50
 179             }
 180             t("@bee" eq "XXX bar burbl blah YYY");              # 51
 181         }
 182         t("@bee" eq "bar burbl blah");                          # 52
 183     }
 184     t("@bee" eq "foo bar burbl blah");                          # 53
 185 }
 186
 187 # try the same with my
 188 {
 189
 190     my @bee = @bee;
 191     t("@bee" eq "foo bar burbl blah");                          # 54
 192     {
 193         my (undef,@bee) = @bee;
 194         t("@bee" eq "bar burbl blah");                          # 55
 195         {
 196             my @bee = ('XXX',@bee,'YYY');
 197             t("@bee" eq "XXX bar burbl blah YYY");              # 56
 198             {
 199                 my @bee = my @bee = qw(foo bar burbl blah);
 200                 t("@bee" eq "foo bar burbl blah");              # 57
 201                 {
 202                     my (@bim) = my(@bee) = qw(foo bar);
 203                     t("@bee" eq "foo bar");                     # 58
 204                     t("@bim" eq "foo bar");                     # 59
 205                 }
 206                 t("@bee" eq "foo bar burbl blah");              # 60
 207             }
 208             t("@bee" eq "XXX bar burbl blah YYY");              # 61
 209         }
 210         t("@bee" eq "bar burbl blah");                          # 62
 211     }
 212     t("@bee" eq "foo bar burbl blah");                          # 63
 213 }
 214
 215 # make sure reification behaves
 216 my $t = 63;
 217 sub reify { $_[1] = ++$t; print "@_\n"; }
 218 reify('ok');
 219 reify('ok');
 220
 221 # qw() is no more a runtime split, it's compiletime.
 222 print "not " unless qw(foo bar snorfle)[2] eq 'snorfle';
 223 print "ok 66\n";
 224
 225 @ary = (12,23,34,45,56);
 226
 227 print "not " unless shift(@ary) == 12;
 228 print "ok 67\n";
 229
 230 print "not " unless pop(@ary) == 56;
 231 print "ok 68\n";
 232
 233 print "not " unless push(@ary,56) == 4;
 234 print "ok 69\n";
 235
 236 print "not " unless unshift(@ary,12) == 5;
 237 print "ok 70\n";
 238
 239 sub foo { "a" }
 240 @foo=(foo())[0,0];
 241 $foo[1] eq "a" or print "not ";
 242 print "ok 71\n";
 243
 244 # $[ should have the same effect regardless of whether the aelem
 245 #    op is optimized to aelemfast.
 246
 247 sub tary {
 248   local $[ = 10;
 249   my $five = 5;
 250   print "not " unless $tary[5] == $tary[$five];
 251   print "ok 72\n";
 252 }
 253
 254 @tary = (0..50);
 255 tary();
 256
 257
 258 require './test.pl';
 259
 260 # bugid #15439 - clearing an array calls destructors which may try
 261 # to modify the array - caused 'Attempt to free unreferenced scalar'
 262
 263 my $got = runperl (
 264         prog => q{
 265                     sub X::DESTROY { @a = () }
 266                     @a = (bless {}, 'X');
 267                     @a = ();
 268                 },
 269         stderr => 1
 270     );
 271
 272 $got =~ s/\n/ /g;
 273 print "# $got\nnot " unless $got eq '';
 274 print "ok 73\n";