1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('.', '../lib'); 7} 8 9plan (194); 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 443SKIP: { 444 skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl; 445 require Scalar::Util; 446 package glelp { 447 Scalar::Util::weaken ($a = \@ISA); 448 @ISA = qw(Foo); 449 Scalar::Util::weaken ($a = \$ISA[0]); 450 ::is @ISA, 1, 'backref magic is not copied to elements'; 451 } 452} 453package peen { 454 $#ISA = -1; 455 @ISA = qw(Foo); 456 $ISA[0] = qw(Sphare); 457 458 sub Sphare::pling { 'pling' } 459 460 ::is eval { pling peen }, 'pling', 461 'arylen_p magic does not stop isa magic from being copied'; 462} 463 464# Test that &PL_sv_undef is not special in arrays 465sub { 466 ok exists $_[0], 467 'exists returns true for &PL_sv_undef elem [perl #7508]'; 468 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]'; 469}->(undef); 470# and that padav also knows how to handle the resulting NULLs 471@_ = sub { my @a; $a[1]=1; @a }->(); 472is join (" ", map $_//"undef", @_), "undef 1", 473 'returning my @a with nonexistent elements'; 474 475# [perl #118691] 476@plink=@plunk=(); 477$plink[3] = 1; 478sub { 479 $_[0] = 2; 480 is $plink[0], 2, '@_ alias to nonexistent elem within array'; 481 $_[1] = 3; 482 is $plink[1], 3, '@_ alias to nonexistent neg index within array'; 483 is $_[2], undef, 'reading alias to negative index past beginning'; 484 eval { $_[2] = 42 }; 485 like $@, qr/Modification of non-creatable array value attempted, (?x: 486 )subscript -5/, 487 'error when setting alias to negative index past beginning'; 488 is $_[3], undef, 'reading alias to -1 elem of empty array'; 489 eval { $_[3] = 42 }; 490 like $@, qr/Modification of non-creatable array value attempted, (?x: 491 )subscript -1/, 492 'error when setting alias to -1 elem of empty array'; 493}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]); 494 495$_ = \$#{[]}; 496$$_ = \1; 497"$$_"; 498pass "no assertion failure after assigning ref to arylen when ary is gone"; 499 500 501{ 502 # Test aelemfast for both +ve and -ve indices, both lex and package vars. 503 # Make especially careful that we don't have any edge cases around 504 # fitting an I8 into a U8. 505 my @a = (0..299); 506 is($a[-256], 300-256, 'lex -256'); 507 is($a[-255], 300-255, 'lex -255'); 508 is($a[-254], 300-254, 'lex -254'); 509 is($a[-129], 300-129, 'lex -129'); 510 is($a[-128], 300-128, 'lex -128'); 511 is($a[-127], 300-127, 'lex -127'); 512 is($a[-126], 300-126, 'lex -126'); 513 is($a[ -1], 300- 1, 'lex -1'); 514 is($a[ 0], 0, 'lex 0'); 515 is($a[ 1], 1, 'lex 1'); 516 is($a[ 126], 126, 'lex 126'); 517 is($a[ 127], 127, 'lex 127'); 518 is($a[ 128], 128, 'lex 128'); 519 is($a[ 129], 129, 'lex 129'); 520 is($a[ 254], 254, 'lex 254'); 521 is($a[ 255], 255, 'lex 255'); 522 is($a[ 256], 256, 'lex 256'); 523 @aelem =(0..299); 524 is($aelem[-256], 300-256, 'pkg -256'); 525 is($aelem[-255], 300-255, 'pkg -255'); 526 is($aelem[-254], 300-254, 'pkg -254'); 527 is($aelem[-129], 300-129, 'pkg -129'); 528 is($aelem[-128], 300-128, 'pkg -128'); 529 is($aelem[-127], 300-127, 'pkg -127'); 530 is($aelem[-126], 300-126, 'pkg -126'); 531 is($aelem[ -1], 300- 1, 'pkg -1'); 532 is($aelem[ 0], 0, 'pkg 0'); 533 is($aelem[ 1], 1, 'pkg 1'); 534 is($aelem[ 126], 126, 'pkg 126'); 535 is($aelem[ 127], 127, 'pkg 127'); 536 is($aelem[ 128], 128, 'pkg 128'); 537 is($aelem[ 129], 129, 'pkg 129'); 538 is($aelem[ 254], 254, 'pkg 254'); 539 is($aelem[ 255], 255, 'pkg 255'); 540 is($aelem[ 256], 256, 'pkg 256'); 541} 542 543# Test aelemfast in list assignment 544@ary = ('a','b'); 545($ary[0],$ary[1]) = ($ary[1],$ary[0]); 546is "@ary", 'b a', 547 'aelemfast with the same array on both sides of list assignment'; 548 549for(scalar $#foo) { $_ = 3 } 550is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)'; 551 552{ 553 my @a = qw(a b c); 554 @a = @a; 555 is "@a", 'a b c', 'assigning to itself'; 556} 557 558sub { undef *_; shift }->(); # This would crash; no ok() necessary. 559sub { undef *_; pop }->(); 560 561# [perl #129164], [perl #129166], [perl #129167] 562# splice() with null array entries 563# These used to crash. 564$#a = -1; $#a++; 565() = 0-splice @a; # subtract 566$#a = -1; $#a++; 567() = -splice @a; # negate 568$#a = -1; $#a++; 569() = 0+splice @a; # add 570# And with array expansion, too 571$#a = -1; $#a++; 572() = 0-splice @a, 0, 1, 1, 1; 573$#a = -1; $#a++; 574() = -splice @a, 0, 1, 1, 1; 575$#a = -1; $#a++; 576() = 0+splice @a, 0, 1, 1, 1; 577 578# [perl #8910] lazy creation of array elements used to leak out 579{ 580 sub t8910 { $_[1] = 5; $_[2] = 7; } 581 my @p; 582 $p[0] = 1; 583 $p[2] = 2; 584 t8910(@p); 585 is "@p", "1 5 7", "lazy element creation with sub call"; 586 my @q; 587 @q[0] = 1; 588 @q[2] = 2; 589 my @qr = \(@q); 590 is $qr[$_], \$q[$_], "lazy element creation with refgen" foreach 0..2; 591 isnt $qr[1], \undef, "lazy element creation with refgen"; 592 my @r; 593 $r[1] = 1; 594 foreach my $re ((), @r) { $re = 5; } 595 is join("", @r), "55", "lazy element creation with foreach"; 596} 597 598{ # Some things broken by the initial fix for #8910 599 (\my @a)->$#*++; 600 my @b = @a; 601 ok !exists $a[0], 'copying an array via = does not vivify elements'; 602 delete $a[0]; 603 @a[1..5] = 1..5; 604 $#a++; 605 my $count; 606 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 607 is join(",", @existing_elements), "1,2,3,4,5", 608 'map {} @a does not vivify elements'; 609 $#a = -1; 610 {local $a[3] = 12; my @foo=@a}; 611 is @a, 0,'unwinding localization of elem past end of array shrinks it'; 612 613 # Again, but with a package array 614 package tmp; (\our @a)->$#*++; package main; 615 my @b = @a; 616 ok !exists $a[0], 'copying an array via = does not vivify elements'; 617 delete $a[0]; 618 @a[1..5] = 1..5; 619 $#a++; 620 my $count; 621 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 622 is join(",", @existing_elements), "1,2,3,4,5", 623 'map {} @a does not vivify elements'; 624 $#a = -1; 625 {local $a[3] = 12; my @foo=@a}; 626 is @a, 0,'unwinding localization of elem past end of array shrinks it'; 627} 628{ 629 # Again, but with a non-magical array ($#a makes it magical) 630 my @a = 1; 631 delete $a[0]; 632 my @b = @a; 633 ok !exists $a[0], 'copying an array via = does not vivify elements'; 634 delete $a[0]; 635 @a[1..5] = 1..5; 636 my $count; 637 my @existing_elements = map { exists $a[$count++] ? $_ : () } @a; 638 is join(",", @existing_elements), "1,2,3,4,5", 639 'map {} @a does not vivify elements'; 640 @a = (); 641 {local $a[3] = 12; my @foo=@a}; 642 is @a, 0, 'unwinding localization of elem past end of array shrinks it' 643} 644 645# perl #132729, as it applies to flattening an array in lvalue context 646{ 647 my @a; 648 $a[1] = 1; 649 map { unshift @a, 7; $_ = 3; goto aftermap; } @a; 650 aftermap: 651 is "[@a]", "[7 3 1]", 652 'non-elems read from @a do not lose their position'; 653 @a = (); 654 $#a++; # make it magical 655 $a[1] = 1; 656 map { unshift @a, 7; $_ = 3; goto aftermath; } @a; 657 aftermath: 658 is "[@a]", "[7 3 1]", 659 'non-elems read from magical @a do not lose their position'; 660} 661# perl #132729, as it applies to ‘holes’ in an array passed to a sub 662# individually 663{ 664 my @a; 665 $a[1] = 1; 666 sub { unshift @a, 7; $_[0] = 3; }->($a[0]); 667 is "[@a]", "[7 3 1]", 668 'holes passed to sub do not lose their position (multideref)'; 669 @a = (); 670 $#a++; # make it magical 671 $a[1] = 1; 672 sub { unshift @a, 7; $_[0] = 3; }->($a[0]); 673 is "[@a]", "[7 3 1]", 674 'holes passed to sub do not lose their position (multideref, mg)'; 675} 676{ 677 # Again, with aelem, not multideref 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 (aelem)'; 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 (aelem, mg)'; 689} 690 691"We're included by lib/Tie/Array/std.t so we need to return something true"; 692