1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = ('.', '../lib'); 6 require 'test.pl'; 7} 8 9plan (171); 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'); 104{ 105 no warnings 'deprecated'; 106 push(foo, 'blah'); 107} 108is($#foo, 3); 109 110# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) 111 112#curr_test(38); 113 114@foo = @foo; 115is("@foo", "foo bar burbl blah"); # 38 116 117(undef,@foo) = @foo; 118is("@foo", "bar burbl blah"); # 39 119 120@foo = ('XXX',@foo, 'YYY'); 121is("@foo", "XXX bar burbl blah YYY"); # 40 122 123@foo = @foo = qw(foo b\a\r bu\\rbl blah); 124is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 125 126@bar = @foo = qw(foo bar); # 42 127is("@foo", "foo bar"); 128is("@bar", "foo bar"); # 43 129 130# try the same with local 131# XXX tie-stdarray fails the tests involving local, so we use 132# different variable names to escape the 'tie' 133 134@bee = ( 'foo', 'bar', 'burbl', 'blah'); 135{ 136 137 local @bee = @bee; 138 is("@bee", "foo bar burbl blah"); # 44 139 { 140 local (undef,@bee) = @bee; 141 is("@bee", "bar burbl blah"); # 45 142 { 143 local @bee = ('XXX',@bee,'YYY'); 144 is("@bee", "XXX bar burbl blah YYY"); # 46 145 { 146 local @bee = local(@bee) = qw(foo bar burbl blah); 147 is("@bee", "foo bar burbl blah"); # 47 148 { 149 local (@bim) = local(@bee) = qw(foo bar); 150 is("@bee", "foo bar"); # 48 151 is("@bim", "foo bar"); # 49 152 } 153 is("@bee", "foo bar burbl blah"); # 50 154 } 155 is("@bee", "XXX bar burbl blah YYY"); # 51 156 } 157 is("@bee", "bar burbl blah"); # 52 158 } 159 is("@bee", "foo bar burbl blah"); # 53 160} 161 162# try the same with my 163{ 164 my @bee = @bee; 165 is("@bee", "foo bar burbl blah"); # 54 166 { 167 my (undef,@bee) = @bee; 168 is("@bee", "bar burbl blah"); # 55 169 { 170 my @bee = ('XXX',@bee,'YYY'); 171 is("@bee", "XXX bar burbl blah YYY"); # 56 172 { 173 my @bee = my @bee = qw(foo bar burbl blah); 174 is("@bee", "foo bar burbl blah"); # 57 175 { 176 my (@bim) = my(@bee) = qw(foo bar); 177 is("@bee", "foo bar"); # 58 178 is("@bim", "foo bar"); # 59 179 } 180 is("@bee", "foo bar burbl blah"); # 60 181 } 182 is("@bee", "XXX bar burbl blah YYY"); # 61 183 } 184 is("@bee", "bar burbl blah"); # 62 185 } 186 is("@bee", "foo bar burbl blah"); # 63 187} 188 189# try the same with our (except that previous values aren't restored) 190{ 191 our @bee = @bee; 192 is("@bee", "foo bar burbl blah"); 193 { 194 our (undef,@bee) = @bee; 195 is("@bee", "bar burbl blah"); 196 { 197 our @bee = ('XXX',@bee,'YYY'); 198 is("@bee", "XXX bar burbl blah YYY"); 199 { 200 our @bee = our @bee = qw(foo bar burbl blah); 201 is("@bee", "foo bar burbl blah"); 202 { 203 our (@bim) = our(@bee) = qw(foo bar); 204 is("@bee", "foo bar"); 205 is("@bim", "foo bar"); 206 } 207 } 208 } 209 } 210} 211 212# make sure reification behaves 213my $t = curr_test(); 214sub reify { $_[1] = $t++; print "@_\n"; } 215reify('ok'); 216reify('ok'); 217 218curr_test($t); 219 220# qw() is no longer a runtime split, it's compiletime. 221is (qw(foo bar snorfle)[2], 'snorfle'); 222 223@ary = (12,23,34,45,56); 224 225is(shift(@ary), 12); 226is(pop(@ary), 56); 227is(push(@ary,56), 4); 228is(unshift(@ary,12), 5); 229 230sub foo { "a" } 231@foo=(foo())[0,0]; 232is ($foo[1], "a"); 233 234# bugid #15439 - clearing an array calls destructors which may try 235# to modify the array - caused 'Attempt to free unreferenced scalar' 236 237my $got = runperl ( 238 prog => q{ 239 sub X::DESTROY { @a = () } 240 @a = (bless {}, q{X}); 241 @a = (); 242 }, 243 stderr => 1 244 ); 245 246$got =~ s/\n/ /g; 247is ($got, ''); 248 249# Test negative and funky indices. 250 251 252{ 253 my @a = 0..4; 254 is($a[-1], 4); 255 is($a[-2], 3); 256 is($a[-5], 0); 257 ok(!defined $a[-6]); 258 259 is($a[2.1] , 2); 260 is($a[2.9] , 2); 261 is($a[undef], 0); 262 is($a["3rd"], 3); 263} 264 265 266{ 267 my @a; 268 eval '$a[-1] = 0'; 269 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); 270} 271 272sub test_arylen { 273 my $ref = shift; 274 local $^W = 1; 275 is ($$ref, undef, "\$# on freed array is undef"); 276 my @warn; 277 local $SIG{__WARN__} = sub {push @warn, "@_"}; 278 $$ref = 1000; 279 is (scalar @warn, 1); 280 like ($warn[0], qr/^Attempt to set length of freed array/); 281} 282 283{ 284 my $a = \$#{[]}; 285 # Need a new statement to make it go out of scope 286 test_arylen ($a); 287 test_arylen (do {my @a; \$#a}); 288} 289 290{ 291 use vars '@array'; 292 293 my $outer = \$#array; 294 is ($$outer, -1); 295 is (scalar @array, 0); 296 297 $$outer = 3; 298 is ($$outer, 3); 299 is (scalar @array, 4); 300 301 my $ref = \@array; 302 303 my $inner; 304 { 305 local @array; 306 $inner = \$#array; 307 308 is ($$inner, -1); 309 is (scalar @array, 0); 310 $$outer = 6; 311 312 is (scalar @$ref, 7); 313 314 is ($$inner, -1); 315 is (scalar @array, 0); 316 317 $$inner = 42; 318 } 319 320 is (scalar @array, 7); 321 is ($$outer, 6); 322 323 is ($$inner, undef, "orphaned $#foo is always undef"); 324 325 is (scalar @array, 7); 326 is ($$outer, 6); 327 328 $$inner = 1; 329 330 is (scalar @array, 7); 331 is ($$outer, 6); 332 333 $$inner = 503; # Bang! 334 335 is (scalar @array, 7); 336 is ($$outer, 6); 337} 338 339{ 340 # Bug #36211 341 use vars '@array'; 342 for (1,2) { 343 { 344 local @a; 345 is ($#a, -1); 346 @a=(1..4) 347 } 348 } 349} 350 351{ 352 # Bug #37350 353 my @array = (1..4); 354 $#{@array} = 7; 355 is ($#{4}, 7); 356 357 my $x; 358 $#{$x} = 3; 359 is(scalar @$x, 4); 360 361 push @{@array}, 23; 362 is ($4[8], 23); 363} 364{ 365 # Bug #37350 -- once more with a global 366 use vars '@array'; 367 @array = (1..4); 368 $#{@array} = 7; 369 is ($#{4}, 7); 370 371 my $x; 372 $#{$x} = 3; 373 is(scalar @$x, 4); 374 375 push @{@array}, 23; 376 is ($4[8], 23); 377} 378 379# more tests for AASSIGN_COMMON 380 381{ 382 our($x,$y,$z) = (1..3); 383 our($y,$z) = ($x,$y); 384 is("$x $y $z", "1 1 2"); 385} 386{ 387 our($x,$y,$z) = (1..3); 388 (our $y, our $z) = ($x,$y); 389 is("$x $y $z", "1 1 2"); 390} 391{ 392 # AASSIGN_COMMON detection with logical operators 393 my $true = 1; 394 our($x,$y,$z) = (1..3); 395 (our $y, our $z) = $true && ($x,$y); 396 is("$x $y $z", "1 1 2"); 397} 398 399# [perl #70171] 400{ 401 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; 402 is( 403 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", 404 'bug 70171 (self-assignment via my %x = %$x)' 405 ); 406 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; 407 is( 408 "@y", "1 2 3 4", 409 'bug 70171 (self-assignment via my @x = @$x)' 410 ); 411} 412 413# [perl #70171], [perl #82110] 414{ 415 my ($i, $ra, $rh); 416 again: 417 my @a = @$ra; # common assignment on 2nd attempt 418 my %h = %$rh; # common assignment on 2nd attempt 419 @a = qw(1 2 3 4); 420 %h = qw(a 1 b 2 c 3 d 4); 421 $ra = \@a; 422 $rh = \%h; 423 goto again unless $i++; 424 425 is("@a", "1 2 3 4", 426 'bug 70171 (self-assignment via my @x = @$x) - goto variant' 427 ); 428 is( 429 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4", 430 'bug 70171 (self-assignment via my %x = %$x) - goto variant' 431 ); 432} 433 434 435*trit = *scile; $trit[0]; 436ok(1, 'aelem_fast on a nonexistent array does not crash'); 437 438# [perl #107440] 439sub A::DESTROY { $::ra = 0 } 440$::ra = [ bless [], 'A' ]; 441undef @$::ra; 442pass 'no crash when freeing array that is being undeffed'; 443$::ra = [ bless [], 'A' ]; 444@$::ra = ('a'..'z'); 445pass 'no crash when freeing array that is being cleared'; 446 447# [perl #85670] Copying magic to elements 448SKIP: { 449 skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl; 450 require Scalar::Util; 451 package glelp { 452 Scalar::Util::weaken ($a = \@ISA); 453 @ISA = qw(Foo); 454 Scalar::Util::weaken ($a = \$ISA[0]); 455 ::is @ISA, 1, 'backref magic is not copied to elements'; 456 } 457} 458package peen { 459 $#ISA = -1; 460 @ISA = qw(Foo); 461 $ISA[0] = qw(Sphare); 462 463 sub Sphare::pling { 'pling' } 464 465 ::is eval { pling peen }, 'pling', 466 'arylen_p magic does not stop isa magic from being copied'; 467} 468 469# Test that &PL_sv_undef is not special in arrays 470sub { 471 ok exists $_[0], 472 'exists returns true for &PL_sv_undef elem [perl #7508]'; 473 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]'; 474}->(undef); 475# and that padav also knows how to handle the resulting NULLs 476@_ = sub { my @a; $a[1]=1; @a }->(); 477is join (" ", map $_//"undef", @_), "undef 1", 478 'returning my @a with nonexistent elements'; 479 480# [perl #118691] 481@plink=@plunk=(); 482$plink[3] = 1; 483sub { 484 $_[0] = 2; 485 is $plink[0], 2, '@_ alias to nonexistent elem within array'; 486 $_[1] = 3; 487 is $plink[1], 3, '@_ alias to nonexistent neg index within array'; 488 is $_[2], undef, 'reading alias to negative index past beginning'; 489 eval { $_[2] = 42 }; 490 like $@, qr/Modification of non-creatable array value attempted, (?x: 491 )subscript -5/, 492 'error when setting alias to negative index past beginning'; 493 is $_[3], undef, 'reading alias to -1 elem of empty array'; 494 eval { $_[3] = 42 }; 495 like $@, qr/Modification of non-creatable array value attempted, (?x: 496 )subscript -1/, 497 'error when setting alias to -1 elem of empty array'; 498}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]); 499 500$_ = \$#{[]}; 501$$_ = \1; 502"$$_"; 503pass "no assertion failure after assigning ref to arylen when ary is gone"; 504 505 506{ 507 # Test aelemfast for both +ve and -ve indices, both lex and package vars. 508 # Make especially careful that we don't have any edge cases around 509 # fitting an I8 into a U8. 510 my @a = (0..299); 511 is($a[-256], 300-256, 'lex -256'); 512 is($a[-255], 300-255, 'lex -255'); 513 is($a[-254], 300-254, 'lex -254'); 514 is($a[-129], 300-129, 'lex -129'); 515 is($a[-128], 300-128, 'lex -128'); 516 is($a[-127], 300-127, 'lex -127'); 517 is($a[-126], 300-126, 'lex -126'); 518 is($a[ -1], 300- 1, 'lex -1'); 519 is($a[ 0], 0, 'lex 0'); 520 is($a[ 1], 1, 'lex 1'); 521 is($a[ 126], 126, 'lex 126'); 522 is($a[ 127], 127, 'lex 127'); 523 is($a[ 128], 128, 'lex 128'); 524 is($a[ 129], 129, 'lex 129'); 525 is($a[ 254], 254, 'lex 254'); 526 is($a[ 255], 255, 'lex 255'); 527 is($a[ 256], 256, 'lex 256'); 528 @aelem =(0..299); 529 is($aelem[-256], 300-256, 'pkg -256'); 530 is($aelem[-255], 300-255, 'pkg -255'); 531 is($aelem[-254], 300-254, 'pkg -254'); 532 is($aelem[-129], 300-129, 'pkg -129'); 533 is($aelem[-128], 300-128, 'pkg -128'); 534 is($aelem[-127], 300-127, 'pkg -127'); 535 is($aelem[-126], 300-126, 'pkg -126'); 536 is($aelem[ -1], 300- 1, 'pkg -1'); 537 is($aelem[ 0], 0, 'pkg 0'); 538 is($aelem[ 1], 1, 'pkg 1'); 539 is($aelem[ 126], 126, 'pkg 126'); 540 is($aelem[ 127], 127, 'pkg 127'); 541 is($aelem[ 128], 128, 'pkg 128'); 542 is($aelem[ 129], 129, 'pkg 129'); 543 is($aelem[ 254], 254, 'pkg 254'); 544 is($aelem[ 255], 255, 'pkg 255'); 545 is($aelem[ 256], 256, 'pkg 256'); 546} 547 548"We're included by lib/Tie/Array/std.t so we need to return something true"; 549