1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('.', '../lib'); 7} 8 9plan (195); 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); 16is(join('',@ary), '12345'); 17 18$tmp = $ary[$#ary]; --$#ary; 19is($tmp, 5); 20is($#ary, 3); 21is(join('',@ary), '1234'); 22 23@foo = (); 24$r = join(',', $#foo, @foo); 25is($r, "-1"); 26$foo[0] = '0'; 27$r = join(',', $#foo, @foo); 28is($r, "0,0"); 29$foo[2] = '2'; 30$r = join(',', $#foo, @foo); 31is($r, "2,0,,2"); 32@bar = (); 33$bar[0] = '0'; 34$bar[1] = '1'; 35$r = join(',', $#bar, @bar); 36is($r, "1,0,1"); 37@bar = (); 38$r = join(',', $#bar, @bar); 39is($r, "-1"); 40$bar[0] = '0'; 41$r = join(',', $#bar, @bar); 42is($r, "0,0"); 43$bar[2] = '2'; 44$r = join(',', $#bar, @bar); 45is($r, "2,0,,2"); 46reset 'b' if $^O ne 'VMS'; 47@bar = (); 48$bar[0] = '0'; 49$r = join(',', $#bar, @bar); 50is($r, "0,0"); 51$bar[2] = '2'; 52$r = join(',', $#bar, @bar); 53is($r, "2,0,,2"); 54 55$foo = 'now is the time'; 56ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); 57is($F1, 'now'); 58is($F2, 'is'); 59is($Etc, 'the time'); 60 61$foo = 'lskjdf'; 62ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) 63 or diag("$cnt $F1:$F2:$Etc"); 64 65%foo = ('blurfl','dyick','foo','bar','etc.','etc.'); 66%bar = %foo; 67is($bar{'foo'}, 'bar'); 68%bar = (); 69is($bar{'foo'}, undef); 70(%bar,$a,$b) = (%foo,'how','now'); 71is($bar{'foo'}, 'bar'); 72is($bar{'how'}, 'now'); 73@bar{keys %foo} = values %foo; 74is($bar{'foo'}, 'bar'); 75is($bar{'how'}, 'now'); 76 77@foo = grep(/e/,split(' ','now is the time for all good men to come to')); 78is(join(' ',@foo), 'the time men come'); 79 80@foo = grep(!/e/,split(' ','now is the time for all good men to come to')); 81is(join(' ',@foo), 'now is for all good to to'); 82 83$foo = join('',('a','b','c','d','e','f')[0..5]); 84is($foo, 'abcdef'); 85 86$foo = join('',('a','b','c','d','e','f')[0..1]); 87is($foo, 'ab'); 88 89$foo = join('',('a','b','c','d','e','f')[6]); 90is($foo, ''); 91 92@foo = ('a','b','c','d','e','f')[0,2,4]; 93@bar = ('a','b','c','d','e','f')[1,3,5]; 94$foo = join('',(@foo,@bar)[0..5]); 95is($foo, 'acebdf'); 96 97$foo = ('a','b','c','d','e','f')[0,2,4]; 98is($foo, 'e'); 99 100$foo = ('a','b','c','d','e','f')[1]; 101is($foo, 'b'); 102 103@foo = ( 'foo', 'bar', 'burbl', 'blah'); 104 105# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) 106 107#curr_test(37); 108 109@foo = @foo; 110is("@foo", "foo bar burbl blah"); # 37 111 112(undef,@foo) = @foo; 113is("@foo", "bar burbl blah"); # 38 114 115@foo = ('XXX',@foo, 'YYY'); 116is("@foo", "XXX bar burbl blah YYY"); # 39 117 118@foo = @foo = qw(foo b\a\r bu\\rbl blah); 119is("@foo", 'foo b\a\r bu\\rbl blah'); # 40 120 121@bar = @foo = qw(foo bar); # 41 122is("@foo", "foo bar"); 123is("@bar", "foo bar"); # 42 124 125# try the same with local 126# XXX tie-stdarray fails the tests involving local, so we use 127# different variable names to escape the 'tie' 128 129@bee = ( 'foo', 'bar', 'burbl', 'blah'); 130{ 131 132 local @bee = @bee; 133 is("@bee", "foo bar burbl blah"); # 43 134 { 135 local (undef,@bee) = @bee; 136 is("@bee", "bar burbl blah"); # 44 137 { 138 local @bee = ('XXX',@bee,'YYY'); 139 is("@bee", "XXX bar burbl blah YYY"); # 45 140 { 141 local @bee = local(@bee) = qw(foo bar burbl blah); 142 is("@bee", "foo bar burbl blah"); # 46 143 { 144 local (@bim) = local(@bee) = qw(foo bar); 145 is("@bee", "foo bar"); # 47 146 is("@bim", "foo bar"); # 48 147 } 148 is("@bee", "foo bar burbl blah"); # 49 149 } 150 is("@bee", "XXX bar burbl blah YYY"); # 50 151 } 152 is("@bee", "bar burbl blah"); # 51 153 } 154 is("@bee", "foo bar burbl blah"); # 52 155} 156 157# try the same with my 158{ 159 my @bee = @bee; 160 is("@bee", "foo bar burbl blah"); # 53 161 { 162 my (undef,@bee) = @bee; 163 is("@bee", "bar burbl blah"); # 54 164 { 165 my @bee = ('XXX',@bee,'YYY'); 166 is("@bee", "XXX bar burbl blah YYY"); # 55 167 { 168 my @bee = my @bee = qw(foo bar burbl blah); 169 is("@bee", "foo bar burbl blah"); # 56 170 { 171 my (@bim) = my(@bee) = qw(foo bar); 172 is("@bee", "foo bar"); # 57 173 is("@bim", "foo bar"); # 58 174 } 175 is("@bee", "foo bar burbl blah"); # 59 176 } 177 is("@bee", "XXX bar burbl blah YYY"); # 60 178 } 179 is("@bee", "bar burbl blah"); # 61 180 } 181 is("@bee", "foo bar burbl blah"); # 62 182} 183 184# try the same with our (except that previous values aren't restored) 185{ 186 our @bee = @bee; 187 is("@bee", "foo bar burbl blah"); 188 { 189 our (undef,@bee) = @bee; 190 is("@bee", "bar burbl blah"); 191 { 192 our @bee = ('XXX',@bee,'YYY'); 193 is("@bee", "XXX bar burbl blah YYY"); 194 { 195 our @bee = our @bee = qw(foo bar burbl blah); 196 is("@bee", "foo bar burbl blah"); 197 { 198 our (@bim) = our(@bee) = qw(foo bar); 199 is("@bee", "foo bar"); 200 is("@bim", "foo bar"); 201 } 202 } 203 } 204 } 205} 206 207# make sure reification behaves 208my $t = curr_test(); 209sub reify { $_[1] = $t++; print "@_\n"; } 210reify('ok'); 211reify('ok'); 212 213curr_test($t); 214 215# qw() is no longer a runtime split, it's compiletime. 216is (qw(foo bar snorfle)[2], 'snorfle'); 217 218@ary = (12,23,34,45,56); 219 220is(shift(@ary), 12); 221is(pop(@ary), 56); 222is(push(@ary,56), 4); 223is(unshift(@ary,12), 5); 224 225sub foo { "a" } 226@foo=(foo())[0,0]; 227is ($foo[1], "a"); 228 229# bugid #15439 - clearing an array calls destructors which may try 230# to modify the array - caused 'Attempt to free unreferenced scalar' 231 232my $got = runperl ( 233 prog => q{ 234 sub X::DESTROY { @a = () } 235 @a = (bless {}, q{X}); 236 @a = (); 237 }, 238 stderr => 1 239 ); 240 241$got =~ s/\n/ /g; 242is ($got, ''); 243 244# Test negative and funky indices. 245 246 247{ 248 my @a = 0..4; 249 is($a[-1], 4); 250 is($a[-2], 3); 251 is($a[-5], 0); 252 ok(!defined $a[-6]); 253 254 is($a[2.1] , 2); 255 is($a[2.9] , 2); 256 is($a[undef], 0); 257 is($a["3rd"], 3); 258} 259 260 261{ 262 my @a; 263 eval '$a[-1] = 0'; 264 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); 265} 266 267sub test_arylen { 268 my ($ref, $fixed, $desc) = @_; 269 local $^W = 1; 270 # on RC builds, the temp [] array isn't prematurely freed: 271 # the \$# magic var keeps it alive. 272 my $is_rc = $fixed && (Internals::stack_refcounted() & 1); 273 is ($$ref, ($is_rc ? - 1 : undef), "$desc: \$# on freed array is undef"); 274 my @warn; 275 local $SIG{__WARN__} = sub {push @warn, "@_"}; 276 $$ref = 1000; 277 is (scalar @warn, ($is_rc ? 0 : 1), "$desc: number of warnings"); 278 if ($is_rc) { 279 pass("$desc: pass"); 280 } 281 else { 282 like ($warn[0], qr/^Attempt to set length of freed array/, "$desc: msg"); 283 } 284} 285 286{ 287 my $a = \$#{[]}; 288 # Need a new statement to make it go out of scope 289 test_arylen ($a, 1, "\$a"); 290 test_arylen (do {my @a; \$#a}, 0, "do {}"); 291} 292 293{ 294 use vars '@array'; 295 296 my $outer = \$#array; 297 is ($$outer, -1); 298 is (scalar @array, 0); 299 300 $$outer = 3; 301 is ($$outer, 3); 302 is (scalar @array, 4); 303 304 my $ref = \@array; 305 306 my $inner; 307 { 308 local @array; 309 $inner = \$#array; 310 311 is ($$inner, -1); 312 is (scalar @array, 0); 313 $$outer = 6; 314 315 is (scalar @$ref, 7); 316 317 is ($$inner, -1); 318 is (scalar @array, 0); 319 320 $$inner = 42; 321 } 322 323 is (scalar @array, 7); 324 is ($$outer, 6); 325 326 is ($$inner, undef, "orphaned $#foo is always undef"); 327 328 is (scalar @array, 7); 329 is ($$outer, 6); 330 331 $$inner = 1; 332 333 is (scalar @array, 7); 334 is ($$outer, 6); 335 336 $$inner = 503; # Bang! 337 338 is (scalar @array, 7); 339 is ($$outer, 6); 340} 341 342{ 343 # Bug #36211 344 use vars '@array'; 345 for (1,2) { 346 { 347 local @a; 348 is ($#a, -1); 349 @a=(1..4) 350 } 351 } 352} 353 354{ 355 # Bug #37350 356 my @array = (1..4); 357 $#{@array} = 7; 358 is ($#{4}, 7); 359 360 my $x; 361 $#{$x} = 3; 362 is(scalar @$x, 4); 363 364 push @{@array}, 23; 365 is ($4[8], 23); 366} 367{ 368 # Bug #37350 -- once more with a global 369 use vars '@array'; 370 @array = (1..4); 371 $#{@array} = 7; 372 is ($#{4}, 7); 373 374 my $x; 375 $#{$x} = 3; 376 is(scalar @$x, 4); 377 378 push @{@array}, 23; 379 is ($4[8], 23); 380} 381 382# more tests for AASSIGN_COMMON 383 384{ 385 our($x,$y,$z) = (1..3); 386 our($y,$z) = ($x,$y); 387 is("$x $y $z", "1 1 2"); 388} 389{ 390 our($x,$y,$z) = (1..3); 391 (our $y, our $z) = ($x,$y); 392 is("$x $y $z", "1 1 2"); 393} 394{ 395 # AASSIGN_COMMON detection with logical operators 396 my $true = 1; 397 our($x,$y,$z) = (1..3); 398 (our $y, our $z) = $true && ($x,$y); 399 is("$x $y $z", "1 1 2"); 400} 401 402# [perl #70171] 403{ 404 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; 405 is( 406 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", 407 'bug 70171 (self-assignment via my %x = %$x)' 408 ); 409 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; 410 is( 411 "@y", "1 2 3 4", 412 'bug 70171 (self-assignment via my @x = @$x)' 413 ); 414} 415 416# [perl #70171], [perl #82110] 417{ 418 my ($i, $ra, $rh); 419 again: 420 my @a = @$ra; # common assignment on 2nd attempt 421 my %h = %$rh; # common assignment on 2nd attempt 422 @a = qw(1 2 3 4); 423 %h = qw(a 1 b 2 c 3 d 4); 424 $ra = \@a; 425 $rh = \%h; 426 goto again unless $i++; 427 428 is("@a", "1 2 3 4", 429 'bug 70171 (self-assignment via my @x = @$x) - goto variant' 430 ); 431 is( 432 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4", 433 'bug 70171 (self-assignment via my %x = %$x) - goto variant' 434 ); 435} 436 437 438*trit = *scile; $trit[0]; 439ok(1, 'aelem_fast on a nonexistent array does not crash'); 440 441# [perl #107440] 442sub A::DESTROY { $::ra = 0 } 443$::ra = [ bless [], 'A' ]; 444undef @$::ra; 445pass 'no crash when freeing array that is being undeffed'; 446$::ra = [ bless [], 'A' ]; 447@$::ra = ('a'..'z'); 448pass 'no crash when freeing array that is being cleared'; 449 450# [perl #85670] Copying magic to elements 451package glelp { 452 no warnings 'experimental::builtin'; 453 use builtin 'weaken'; 454 weaken ($a = \@ISA); 455 @ISA = qw(Foo); 456 weaken ($a = \$ISA[0]); 457 ::is @ISA, 1, 'backref magic is not copied to elements'; 458} 459package peen { 460 $#ISA = -1; 461 @ISA = qw(Foo); 462 $ISA[0] = qw(Sphare); 463 464 sub Sphare::pling { 'pling' } 465 466 ::is eval { pling peen }, 'pling', 467 'arylen_p magic does not stop isa magic from being copied'; 468} 469 470# Test that &PL_sv_undef is not special in arrays 471sub { 472 ok exists $_[0], 473 'exists returns true for &PL_sv_undef elem [perl #7508]'; 474 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]'; 475}->(undef); 476# and that padav also knows how to handle the resulting NULLs 477@_ = sub { my @a; $a[1]=1; @a }->(); 478is join (" ", map $_//"undef", @_), "undef 1", 479 'returning my @a with nonexistent elements'; 480 481# [perl #118691] 482@plink=@plunk=(); 483$plink[3] = 1; 484sub { 485 $_[0] = 2; 486 is $plink[0], 2, '@_ alias to nonexistent elem within array'; 487 $_[1] = 3; 488 is $plink[1], 3, '@_ alias to nonexistent neg index within array'; 489 is $_[2], undef, 'reading alias to negative index past beginning'; 490 eval { $_[2] = 42 }; 491 like $@, qr/Modification of non-creatable array value attempted, (?x: 492 )subscript -5/, 493 'error when setting alias to negative index past beginning'; 494 is $_[3], undef, 'reading alias to -1 elem of empty array'; 495 eval { $_[3] = 42 }; 496 like $@, qr/Modification of non-creatable array value attempted, (?x: 497 )subscript -1/, 498 'error when setting alias to -1 elem of empty array'; 499}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]); 500 501unless (Internals::stack_refcounted() & 1) { 502 # Skip this test on RC stack builds. The test assumes that the temp 503 # array has been freed - and so it is just checking that the code 504 # doesn't crash. But on RC builds the array (correctly) lives on while 505 # the arylen magic var lives. The assignment ends up using the address 506 # of \1 as a random number to set the array length to, which can use 507 # lots of memory! 508 $_ = \$#{[]}; 509 $$_ = \1; 510 "$$_"; 511} 512pass "no assertion failure after assigning ref to arylen when ary is gone"; 513 514 515{ 516 # Test aelemfast for both +ve and -ve indices, both lex and package vars. 517 # Make especially careful that we don't have any edge cases around 518 # fitting an I8 into a U8. 519 my @a = (0..299); 520 is($a[-256], 300-256, 'lex -256'); 521 is($a[-255], 300-255, 'lex -255'); 522 is($a[-254], 300-254, 'lex -254'); 523 is($a[-129], 300-129, 'lex -129'); 524 is($a[-128], 300-128, 'lex -128'); 525 is($a[-127], 300-127, 'lex -127'); 526 is($a[-126], 300-126, 'lex -126'); 527 is($a[ -1], 300- 1, 'lex -1'); 528 is($a[ 0], 0, 'lex 0'); 529 is($a[ 1], 1, 'lex 1'); 530 is($a[ 126], 126, 'lex 126'); 531 is($a[ 127], 127, 'lex 127'); 532 is($a[ 128], 128, 'lex 128'); 533 is($a[ 129], 129, 'lex 129'); 534 is($a[ 254], 254, 'lex 254'); 535 is($a[ 255], 255, 'lex 255'); 536 is($a[ 256], 256, 'lex 256'); 537 @aelem =(0..299); 538 is($aelem[-256], 300-256, 'pkg -256'); 539 is($aelem[-255], 300-255, 'pkg -255'); 540 is($aelem[-254], 300-254, 'pkg -254'); 541 is($aelem[-129], 300-129, 'pkg -129'); 542 is($aelem[-128], 300-128, 'pkg -128'); 543 is($aelem[-127], 300-127, 'pkg -127'); 544 is($aelem[-126], 300-126, 'pkg -126'); 545 is($aelem[ -1], 300- 1, 'pkg -1'); 546 is($aelem[ 0], 0, 'pkg 0'); 547 is($aelem[ 1], 1, 'pkg 1'); 548 is($aelem[ 126], 126, 'pkg 126'); 549 is($aelem[ 127], 127, 'pkg 127'); 550 is($aelem[ 128], 128, 'pkg 128'); 551 is($aelem[ 129], 129, 'pkg 129'); 552 is($aelem[ 254], 254, 'pkg 254'); 553 is($aelem[ 255], 255, 'pkg 255'); 554 is($aelem[ 256], 256, 'pkg 256'); 555} 556 557# Test aelemfast in list assignment 558@ary = ('a','b'); 559($ary[0],$ary[1]) = ($ary[1],$ary[0]); 560is "@ary", 'b a', 561 'aelemfast with the same array on both sides of list assignment'; 562 563for(scalar $#foo) { $_ = 3 } 564is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)'; 565 566{ 567 my @a = qw(a b c); 568 @a = @a; 569 is "@a", 'a b c', 'assigning to itself'; 570} 571 572sub { undef *_; shift }->(); # This would crash; no ok() necessary. 573sub { undef *_; pop }->(); 574 575# [perl #129164], [perl #129166], [perl #129167] 576# splice() with null array entries 577# These used to crash. 578$#a = -1; $#a++; 579() = 0-splice @a; # subtract 580$#a = -1; $#a++; 581() = -splice @a; # negate 582$#a = -1; $#a++; 583() = 0+splice @a; # add 584# And with array expansion, too 585$#a = -1; $#a++; 586() = 0-splice @a, 0, 1, 1, 1; 587$#a = -1; $#a++; 588() = -splice @a, 0, 1, 1, 1; 589$#a = -1; $#a++; 590() = 0+splice @a, 0, 1, 1, 1; 591 592# [perl #8910] lazy creation of array elements used to leak out 593{ 594 sub t8910 { $_[1] = 5; $_[2] = 7; } 595 my @p; 596 $p[0] = 1; 597 $p[2] = 2; 598 t8910(@p); 599 is "@p", "1 5 7", "lazy element creation with sub call"; 600 my @q; 601 @q[0] = 1; 602 @q[2] = 2; 603 my @qr = \(@q); 604 is $qr[$_], \$q[$_], "lazy element creation with refgen" foreach 0..2; 605 isnt $qr[1], \undef, "lazy element creation with refgen"; 606 my @r; 607 $r[1] = 1; 608 foreach my $re ((), @r) { $re = 5; } 609 is join("", @r), "55", "lazy element creation with foreach"; 610} 611 612{ # Some things broken by the initial fix for #8910 613 (\my @a)->$#*++; 614 my @b = @a; 615 ok !exists $a[0], 'copying an array via = does not vivify elements'; 616 delete $a[0]; 617 @a[1..5] = 1..5; 618 $#a++; 619 my $count; 620 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 621 is join(",", @existing_elements), "1,2,3,4,5", 622 'map {} @a does not vivify elements'; 623 $#a = -1; 624 {local $a[3] = 12; my @foo=@a}; 625 is @a, 0,'unwinding localization of elem past end of array shrinks it'; 626 627 # Again, but with a package array 628 package tmp; (\our @a)->$#*++; package main; 629 my @b = @a; 630 ok !exists $a[0], 'copying an array via = does not vivify elements'; 631 delete $a[0]; 632 @a[1..5] = 1..5; 633 $#a++; 634 my $count; 635 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 636 is join(",", @existing_elements), "1,2,3,4,5", 637 'map {} @a does not vivify elements'; 638 $#a = -1; 639 {local $a[3] = 12; my @foo=@a}; 640 is @a, 0,'unwinding localization of elem past end of array shrinks it'; 641} 642{ 643 # Again, but with a non-magical array ($#a makes it magical) 644 my @a = 1; 645 delete $a[0]; 646 my @b = @a; 647 ok !exists $a[0], 'copying an array via = does not vivify elements'; 648 delete $a[0]; 649 @a[1..5] = 1..5; 650 my $count; 651 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 652 is join(",", @existing_elements), "1,2,3,4,5", 653 'map {} @a does not vivify elements'; 654 @a = (); 655 {local $a[3] = 12; my @foo=@a}; 656 is @a, 0, 'unwinding localization of elem past end of array shrinks it' 657} 658 659# perl #132729, as it applies to flattening an array in lvalue context 660{ 661 my @a; 662 $a[1] = 1; 663 map { unshift @a, 7; $_ = 3; goto aftermap; } @a; 664 aftermap: 665 is "[@a]", "[7 3 1]", 666 'non-elems read from @a do not lose their position'; 667 @a = (); 668 $#a++; # make it magical 669 $a[1] = 1; 670 map { unshift @a, 7; $_ = 3; goto aftermath; } @a; 671 aftermath: 672 is "[@a]", "[7 3 1]", 673 'non-elems read from magical @a do not lose their position'; 674} 675# perl #132729, as it applies to ‘holes’ in an array passed to a sub 676# individually 677{ 678 my @a; 679 $a[1] = 1; 680 sub { unshift @a, 7; $_[0] = 3; }->($a[0]); 681 is "[@a]", "[7 3 1]", 682 'holes passed to sub do not lose their position (multideref)'; 683 @a = (); 684 $#a++; # make it magical 685 $a[1] = 1; 686 sub { unshift @a, 7; $_[0] = 3; }->($a[0]); 687 is "[@a]", "[7 3 1]", 688 'holes passed to sub do not lose their position (multideref, mg)'; 689} 690{ 691 # Again, with aelem, not multideref 692 my @a; 693 $a[1] = 1; 694 sub { unshift @a, 7; $_[0] = 3; }->($a[${\0}]); 695 is "[@a]", "[7 3 1]", 696 'holes passed to sub do not lose their position (aelem)'; 697 @a = (); 698 $#a++; # make it magical 699 $a[1] = 1; 700 sub { unshift @a, 7; $_[0] = 3; }->($a[${\0}]); 701 is "[@a]", "[7 3 1]", 702 'holes passed to sub do not lose their position (aelem, mg)'; 703} 704 705# GH #21235 706fresh_perl_is('my @x;$x[0] = 1;shift @x;$x[22] = 1;$x[25] = 1;','', 707 {}, 'unshifting and growing an array initializes trailing elements'); 708 709"We're included by lib/Tie/Array/std.t so we need to return something true"; 710