1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = ('.', '../lib'); 6} 7 8require 'test.pl'; 9 10plan (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); 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 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 228my $t = curr_test(); 229sub reify { $_[1] = $t++; print "@_\n"; } 230reify('ok'); 231reify('ok'); 232 233curr_test($t); 234 235# qw() is no longer a runtime split, it's compiletime. 236is (qw(foo bar snorfle)[2], 'snorfle'); 237 238@ary = (12,23,34,45,56); 239 240is(shift(@ary), 12); 241is(pop(@ary), 56); 242is(push(@ary,56), 4); 243is(unshift(@ary,12), 5); 244 245sub foo { "a" } 246@foo=(foo())[0,0]; 247is ($foo[1], "a"); 248 249# $[ should have the same effect regardless of whether the aelem 250# op is optimized to aelemfast. 251 252 253 254sub tary { 255 local $[ = 10; 256 my $five = 5; 257 is ($tary[5], $tary[$five]); 258} 259 260@tary = (0..50); 261tary(); 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 267my $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; 277is ($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 302sub 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"; 424