1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = ('.', '../lib'); 6 require 'test.pl'; 7} 8 9plan (127); 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{ 24 no warnings 'deprecated'; 25 26@foo = (); 27$r = join(',', $#foo, @foo); 28is($r, "-1"); 29$foo[0] = '0'; 30$r = join(',', $#foo, @foo); 31is($r, "0,0"); 32$foo[2] = '2'; 33$r = join(',', $#foo, @foo); 34is($r, "2,0,,2"); 35@bar = (); 36$bar[0] = '0'; 37$bar[1] = '1'; 38$r = join(',', $#bar, @bar); 39is($r, "1,0,1"); 40@bar = (); 41$r = join(',', $#bar, @bar); 42is($r, "-1"); 43$bar[0] = '0'; 44$r = join(',', $#bar, @bar); 45is($r, "0,0"); 46$bar[2] = '2'; 47$r = join(',', $#bar, @bar); 48is($r, "2,0,,2"); 49reset 'b' if $^O ne 'VMS'; 50@bar = (); 51$bar[0] = '0'; 52$r = join(',', $#bar, @bar); 53is($r, "0,0"); 54$bar[2] = '2'; 55$r = join(',', $#bar, @bar); 56is($r, "2,0,,2"); 57 58} 59 60$foo = 'now is the time'; 61ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); 62is($F1, 'now'); 63is($F2, 'is'); 64is($Etc, 'the time'); 65 66$foo = 'lskjdf'; 67ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) 68 or diag("$cnt $F1:$F2:$Etc"); 69 70%foo = ('blurfl','dyick','foo','bar','etc.','etc.'); 71%bar = %foo; 72is($bar{'foo'}, 'bar'); 73%bar = (); 74is($bar{'foo'}, undef); 75(%bar,$a,$b) = (%foo,'how','now'); 76is($bar{'foo'}, 'bar'); 77is($bar{'how'}, 'now'); 78@bar{keys %foo} = values %foo; 79is($bar{'foo'}, 'bar'); 80is($bar{'how'}, 'now'); 81 82@foo = grep(/e/,split(' ','now is the time for all good men to come to')); 83is(join(' ',@foo), 'the time men come'); 84 85@foo = grep(!/e/,split(' ','now is the time for all good men to come to')); 86is(join(' ',@foo), 'now is for all good to to'); 87 88$foo = join('',('a','b','c','d','e','f')[0..5]); 89is($foo, 'abcdef'); 90 91$foo = join('',('a','b','c','d','e','f')[0..1]); 92is($foo, 'ab'); 93 94$foo = join('',('a','b','c','d','e','f')[6]); 95is($foo, ''); 96 97@foo = ('a','b','c','d','e','f')[0,2,4]; 98@bar = ('a','b','c','d','e','f')[1,3,5]; 99$foo = join('',(@foo,@bar)[0..5]); 100is($foo, 'acebdf'); 101 102$foo = ('a','b','c','d','e','f')[0,2,4]; 103is($foo, 'e'); 104 105$foo = ('a','b','c','d','e','f')[1]; 106is($foo, 'b'); 107 108@foo = ( 'foo', 'bar', 'burbl'); 109{ 110 no warnings 'deprecated'; 111 push(foo, 'blah'); 112} 113is($#foo, 3); 114 115# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) 116 117#curr_test(38); 118 119@foo = @foo; 120is("@foo", "foo bar burbl blah"); # 38 121 122(undef,@foo) = @foo; 123is("@foo", "bar burbl blah"); # 39 124 125@foo = ('XXX',@foo, 'YYY'); 126is("@foo", "XXX bar burbl blah YYY"); # 40 127 128@foo = @foo = qw(foo b\a\r bu\\rbl blah); 129is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 130 131@bar = @foo = qw(foo bar); # 42 132is("@foo", "foo bar"); 133is("@bar", "foo bar"); # 43 134 135# try the same with local 136# XXX tie-stdarray fails the tests involving local, so we use 137# different variable names to escape the 'tie' 138 139@bee = ( 'foo', 'bar', 'burbl', 'blah'); 140{ 141 142 local @bee = @bee; 143 is("@bee", "foo bar burbl blah"); # 44 144 { 145 local (undef,@bee) = @bee; 146 is("@bee", "bar burbl blah"); # 45 147 { 148 local @bee = ('XXX',@bee,'YYY'); 149 is("@bee", "XXX bar burbl blah YYY"); # 46 150 { 151 local @bee = local(@bee) = qw(foo bar burbl blah); 152 is("@bee", "foo bar burbl blah"); # 47 153 { 154 local (@bim) = local(@bee) = qw(foo bar); 155 is("@bee", "foo bar"); # 48 156 is("@bim", "foo bar"); # 49 157 } 158 is("@bee", "foo bar burbl blah"); # 50 159 } 160 is("@bee", "XXX bar burbl blah YYY"); # 51 161 } 162 is("@bee", "bar burbl blah"); # 52 163 } 164 is("@bee", "foo bar burbl blah"); # 53 165} 166 167# try the same with my 168{ 169 my @bee = @bee; 170 is("@bee", "foo bar burbl blah"); # 54 171 { 172 my (undef,@bee) = @bee; 173 is("@bee", "bar burbl blah"); # 55 174 { 175 my @bee = ('XXX',@bee,'YYY'); 176 is("@bee", "XXX bar burbl blah YYY"); # 56 177 { 178 my @bee = my @bee = qw(foo bar burbl blah); 179 is("@bee", "foo bar burbl blah"); # 57 180 { 181 my (@bim) = my(@bee) = qw(foo bar); 182 is("@bee", "foo bar"); # 58 183 is("@bim", "foo bar"); # 59 184 } 185 is("@bee", "foo bar burbl blah"); # 60 186 } 187 is("@bee", "XXX bar burbl blah YYY"); # 61 188 } 189 is("@bee", "bar burbl blah"); # 62 190 } 191 is("@bee", "foo bar burbl blah"); # 63 192} 193 194# try the same with our (except that previous values aren't restored) 195{ 196 our @bee = @bee; 197 is("@bee", "foo bar burbl blah"); 198 { 199 our (undef,@bee) = @bee; 200 is("@bee", "bar burbl blah"); 201 { 202 our @bee = ('XXX',@bee,'YYY'); 203 is("@bee", "XXX bar burbl blah YYY"); 204 { 205 our @bee = our @bee = qw(foo bar burbl blah); 206 is("@bee", "foo bar burbl blah"); 207 { 208 our (@bim) = our(@bee) = qw(foo bar); 209 is("@bee", "foo bar"); 210 is("@bim", "foo bar"); 211 } 212 } 213 } 214 } 215} 216 217# make sure reification behaves 218my $t = curr_test(); 219sub reify { $_[1] = $t++; print "@_\n"; } 220reify('ok'); 221reify('ok'); 222 223curr_test($t); 224 225# qw() is no longer a runtime split, it's compiletime. 226is (qw(foo bar snorfle)[2], 'snorfle'); 227 228@ary = (12,23,34,45,56); 229 230is(shift(@ary), 12); 231is(pop(@ary), 56); 232is(push(@ary,56), 4); 233is(unshift(@ary,12), 5); 234 235sub foo { "a" } 236@foo=(foo())[0,0]; 237is ($foo[1], "a"); 238 239# bugid #15439 - clearing an array calls destructors which may try 240# to modify the array - caused 'Attempt to free unreferenced scalar' 241 242my $got = runperl ( 243 prog => q{ 244 sub X::DESTROY { @a = () } 245 @a = (bless {}, q{X}); 246 @a = (); 247 }, 248 stderr => 1 249 ); 250 251$got =~ s/\n/ /g; 252is ($got, ''); 253 254# Test negative and funky indices. 255 256 257{ 258 my @a = 0..4; 259 is($a[-1], 4); 260 is($a[-2], 3); 261 is($a[-5], 0); 262 ok(!defined $a[-6]); 263 264 is($a[2.1] , 2); 265 is($a[2.9] , 2); 266 is($a[undef], 0); 267 is($a["3rd"], 3); 268} 269 270 271{ 272 my @a; 273 eval '$a[-1] = 0'; 274 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); 275} 276 277sub test_arylen { 278 my $ref = shift; 279 local $^W = 1; 280 is ($$ref, undef, "\$# on freed array is undef"); 281 my @warn; 282 local $SIG{__WARN__} = sub {push @warn, "@_"}; 283 $$ref = 1000; 284 is (scalar @warn, 1); 285 like ($warn[0], qr/^Attempt to set length of freed array/); 286} 287 288{ 289 my $a = \$#{[]}; 290 # Need a new statement to make it go out of scope 291 test_arylen ($a); 292 test_arylen (do {my @a; \$#a}); 293} 294 295{ 296 use vars '@array'; 297 298 my $outer = \$#array; 299 is ($$outer, -1); 300 is (scalar @array, 0); 301 302 $$outer = 3; 303 is ($$outer, 3); 304 is (scalar @array, 4); 305 306 my $ref = \@array; 307 308 my $inner; 309 { 310 local @array; 311 $inner = \$#array; 312 313 is ($$inner, -1); 314 is (scalar @array, 0); 315 $$outer = 6; 316 317 is (scalar @$ref, 7); 318 319 is ($$inner, -1); 320 is (scalar @array, 0); 321 322 $$inner = 42; 323 } 324 325 is (scalar @array, 7); 326 is ($$outer, 6); 327 328 is ($$inner, undef, "orphaned $#foo is always undef"); 329 330 is (scalar @array, 7); 331 is ($$outer, 6); 332 333 $$inner = 1; 334 335 is (scalar @array, 7); 336 is ($$outer, 6); 337 338 $$inner = 503; # Bang! 339 340 is (scalar @array, 7); 341 is ($$outer, 6); 342} 343 344{ 345 # Bug #36211 346 use vars '@array'; 347 for (1,2) { 348 { 349 local @a; 350 is ($#a, -1); 351 @a=(1..4) 352 } 353 } 354} 355 356{ 357 # Bug #37350 358 my @array = (1..4); 359 $#{@array} = 7; 360 is ($#{4}, 7); 361 362 my $x; 363 $#{$x} = 3; 364 is(scalar @$x, 4); 365 366 push @{@array}, 23; 367 is ($4[8], 23); 368} 369{ 370 # Bug #37350 -- once more with a global 371 use vars '@array'; 372 @array = (1..4); 373 $#{@array} = 7; 374 is ($#{4}, 7); 375 376 my $x; 377 $#{$x} = 3; 378 is(scalar @$x, 4); 379 380 push @{@array}, 23; 381 is ($4[8], 23); 382} 383 384# more tests for AASSIGN_COMMON 385 386{ 387 our($x,$y,$z) = (1..3); 388 our($y,$z) = ($x,$y); 389 is("$x $y $z", "1 1 2"); 390} 391{ 392 our($x,$y,$z) = (1..3); 393 (our $y, our $z) = ($x,$y); 394 is("$x $y $z", "1 1 2"); 395} 396{ 397 # AASSIGN_COMMON detection with logical operators 398 my $true = 1; 399 our($x,$y,$z) = (1..3); 400 (our $y, our $z) = $true && ($x,$y); 401 is("$x $y $z", "1 1 2"); 402} 403 404# [perl #70171] 405{ 406 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; 407 is( 408 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", 409 'bug 70171 (self-assignment via my %x = %$x)' 410 ); 411 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; 412 is( 413 "@y", "1 2 3 4", 414 'bug 70171 (self-assignment via my @x = @$x)' 415 ); 416} 417 418# [perl #70171], [perl #82110] 419{ 420 my ($i, $ra, $rh); 421 again: 422 my @a = @$ra; # common assignment on 2nd attempt 423 my %h = %$rh; # common assignment on 2nd attempt 424 @a = qw(1 2 3 4); 425 %h = qw(a 1 b 2 c 3 d 4); 426 $ra = \@a; 427 $rh = \%h; 428 goto again unless $i++; 429 430 is("@a", "1 2 3 4", 431 'bug 70171 (self-assignment via my @x = @$x) - goto variant' 432 ); 433 is( 434 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4", 435 'bug 70171 (self-assignment via my %x = %$x) - goto variant' 436 ); 437} 438 439 440*trit = *scile; $trit[0]; 441ok(1, 'aelem_fast on a nonexistent array does not crash'); 442 443# [perl #107440] 444sub A::DESTROY { $::ra = 0 } 445$::ra = [ bless [], 'A' ]; 446undef @$::ra; 447pass 'no crash when freeing array that is being undeffed'; 448$::ra = [ bless [], 'A' ]; 449@$::ra = ('a'..'z'); 450pass 'no crash when freeing array that is being cleared'; 451 452# [perl #85670] Copying magic to elements 453SKIP: { 454 skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl; 455 require Scalar::Util; 456 package glelp { 457 Scalar::Util::weaken ($a = \@ISA); 458 @ISA = qw(Foo); 459 Scalar::Util::weaken ($a = \$ISA[0]); 460 ::is @ISA, 1, 'backref magic is not copied to elements'; 461 } 462} 463package peen { 464 $#ISA = -1; 465 @ISA = qw(Foo); 466 $ISA[0] = qw(Sphare); 467 468 sub Sphare::pling { 'pling' } 469 470 ::is eval { pling peen }, 'pling', 471 'arylen_p magic does not stop isa magic from being copied'; 472} 473 474 475"We're included by lib/Tie/Array/std.t so we need to return something true"; 476