1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '.', '../lib'; 6} 7 8require 'test.pl'; 9 10plan (91); 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); 17is(join('',@ary), '12345'); 18 19$tmp = $ary[$#ary]; --$#ary; 20is($tmp, 5); 21is($#ary, 3); 22is(join('',@ary), '1234'); 23 24$[ = 1; 25@ary = (1,2,3,4,5); 26is(join('',@ary), '12345'); 27 28$tmp = $ary[$#ary]; --$#ary; 29is($tmp, 5); 30# Must do == here beacuse $[ isn't 0 31ok($#ary == 4); 32is(join('',@ary), '1234'); 33 34is($ary[5], undef); 35 36$#ary += 1; # see if element 5 gone for good 37ok($#ary == 5); 38ok(!defined $ary[5]); 39 40$[ = 0; 41@foo = (); 42$r = join(',', $#foo, @foo); 43is($r, "-1"); 44$foo[0] = '0'; 45$r = join(',', $#foo, @foo); 46is($r, "0,0"); 47$foo[2] = '2'; 48$r = join(',', $#foo, @foo); 49is($r, "2,0,,2"); 50@bar = (); 51$bar[0] = '0'; 52$bar[1] = '1'; 53$r = join(',', $#bar, @bar); 54is($r, "1,0,1"); 55@bar = (); 56$r = join(',', $#bar, @bar); 57is($r, "-1"); 58$bar[0] = '0'; 59$r = join(',', $#bar, @bar); 60is($r, "0,0"); 61$bar[2] = '2'; 62$r = join(',', $#bar, @bar); 63is($r, "2,0,,2"); 64reset 'b' if $^O ne 'VMS'; 65@bar = (); 66$bar[0] = '0'; 67$r = join(',', $#bar, @bar); 68is($r, "0,0"); 69$bar[2] = '2'; 70$r = join(',', $#bar, @bar); 71is($r, "2,0,,2"); 72 73$foo = 'now is the time'; 74ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); 75is($F1, 'now'); 76is($F2, 'is'); 77is($Etc, 'the time'); 78 79$foo = 'lskjdf'; 80ok(!($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; 85is($bar{'foo'}, 'bar'); 86%bar = (); 87is($bar{'foo'}, undef); 88(%bar,$a,$b) = (%foo,'how','now'); 89is($bar{'foo'}, 'bar'); 90is($bar{'how'}, 'now'); 91@bar{keys %foo} = values %foo; 92is($bar{'foo'}, 'bar'); 93is($bar{'how'}, 'now'); 94 95@foo = grep(/e/,split(' ','now is the time for all good men to come to')); 96is(join(' ',@foo), 'the time men come'); 97 98@foo = grep(!/e/,split(' ','now is the time for all good men to come to')); 99is(join(' ',@foo), 'now is for all good to to'); 100 101$foo = join('',('a','b','c','d','e','f')[0..5]); 102is($foo, 'abcdef'); 103 104$foo = join('',('a','b','c','d','e','f')[0..1]); 105is($foo, 'ab'); 106 107$foo = join('',('a','b','c','d','e','f')[6]); 108is($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]); 113is($foo, 'acebdf'); 114 115$foo = ('a','b','c','d','e','f')[0,2,4]; 116is($foo, 'e'); 117 118$foo = ('a','b','c','d','e','f')[1]; 119is($foo, 'b'); 120 121@foo = ( 'foo', 'bar', 'burbl'); 122push(foo, 'blah'); 123is($#foo, 3); 124 125# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) 126 127#curr_test(38); 128 129@foo = @foo; 130is("@foo", "foo bar burbl blah"); # 38 131 132(undef,@foo) = @foo; 133is("@foo", "bar burbl blah"); # 39 134 135@foo = ('XXX',@foo, 'YYY'); 136is("@foo", "XXX bar burbl blah YYY"); # 40 137 138@foo = @foo = qw(foo b\a\r bu\\rbl blah); 139is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 140 141@bar = @foo = qw(foo bar); # 42 142is("@foo", "foo bar"); 143is("@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 180 my @bee = @bee; 181 is("@bee", "foo bar burbl blah"); # 54 182 { 183 my (undef,@bee) = @bee; 184 is("@bee", "bar burbl blah"); # 55 185 { 186 my @bee = ('XXX',@bee,'YYY'); 187 is("@bee", "XXX bar burbl blah YYY"); # 56 188 { 189 my @bee = my @bee = qw(foo bar burbl blah); 190 is("@bee", "foo bar burbl blah"); # 57 191 { 192 my (@bim) = my(@bee) = qw(foo bar); 193 is("@bee", "foo bar"); # 58 194 is("@bim", "foo bar"); # 59 195 } 196 is("@bee", "foo bar burbl blah"); # 60 197 } 198 is("@bee", "XXX bar burbl blah YYY"); # 61 199 } 200 is("@bee", "bar burbl blah"); # 62 201 } 202 is("@bee", "foo bar burbl blah"); # 63 203} 204 205# make sure reification behaves 206my $t = curr_test(); 207sub reify { $_[1] = $t++; print "@_\n"; } 208reify('ok'); 209reify('ok'); 210 211curr_test($t); 212 213# qw() is no longer a runtime split, it's compiletime. 214is (qw(foo bar snorfle)[2], 'snorfle'); 215 216@ary = (12,23,34,45,56); 217 218is(shift(@ary), 12); 219is(pop(@ary), 56); 220is(push(@ary,56), 4); 221is(unshift(@ary,12), 5); 222 223sub foo { "a" } 224@foo=(foo())[0,0]; 225is ($foo[1], "a"); 226 227# $[ should have the same effect regardless of whether the aelem 228# op is optimized to aelemfast. 229 230 231 232sub tary { 233 local $[ = 10; 234 my $five = 5; 235 is ($tary[5], $tary[$five]); 236} 237 238@tary = (0..50); 239tary(); 240 241 242# bugid #15439 - clearing an array calls destructors which may try 243# to modify the array - caused 'Attempt to free unreferenced scalar' 244 245my $got = runperl ( 246 prog => q{ 247 sub X::DESTROY { @a = () } 248 @a = (bless {}, 'X'); 249 @a = (); 250 }, 251 stderr => 1 252 ); 253 254$got =~ s/\n/ /g; 255is ($got, ''); 256 257# Test negative and funky indices. 258 259 260{ 261 my @a = 0..4; 262 is($a[-1], 4); 263 is($a[-2], 3); 264 is($a[-5], 0); 265 ok(!defined $a[-6]); 266 267 is($a[2.1] , 2); 268 is($a[2.9] , 2); 269 is($a[undef], 0); 270 is($a["3rd"], 3); 271} 272 273 274{ 275 my @a; 276 eval '$a[-1] = 0'; 277 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); 278} 279 280sub test_arylen { 281 my $ref = shift; 282 local $^W = 1; 283 is ($$ref, undef, "\$# on freed array is undef"); 284 my @warn; 285 local $SIG{__WARN__} = sub {push @warn, "@_"}; 286 $$ref = 1000; 287 is (scalar @warn, 1); 288 like ($warn[0], qr/^Attempt to set length of freed array/); 289} 290 291{ 292 my $a = \$#{[]}; 293 # Need a new statement to make it go out of scope 294 test_arylen ($a); 295 test_arylen (do {my @a; \$#a}); 296} 297