1#!./perl 2 3 4BEGIN { 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7} 8 9print "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); 16if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";} 17 18$tmp = $ary[$#ary]; --$#ary; 19if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";} 20if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";} 21if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";} 22 23$[ = 1; 24@ary = (1,2,3,4,5); 25if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";} 26 27$tmp = $ary[$#ary]; --$#ary; 28if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";} 29if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";} 30if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";} 31 32if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";} 33 34$#ary += 1; # see if element 5 gone for good 35if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";} 36if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";} 37 38$[ = 0; 39@foo = (); 40$r = join(',', $#foo, @foo); 41if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";} 42$foo[0] = '0'; 43$r = join(',', $#foo, @foo); 44if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";} 45$foo[2] = '2'; 46$r = join(',', $#foo, @foo); 47if ($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); 52if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";} 53@bar = (); 54$r = join(',', $#bar, @bar); 55if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";} 56$bar[0] = '0'; 57$r = join(',', $#bar, @bar); 58if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";} 59$bar[2] = '2'; 60$r = join(',', $#bar, @bar); 61if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";} 62reset 'b'; 63@bar = (); 64$bar[0] = '0'; 65$r = join(',', $#bar, @bar); 66if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";} 67$bar[2] = '2'; 68$r = join(',', $#bar, @bar); 69if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";} 70 71$foo = 'now is the time'; 72if (($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} 80else { 81 print "not ok 21\n"; 82} 83 84$foo = 'lskjdf'; 85if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) { 86 print "not ok 22 $cnt $F1:$F2:$Etc\n"; 87} 88else { 89 print "ok 22\n"; 90} 91 92%foo = ('blurfl','dyick','foo','bar','etc.','etc.'); 93%bar = %foo; 94print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n"; 95%bar = (); 96print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n"; 97(%bar,$a,$b) = (%foo,'how','now'); 98print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n"; 99print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n"; 100@bar{keys %foo} = values %foo; 101print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n"; 102print $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')); 105print 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')); 108print 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]); 111print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n"; 112 113$foo = join('',('a','b','c','d','e','f')[0..1]); 114print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n"; 115 116$foo = join('',('a','b','c','d','e','f')[6]); 117print $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]); 122print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n"; 123 124$foo = ('a','b','c','d','e','f')[0,2,4]; 125print $foo eq 'e' ? "ok 35\n" : "not ok 35\n"; 126 127$foo = ('a','b','c','d','e','f')[1]; 128print $foo eq 'b' ? "ok 36\n" : "not ok 36\n"; 129 130@foo = ( 'foo', 'bar', 'burbl'); 131push(foo, 'blah'); 132print $#foo == 3 ? "ok 37\n" : "not ok 37\n"; 133 134# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) 135 136$test = 37; 137sub t { ++$test; print "not " unless $_[0]; print "ok $test\n"; } 138 139@foo = @foo; 140t("@foo" eq "foo bar burbl blah"); # 38 141 142(undef,@foo) = @foo; 143t("@foo" eq "bar burbl blah"); # 39 144 145@foo = ('XXX',@foo, 'YYY'); 146t("@foo" eq "XXX bar burbl blah YYY"); # 40 147 148@foo = @foo = qw(foo b\a\r bu\\rbl blah); 149t("@foo" eq 'foo b\a\r bu\\rbl blah'); # 41 150 151@bar = @foo = qw(foo bar); # 42 152t("@foo" eq "foo bar"); 153t("@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 216my $t = 63; 217sub reify { $_[1] = ++$t; print "@_\n"; } 218reify('ok'); 219reify('ok'); 220 221# qw() is no more a runtime split, it's compiletime. 222print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; 223print "ok 66\n"; 224 225@ary = (12,23,34,45,56); 226 227print "not " unless shift(@ary) == 12; 228print "ok 67\n"; 229 230print "not " unless pop(@ary) == 56; 231print "ok 68\n"; 232 233print "not " unless push(@ary,56) == 4; 234print "ok 69\n"; 235 236print "not " unless unshift(@ary,12) == 5; 237print "ok 70\n"; 238 239sub foo { "a" } 240@foo=(foo())[0,0]; 241$foo[1] eq "a" or print "not "; 242print "ok 71\n"; 243 244# $[ should have the same effect regardless of whether the aelem 245# op is optimized to aelemfast. 246 247sub 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); 255tary(); 256 257 258require './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 263my $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; 273print "# $got\nnot " unless $got eq ''; 274print "ok 73\n"; 275