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 = shift; 269 local $^W = 1; 270 is ($$ref, undef, "\$# on freed array is undef"); 271 my @warn; 272 local $SIG{__WARN__} = sub {push @warn, "@_"}; 273 $$ref = 1000; 274 is (scalar @warn, 1); 275 like ($warn[0], qr/^Attempt to set length of freed array/); 276} 277 278{ 279 my $a = \$#{[]}; 280 # Need a new statement to make it go out of scope 281 test_arylen ($a); 282 test_arylen (do {my @a; \$#a}); 283} 284 285{ 286 use vars '@array'; 287 288 my $outer = \$#array; 289 is ($$outer, -1); 290 is (scalar @array, 0); 291 292 $$outer = 3; 293 is ($$outer, 3); 294 is (scalar @array, 4); 295 296 my $ref = \@array; 297 298 my $inner; 299 { 300 local @array; 301 $inner = \$#array; 302 303 is ($$inner, -1); 304 is (scalar @array, 0); 305 $$outer = 6; 306 307 is (scalar @$ref, 7); 308 309 is ($$inner, -1); 310 is (scalar @array, 0); 311 312 $$inner = 42; 313 } 314 315 is (scalar @array, 7); 316 is ($$outer, 6); 317 318 is ($$inner, undef, "orphaned $#foo is always undef"); 319 320 is (scalar @array, 7); 321 is ($$outer, 6); 322 323 $$inner = 1; 324 325 is (scalar @array, 7); 326 is ($$outer, 6); 327 328 $$inner = 503; # Bang! 329 330 is (scalar @array, 7); 331 is ($$outer, 6); 332} 333 334{ 335 # Bug #36211 336 use vars '@array'; 337 for (1,2) { 338 { 339 local @a; 340 is ($#a, -1); 341 @a=(1..4) 342 } 343 } 344} 345 346{ 347 # Bug #37350 348 my @array = (1..4); 349 $#{@array} = 7; 350 is ($#{4}, 7); 351 352 my $x; 353 $#{$x} = 3; 354 is(scalar @$x, 4); 355 356 push @{@array}, 23; 357 is ($4[8], 23); 358} 359{ 360 # Bug #37350 -- once more with a global 361 use vars '@array'; 362 @array = (1..4); 363 $#{@array} = 7; 364 is ($#{4}, 7); 365 366 my $x; 367 $#{$x} = 3; 368 is(scalar @$x, 4); 369 370 push @{@array}, 23; 371 is ($4[8], 23); 372} 373 374# more tests for AASSIGN_COMMON 375 376{ 377 our($x,$y,$z) = (1..3); 378 our($y,$z) = ($x,$y); 379 is("$x $y $z", "1 1 2"); 380} 381{ 382 our($x,$y,$z) = (1..3); 383 (our $y, our $z) = ($x,$y); 384 is("$x $y $z", "1 1 2"); 385} 386{ 387 # AASSIGN_COMMON detection with logical operators 388 my $true = 1; 389 our($x,$y,$z) = (1..3); 390 (our $y, our $z) = $true && ($x,$y); 391 is("$x $y $z", "1 1 2"); 392} 393 394# [perl #70171] 395{ 396 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; 397 is( 398 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", 399 'bug 70171 (self-assignment via my %x = %$x)' 400 ); 401 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; 402 is( 403 "@y", "1 2 3 4", 404 'bug 70171 (self-assignment via my @x = @$x)' 405 ); 406} 407 408# [perl #70171], [perl #82110] 409{ 410 my ($i, $ra, $rh); 411 again: 412 my @a = @$ra; # common assignment on 2nd attempt 413 my %h = %$rh; # common assignment on 2nd attempt 414 @a = qw(1 2 3 4); 415 %h = qw(a 1 b 2 c 3 d 4); 416 $ra = \@a; 417 $rh = \%h; 418 goto again unless $i++; 419 420 is("@a", "1 2 3 4", 421 'bug 70171 (self-assignment via my @x = @$x) - goto variant' 422 ); 423 is( 424 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4", 425 'bug 70171 (self-assignment via my %x = %$x) - goto variant' 426 ); 427} 428 429 430*trit = *scile; $trit[0]; 431ok(1, 'aelem_fast on a nonexistent array does not crash'); 432 433# [perl #107440] 434sub A::DESTROY { $::ra = 0 } 435$::ra = [ bless [], 'A' ]; 436undef @$::ra; 437pass 'no crash when freeing array that is being undeffed'; 438$::ra = [ bless [], 'A' ]; 439@$::ra = ('a'..'z'); 440pass 'no crash when freeing array that is being cleared'; 441 442# [perl #85670] Copying magic to elements 443package glelp { 444 no warnings 'experimental::builtin'; 445 use builtin 'weaken'; 446 weaken ($a = \@ISA); 447 @ISA = qw(Foo); 448 weaken ($a = \$ISA[0]); 449 ::is @ISA, 1, 'backref magic is not copied to elements'; 450} 451package peen { 452 $#ISA = -1; 453 @ISA = qw(Foo); 454 $ISA[0] = qw(Sphare); 455 456 sub Sphare::pling { 'pling' } 457 458 ::is eval { pling peen }, 'pling', 459 'arylen_p magic does not stop isa magic from being copied'; 460} 461 462# Test that &PL_sv_undef is not special in arrays 463sub { 464 ok exists $_[0], 465 'exists returns true for &PL_sv_undef elem [perl #7508]'; 466 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]'; 467}->(undef); 468# and that padav also knows how to handle the resulting NULLs 469@_ = sub { my @a; $a[1]=1; @a }->(); 470is join (" ", map $_//"undef", @_), "undef 1", 471 'returning my @a with nonexistent elements'; 472 473# [perl #118691] 474@plink=@plunk=(); 475$plink[3] = 1; 476sub { 477 $_[0] = 2; 478 is $plink[0], 2, '@_ alias to nonexistent elem within array'; 479 $_[1] = 3; 480 is $plink[1], 3, '@_ alias to nonexistent neg index within array'; 481 is $_[2], undef, 'reading alias to negative index past beginning'; 482 eval { $_[2] = 42 }; 483 like $@, qr/Modification of non-creatable array value attempted, (?x: 484 )subscript -5/, 485 'error when setting alias to negative index past beginning'; 486 is $_[3], undef, 'reading alias to -1 elem of empty array'; 487 eval { $_[3] = 42 }; 488 like $@, qr/Modification of non-creatable array value attempted, (?x: 489 )subscript -1/, 490 'error when setting alias to -1 elem of empty array'; 491}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]); 492 493$_ = \$#{[]}; 494$$_ = \1; 495"$$_"; 496pass "no assertion failure after assigning ref to arylen when ary is gone"; 497 498 499{ 500 # Test aelemfast for both +ve and -ve indices, both lex and package vars. 501 # Make especially careful that we don't have any edge cases around 502 # fitting an I8 into a U8. 503 my @a = (0..299); 504 is($a[-256], 300-256, 'lex -256'); 505 is($a[-255], 300-255, 'lex -255'); 506 is($a[-254], 300-254, 'lex -254'); 507 is($a[-129], 300-129, 'lex -129'); 508 is($a[-128], 300-128, 'lex -128'); 509 is($a[-127], 300-127, 'lex -127'); 510 is($a[-126], 300-126, 'lex -126'); 511 is($a[ -1], 300- 1, 'lex -1'); 512 is($a[ 0], 0, 'lex 0'); 513 is($a[ 1], 1, 'lex 1'); 514 is($a[ 126], 126, 'lex 126'); 515 is($a[ 127], 127, 'lex 127'); 516 is($a[ 128], 128, 'lex 128'); 517 is($a[ 129], 129, 'lex 129'); 518 is($a[ 254], 254, 'lex 254'); 519 is($a[ 255], 255, 'lex 255'); 520 is($a[ 256], 256, 'lex 256'); 521 @aelem =(0..299); 522 is($aelem[-256], 300-256, 'pkg -256'); 523 is($aelem[-255], 300-255, 'pkg -255'); 524 is($aelem[-254], 300-254, 'pkg -254'); 525 is($aelem[-129], 300-129, 'pkg -129'); 526 is($aelem[-128], 300-128, 'pkg -128'); 527 is($aelem[-127], 300-127, 'pkg -127'); 528 is($aelem[-126], 300-126, 'pkg -126'); 529 is($aelem[ -1], 300- 1, 'pkg -1'); 530 is($aelem[ 0], 0, 'pkg 0'); 531 is($aelem[ 1], 1, 'pkg 1'); 532 is($aelem[ 126], 126, 'pkg 126'); 533 is($aelem[ 127], 127, 'pkg 127'); 534 is($aelem[ 128], 128, 'pkg 128'); 535 is($aelem[ 129], 129, 'pkg 129'); 536 is($aelem[ 254], 254, 'pkg 254'); 537 is($aelem[ 255], 255, 'pkg 255'); 538 is($aelem[ 256], 256, 'pkg 256'); 539} 540 541# Test aelemfast in list assignment 542@ary = ('a','b'); 543($ary[0],$ary[1]) = ($ary[1],$ary[0]); 544is "@ary", 'b a', 545 'aelemfast with the same array on both sides of list assignment'; 546 547for(scalar $#foo) { $_ = 3 } 548is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)'; 549 550{ 551 my @a = qw(a b c); 552 @a = @a; 553 is "@a", 'a b c', 'assigning to itself'; 554} 555 556sub { undef *_; shift }->(); # This would crash; no ok() necessary. 557sub { undef *_; pop }->(); 558 559# [perl #129164], [perl #129166], [perl #129167] 560# splice() with null array entries 561# These used to crash. 562$#a = -1; $#a++; 563() = 0-splice @a; # subtract 564$#a = -1; $#a++; 565() = -splice @a; # negate 566$#a = -1; $#a++; 567() = 0+splice @a; # add 568# And with array expansion, too 569$#a = -1; $#a++; 570() = 0-splice @a, 0, 1, 1, 1; 571$#a = -1; $#a++; 572() = -splice @a, 0, 1, 1, 1; 573$#a = -1; $#a++; 574() = 0+splice @a, 0, 1, 1, 1; 575 576# [perl #8910] lazy creation of array elements used to leak out 577{ 578 sub t8910 { $_[1] = 5; $_[2] = 7; } 579 my @p; 580 $p[0] = 1; 581 $p[2] = 2; 582 t8910(@p); 583 is "@p", "1 5 7", "lazy element creation with sub call"; 584 my @q; 585 @q[0] = 1; 586 @q[2] = 2; 587 my @qr = \(@q); 588 is $qr[$_], \$q[$_], "lazy element creation with refgen" foreach 0..2; 589 isnt $qr[1], \undef, "lazy element creation with refgen"; 590 my @r; 591 $r[1] = 1; 592 foreach my $re ((), @r) { $re = 5; } 593 is join("", @r), "55", "lazy element creation with foreach"; 594} 595 596{ # Some things broken by the initial fix for #8910 597 (\my @a)->$#*++; 598 my @b = @a; 599 ok !exists $a[0], 'copying an array via = does not vivify elements'; 600 delete $a[0]; 601 @a[1..5] = 1..5; 602 $#a++; 603 my $count; 604 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 605 is join(",", @existing_elements), "1,2,3,4,5", 606 'map {} @a does not vivify elements'; 607 $#a = -1; 608 {local $a[3] = 12; my @foo=@a}; 609 is @a, 0,'unwinding localization of elem past end of array shrinks it'; 610 611 # Again, but with a package array 612 package tmp; (\our @a)->$#*++; package main; 613 my @b = @a; 614 ok !exists $a[0], 'copying an array via = does not vivify elements'; 615 delete $a[0]; 616 @a[1..5] = 1..5; 617 $#a++; 618 my $count; 619 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 620 is join(",", @existing_elements), "1,2,3,4,5", 621 'map {} @a does not vivify elements'; 622 $#a = -1; 623 {local $a[3] = 12; my @foo=@a}; 624 is @a, 0,'unwinding localization of elem past end of array shrinks it'; 625} 626{ 627 # Again, but with a non-magical array ($#a makes it magical) 628 my @a = 1; 629 delete $a[0]; 630 my @b = @a; 631 ok !exists $a[0], 'copying an array via = does not vivify elements'; 632 delete $a[0]; 633 @a[1..5] = 1..5; 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 = (); 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# perl #132729, as it applies to flattening an array in lvalue context 644{ 645 my @a; 646 $a[1] = 1; 647 map { unshift @a, 7; $_ = 3; goto aftermap; } @a; 648 aftermap: 649 is "[@a]", "[7 3 1]", 650 'non-elems read from @a do not lose their position'; 651 @a = (); 652 $#a++; # make it magical 653 $a[1] = 1; 654 map { unshift @a, 7; $_ = 3; goto aftermath; } @a; 655 aftermath: 656 is "[@a]", "[7 3 1]", 657 'non-elems read from magical @a do not lose their position'; 658} 659# perl #132729, as it applies to ‘holes’ in an array passed to a sub 660# individually 661{ 662 my @a; 663 $a[1] = 1; 664 sub { unshift @a, 7; $_[0] = 3; }->($a[0]); 665 is "[@a]", "[7 3 1]", 666 'holes passed to sub do not lose their position (multideref)'; 667 @a = (); 668 $#a++; # make it magical 669 $a[1] = 1; 670 sub { unshift @a, 7; $_[0] = 3; }->($a[0]); 671 is "[@a]", "[7 3 1]", 672 'holes passed to sub do not lose their position (multideref, mg)'; 673} 674{ 675 # Again, with aelem, not multideref 676 my @a; 677 $a[1] = 1; 678 sub { unshift @a, 7; $_[0] = 3; }->($a[${\0}]); 679 is "[@a]", "[7 3 1]", 680 'holes passed to sub do not lose their position (aelem)'; 681 @a = (); 682 $#a++; # make it magical 683 $a[1] = 1; 684 sub { unshift @a, 7; $_[0] = 3; }->($a[${\0}]); 685 is "[@a]", "[7 3 1]", 686 'holes passed to sub do not lose their position (aelem, mg)'; 687} 688 689# GH #21235 690fresh_perl_is('my @x;$x[0] = 1;shift @x;$x[22] = 1;$x[25] = 1;','', 691 {}, 'unshifting and growing an array initializes trailing elements'); 692 693"We're included by lib/Tie/Array/std.t so we need to return something true"; 694