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