| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | require './test.pl'; |
| 6 | set_up_inc( qw(. ../lib) ); |
| 7 | } |
| 8 | |
| 9 | use strict qw(refs subs); |
| 10 | |
| 11 | plan(236); |
| 12 | |
| 13 | # Test this first before we extend the stack with other operations. |
| 14 | # This caused an asan failure due to a bad write past the end of the stack. |
| 15 | eval { die 1..127, $_=\() }; |
| 16 | |
| 17 | # Test glob operations. |
| 18 | |
| 19 | $bar = "one"; |
| 20 | $foo = "two"; |
| 21 | { |
| 22 | local(*foo) = *bar; |
| 23 | is($foo, 'one'); |
| 24 | } |
| 25 | is ($foo, 'two'); |
| 26 | |
| 27 | $baz = "three"; |
| 28 | $foo = "four"; |
| 29 | { |
| 30 | local(*foo) = 'baz'; |
| 31 | is ($foo, 'three'); |
| 32 | } |
| 33 | is ($foo, 'four'); |
| 34 | |
| 35 | $foo = "global"; |
| 36 | { |
| 37 | local(*foo); |
| 38 | is ($foo, undef); |
| 39 | $foo = "local"; |
| 40 | is ($foo, 'local'); |
| 41 | } |
| 42 | is ($foo, 'global'); |
| 43 | |
| 44 | { |
| 45 | no strict 'refs'; |
| 46 | # Test fake references. |
| 47 | |
| 48 | $baz = "valid"; |
| 49 | $bar = 'baz'; |
| 50 | $foo = 'bar'; |
| 51 | is ($$$foo, 'valid'); |
| 52 | } |
| 53 | |
| 54 | # Test real references. |
| 55 | |
| 56 | $FOO = \$BAR; |
| 57 | $BAR = \$BAZ; |
| 58 | $BAZ = "hit"; |
| 59 | is ($$$FOO, 'hit'); |
| 60 | |
| 61 | # Test references to real arrays. |
| 62 | |
| 63 | my $test = curr_test(); |
| 64 | @ary = ($test,$test+1,$test+2,$test+3); |
| 65 | $ref[0] = \@a; |
| 66 | $ref[1] = \@b; |
| 67 | $ref[2] = \@c; |
| 68 | $ref[3] = \@d; |
| 69 | for $i (3,1,2,0) { |
| 70 | push(@{$ref[$i]}, "ok $ary[$i]\n"); |
| 71 | } |
| 72 | print @a; |
| 73 | print ${$ref[1]}[0]; |
| 74 | print @{$ref[2]}[0]; |
| 75 | { |
| 76 | no strict 'refs'; |
| 77 | print @{'d'}; |
| 78 | } |
| 79 | curr_test($test+4); |
| 80 | |
| 81 | # Test references to references. |
| 82 | |
| 83 | $refref = \\$x; |
| 84 | $x = "Good"; |
| 85 | is ($$$refref, 'Good'); |
| 86 | |
| 87 | # Test nested anonymous arrays. |
| 88 | |
| 89 | $ref = [[],2,[3,4,5,]]; |
| 90 | is (scalar @$ref, 3); |
| 91 | is ($$ref[1], 2); |
| 92 | is (${$$ref[2]}[2], 5); |
| 93 | is (scalar @{$$ref[0]}, 0); |
| 94 | |
| 95 | is ($ref->[1], 2); |
| 96 | is ($ref->[2]->[0], 3); |
| 97 | |
| 98 | # Test references to hashes of references. |
| 99 | |
| 100 | $refref = \%whatever; |
| 101 | $refref->{"key"} = $ref; |
| 102 | is ($refref->{"key"}->[2]->[0], 3); |
| 103 | |
| 104 | # Test to see if anonymous subarrays spring into existence. |
| 105 | |
| 106 | $spring[5]->[0] = 123; |
| 107 | $spring[5]->[1] = 456; |
| 108 | push(@{$spring[5]}, 789); |
| 109 | is (join(':',@{$spring[5]}), "123:456:789"); |
| 110 | |
| 111 | # Test to see if anonymous subhashes spring into existence. |
| 112 | |
| 113 | @{$spring2{"foo"}} = (1,2,3); |
| 114 | $spring2{"foo"}->[3] = 4; |
| 115 | is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); |
| 116 | |
| 117 | # Test references to subroutines. |
| 118 | |
| 119 | { |
| 120 | my $called; |
| 121 | sub mysub { $called++; } |
| 122 | $subref = \&mysub; |
| 123 | &$subref; |
| 124 | is ($called, 1); |
| 125 | } |
| 126 | is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]'; |
| 127 | delete $My::{"Foo::"}; |
| 128 | is ref \&My::Foo::foo, "CODE", |
| 129 | 'creating stub with \&deleted_stash::foo [perl #128532]'; |
| 130 | |
| 131 | |
| 132 | # Test references to return values of operators (TARGs/PADTMPs) |
| 133 | { |
| 134 | my @refs; |
| 135 | for("a", "b") { |
| 136 | push @refs, \"$_" |
| 137 | } |
| 138 | is join(" ", map $$_, @refs), "a b", 'refgen+PADTMP'; |
| 139 | } |
| 140 | |
| 141 | $subrefref = \\&mysub2; |
| 142 | is ($$subrefref->("GOOD"), "good"); |
| 143 | sub mysub2 { lc shift } |
| 144 | |
| 145 | # Test REGEXP assignment |
| 146 | |
| 147 | SKIP: { |
| 148 | skip_if_miniperl("no dynamic loading on miniperl, so can't load re", 5); |
| 149 | require re; |
| 150 | my $x = qr/x/; |
| 151 | my $str = "$x"; # regex stringification may change |
| 152 | |
| 153 | my $y = $$x; |
| 154 | is ($y, $str, "bare REGEXP stringifies correctly"); |
| 155 | ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); |
| 156 | |
| 157 | my $z = \$y; |
| 158 | ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); |
| 159 | is ($z, $str, "new ref to REGEXP stringifies correctly"); |
| 160 | ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); |
| 161 | } |
| 162 | { |
| 163 | my ($x, $str); |
| 164 | { |
| 165 | my $y = qr/x/; |
| 166 | $str = "$y"; |
| 167 | $x = $$y; |
| 168 | } |
| 169 | is ($x, $str, "REGEXP keeps a ref to its mother_re"); |
| 170 | ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); |
| 171 | } |
| 172 | |
| 173 | # Test the ref operator. |
| 174 | |
| 175 | sub PVBM () { 'foo' } |
| 176 | { my $dummy = index 'foo', PVBM } |
| 177 | |
| 178 | my $pviv = 1; "$pviv"; |
| 179 | my $pvnv = 1.0; "$pvnv"; |
| 180 | my $x; |
| 181 | |
| 182 | # we don't test |
| 183 | # tied lvalue => SCALAR, as we haven't tested tie yet |
| 184 | # BIND, 'cos we can't create them yet |
| 185 | # REGEXP, 'cos that requires overload or Scalar::Util |
| 186 | |
| 187 | for ( |
| 188 | [ 'undef', SCALAR => \undef ], |
| 189 | [ 'constant IV', SCALAR => \1 ], |
| 190 | [ 'constant NV', SCALAR => \1.0 ], |
| 191 | [ 'constant PV', SCALAR => \'f' ], |
| 192 | [ 'scalar', SCALAR => \$x ], |
| 193 | [ 'PVIV', SCALAR => \$pviv ], |
| 194 | [ 'PVNV', SCALAR => \$pvnv ], |
| 195 | [ 'PVMG', SCALAR => \$0 ], |
| 196 | [ 'PVBM', SCALAR => \PVBM ], |
| 197 | [ 'scalar @array', SCALAR => \scalar @array ], |
| 198 | [ 'scalar %hash', SCALAR => \scalar %hash ], |
| 199 | [ 'vstring', VSTRING => \v1 ], |
| 200 | [ 'ref', REF => \\1 ], |
| 201 | [ 'substr lvalue', LVALUE => \substr($x, 0, 0) ], |
| 202 | [ 'pos lvalue', LVALUE => \pos ], |
| 203 | [ 'vec lvalue', LVALUE => \vec($x,0,1) ], |
| 204 | [ 'named array', ARRAY => \@ary ], |
| 205 | [ 'anon array', ARRAY => [ 1 ] ], |
| 206 | [ 'named hash', HASH => \%whatever ], |
| 207 | [ 'anon hash', HASH => { a => 1 } ], |
| 208 | [ 'named sub', CODE => \&mysub, ], |
| 209 | [ 'anon sub', CODE => sub { 1; } ], |
| 210 | [ 'glob', GLOB => \*foo ], |
| 211 | [ 'format', FORMAT => *STDERR{FORMAT} ], |
| 212 | ) { |
| 213 | my ($desc, $type, $ref) = @$_; |
| 214 | is (ref $ref, $type, "ref() for ref to $desc"); |
| 215 | like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); |
| 216 | } |
| 217 | |
| 218 | is (ref *STDOUT{IO}, 'IO::File', 'IO refs are blessed into IO::File'); |
| 219 | like (*STDOUT{IO}, qr/^IO::File=IO\(0x[0-9a-f]+\)$/, |
| 220 | 'stringify for IO refs'); |
| 221 | |
| 222 | { # Test re-use of ref's TARG [perl #101738] |
| 223 | my $obj = bless [], '____'; |
| 224 | my $uniobj = bless [], chr 256; |
| 225 | my $get_ref = sub { ref shift }; |
| 226 | my $dummy = &$get_ref($uniobj); |
| 227 | $dummy = &$get_ref($obj); |
| 228 | ok exists { ____ => undef }->{$dummy}, 'ref sets UTF8 flag correctly'; |
| 229 | } |
| 230 | |
| 231 | # Test anonymous hash syntax. |
| 232 | |
| 233 | $anonhash = {}; |
| 234 | is (ref $anonhash, 'HASH'); |
| 235 | $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; |
| 236 | is (join('', sort values %$anonhash2), 'BARXYZ'); |
| 237 | |
| 238 | # Test bless operator. |
| 239 | |
| 240 | package MYHASH; |
| 241 | |
| 242 | $object = bless $main'anonhash2; |
| 243 | main::is (ref $object, 'MYHASH'); |
| 244 | main::is ($object->{ABC}, 'XYZ'); |
| 245 | |
| 246 | $object2 = bless {}; |
| 247 | main::is (ref $object2, 'MYHASH'); |
| 248 | |
| 249 | # Test ordinary call on object method. |
| 250 | |
| 251 | &mymethod($object,"argument"); |
| 252 | |
| 253 | sub mymethod { |
| 254 | local($THIS, @ARGS) = @_; |
| 255 | die 'Got a "' . ref($THIS). '" instead of a MYHASH' |
| 256 | unless ref $THIS eq 'MYHASH'; |
| 257 | main::is ($ARGS[0], "argument"); |
| 258 | main::is ($THIS->{FOO}, 'BAR'); |
| 259 | } |
| 260 | |
| 261 | # Test automatic destructor call. |
| 262 | |
| 263 | $string = "bad"; |
| 264 | $object = "foo"; |
| 265 | $string = "good"; |
| 266 | $main'anonhash2 = "foo"; |
| 267 | $string = ""; |
| 268 | |
| 269 | DESTROY { |
| 270 | return unless $string; |
| 271 | main::is ($string, 'good'); |
| 272 | |
| 273 | # Test that the object has not already been "cursed". |
| 274 | main::isnt (ref shift, 'HASH'); |
| 275 | } |
| 276 | |
| 277 | # Now test inheritance of methods. |
| 278 | |
| 279 | package OBJ; |
| 280 | |
| 281 | @ISA = ('BASEOBJ'); |
| 282 | |
| 283 | $main'object = bless {FOO => 'foo', BAR => 'bar'}; |
| 284 | |
| 285 | package main; |
| 286 | |
| 287 | # Test arrow-style method invocation. |
| 288 | |
| 289 | is ($object->doit("BAR"), 'bar'); |
| 290 | |
| 291 | # Test indirect-object-style method invocation. |
| 292 | |
| 293 | $foo = doit $object "FOO"; |
| 294 | main::is ($foo, 'foo'); |
| 295 | |
| 296 | sub BASEOBJ'doit { |
| 297 | local $ref = shift; |
| 298 | die "Not an OBJ" unless ref $ref eq 'OBJ'; |
| 299 | $ref->{shift()}; |
| 300 | } |
| 301 | |
| 302 | package UNIVERSAL; |
| 303 | @ISA = 'LASTCHANCE'; |
| 304 | |
| 305 | package LASTCHANCE; |
| 306 | sub foo { main::is ($_[1], 'works') } |
| 307 | |
| 308 | package WHATEVER; |
| 309 | foo WHATEVER "works"; |
| 310 | |
| 311 | # |
| 312 | # test the \(@foo) construct |
| 313 | # |
| 314 | package main; |
| 315 | @foo = \(1..3); |
| 316 | @bar = \(@foo); |
| 317 | @baz = \(1,@foo,@bar); |
| 318 | is (scalar (@bar), 3); |
| 319 | is (scalar grep(ref($_), @bar), 3); |
| 320 | is (scalar (@baz), 3); |
| 321 | |
| 322 | my(@fuu) = \(1..2,3); |
| 323 | my(@baa) = \(@fuu); |
| 324 | my(@bzz) = \(1,@fuu,@baa); |
| 325 | is (scalar (@baa), 3); |
| 326 | is (scalar grep(ref($_), @baa), 3); |
| 327 | is (scalar (@bzz), 3); |
| 328 | |
| 329 | # also, it can't be an lvalue |
| 330 | # (That’s what *you* think! --sprout) |
| 331 | eval '\\($x, $y) = (1, 2);'; |
| 332 | like ($@, qr/Can\'t modify.*ref.*in.*assignment(?x: |
| 333 | )|Experimental aliasing via reference not enabled/); |
| 334 | |
| 335 | # test for proper destruction of lexical objects |
| 336 | $test = curr_test(); |
| 337 | sub larry::DESTROY { print "# larry\nok $test\n"; } |
| 338 | sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } |
| 339 | sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } |
| 340 | |
| 341 | { |
| 342 | my ($joe, @curly, %larry); |
| 343 | my $moe = bless \$joe, 'moe'; |
| 344 | my $curly = bless \@curly, 'curly'; |
| 345 | my $larry = bless \%larry, 'larry'; |
| 346 | print "# leaving block\n"; |
| 347 | } |
| 348 | |
| 349 | print "# left block\n"; |
| 350 | curr_test($test + 3); |
| 351 | |
| 352 | # another glob test |
| 353 | |
| 354 | |
| 355 | $foo = "garbage"; |
| 356 | { local(*bar) = "foo" } |
| 357 | $bar = "glob 3"; |
| 358 | local(*bar) = *bar; |
| 359 | is ($bar, "glob 3"); |
| 360 | |
| 361 | $var = "glob 4"; |
| 362 | $_ = \$var; |
| 363 | is ($$_, 'glob 4'); |
| 364 | |
| 365 | |
| 366 | # test if reblessing during destruction results in more destruction |
| 367 | $test = curr_test(); |
| 368 | { |
| 369 | package A; |
| 370 | sub new { bless {}, shift } |
| 371 | DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } |
| 372 | package _B; |
| 373 | sub new { bless {}, shift } |
| 374 | DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } |
| 375 | package main; |
| 376 | my $b = _B->new; |
| 377 | } |
| 378 | curr_test($test + 2); |
| 379 | |
| 380 | # test if $_[0] is properly protected in DESTROY() |
| 381 | |
| 382 | { |
| 383 | my $test = curr_test(); |
| 384 | my $i = 0; |
| 385 | local $SIG{'__DIE__'} = sub { |
| 386 | my $m = shift; |
| 387 | if ($i++ > 4) { |
| 388 | print "# infinite recursion, bailing\nnot ok $test\n"; |
| 389 | exit 1; |
| 390 | } |
| 391 | like ($m, qr/^Modification of a read-only/); |
| 392 | }; |
| 393 | package C; |
| 394 | sub new { bless {}, shift } |
| 395 | DESTROY { $_[0] = 'foo' } |
| 396 | { |
| 397 | print "# should generate an error...\n"; |
| 398 | my $c = C->new; |
| 399 | } |
| 400 | print "# good, didn't recurse\n"; |
| 401 | } |
| 402 | |
| 403 | # test that DESTROY is called on all objects during global destruction, |
| 404 | # even those without hard references [perl #36347] |
| 405 | |
| 406 | is( |
| 407 | runperl( |
| 408 | stderr => 1, prog => 'sub DESTROY { print qq-aaa\n- } bless \$a[0]' |
| 409 | ), |
| 410 | "aaa\n", 'DESTROY called on array elem' |
| 411 | ); |
| 412 | is( |
| 413 | runperl( |
| 414 | stderr => 1, |
| 415 | prog => '{ bless \my@x; *a=sub{@x}}sub DESTROY { print qq-aaa\n- }' |
| 416 | ), |
| 417 | "aaa\n", |
| 418 | 'DESTROY called on closure variable' |
| 419 | ); |
| 420 | |
| 421 | # But cursing objects must not result in double frees |
| 422 | # This caused "Attempt to free unreferenced scalar" in 5.16. |
| 423 | fresh_perl_is( |
| 424 | 'bless \%foo::, bar::; bless \%bar::, foo::; print "ok\n"', "ok\n", |
| 425 | { stderr => 1 }, |
| 426 | 'no double free when stashes are blessed into each other'); |
| 427 | |
| 428 | |
| 429 | # test if refgen behaves with autoviv magic |
| 430 | { |
| 431 | my @a; |
| 432 | $a[1] = "good"; |
| 433 | my $got; |
| 434 | for (@a) { |
| 435 | $got .= ${\$_}; |
| 436 | $got .= ';'; |
| 437 | } |
| 438 | is ($got, ";good;"); |
| 439 | } |
| 440 | |
| 441 | # This test is the reason for postponed destruction in sv_unref |
| 442 | $a = [1,2,3]; |
| 443 | $a = $a->[1]; |
| 444 | is ($a, 2); |
| 445 | |
| 446 | # This test used to coredump. The BEGIN block is important as it causes the |
| 447 | # op that created the constant reference to be freed. Hence the only |
| 448 | # reference to the constant string "pass" is in $a. The hack that made |
| 449 | # sure $a = $a->[1] would work didn't work with references to constants. |
| 450 | |
| 451 | |
| 452 | foreach my $lexical ('', 'my $a; ') { |
| 453 | my $expect = "pass\n"; |
| 454 | my $result = runperl (switches => ['-wl'], stderr => 1, |
| 455 | prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); |
| 456 | |
| 457 | is ($?, 0); |
| 458 | is ($result, $expect); |
| 459 | } |
| 460 | |
| 461 | $test = curr_test(); |
| 462 | sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} |
| 463 | { my $a1 = bless [3],"x"; |
| 464 | my $a2 = bless [2],"x"; |
| 465 | { my $a3 = bless [1],"x"; |
| 466 | my $a4 = bless [0],"x"; |
| 467 | 567; |
| 468 | } |
| 469 | } |
| 470 | curr_test($test+4); |
| 471 | |
| 472 | is (runperl (switches=>['-l'], |
| 473 | prog=> 'print 1; print qq-*$\*-;print 1;'), |
| 474 | "1\n*\n*\n1\n"); |
| 475 | |
| 476 | # bug #21347 |
| 477 | |
| 478 | runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); |
| 479 | is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); |
| 480 | |
| 481 | runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); |
| 482 | is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); |
| 483 | |
| 484 | |
| 485 | # bug #22719 |
| 486 | |
| 487 | runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); |
| 488 | is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); |
| 489 | |
| 490 | # bug #27268: freeing self-referential typeglobs could trigger |
| 491 | # "Attempt to free unreferenced scalar" warnings |
| 492 | |
| 493 | is (runperl( |
| 494 | prog => 'use Symbol;my $x=bless \gensym,q{t}; print;*$$x=$x', |
| 495 | stderr => 1 |
| 496 | ), '', 'freeing self-referential typeglob'); |
| 497 | |
| 498 | # using a regex in the destructor for STDOUT segfaulted because the |
| 499 | # REGEX pad had already been freed (ithreads build only). The |
| 500 | # object is required to trigger the early freeing of GV refs to to STDOUT |
| 501 | |
| 502 | TODO: { |
| 503 | local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS'; |
| 504 | like (runperl( |
| 505 | prog => '$x=bless[]; sub IO::Handle::DESTROY{$_=q{bad};s/bad/ok/;print}', |
| 506 | stderr => 1 |
| 507 | ), qr/^(ok)+$/, 'STDOUT destructor'); |
| 508 | } |
| 509 | |
| 510 | { |
| 511 | no strict 'refs'; |
| 512 | $name8 = chr 163; |
| 513 | $name_utf8 = $name8 . chr 256; |
| 514 | chop $name_utf8; |
| 515 | |
| 516 | is ($$name8, undef, 'Nothing before we start'); |
| 517 | is ($$name_utf8, undef, 'Nothing before we start'); |
| 518 | $$name8 = "Pound"; |
| 519 | is ($$name8, "Pound", 'Accessing via 8 bit symref works'); |
| 520 | is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works'); |
| 521 | } |
| 522 | |
| 523 | { |
| 524 | no strict 'refs'; |
| 525 | $name_utf8 = $name = chr 9787; |
| 526 | utf8::encode $name_utf8; |
| 527 | |
| 528 | is (length $name, 1, "Name is 1 char"); |
| 529 | is (length $name_utf8, 3, "UTF8 representation is 3 chars"); |
| 530 | |
| 531 | is ($$name, undef, 'Nothing before we start'); |
| 532 | is ($$name_utf8, undef, 'Nothing before we start'); |
| 533 | $$name = "Face"; |
| 534 | is ($$name, "Face", 'Accessing via Unicode symref works'); |
| 535 | is ($$name_utf8, undef, |
| 536 | 'Accessing via the UTF8 byte sequence gives nothing'); |
| 537 | } |
| 538 | |
| 539 | { |
| 540 | no strict 'refs'; |
| 541 | $name1 = "\0Chalk"; |
| 542 | $name2 = "\0Cheese"; |
| 543 | |
| 544 | isnt ($name1, $name2, "They differ"); |
| 545 | |
| 546 | is ($$name1, undef, 'Nothing before we start (scalars)'); |
| 547 | is ($$name2, undef, 'Nothing before we start'); |
| 548 | $$name1 = "Yummy"; |
| 549 | is ($$name1, "Yummy", 'Accessing via the correct name works'); |
| 550 | is ($$name2, undef, |
| 551 | 'Accessing via a different NUL-containing name gives nothing'); |
| 552 | # defined uses a different code path |
| 553 | ok (defined $$name1, 'defined via the correct name works'); |
| 554 | ok (!defined $$name2, |
| 555 | 'defined via a different NUL-containing name gives nothing'); |
| 556 | |
| 557 | is ($name1->[0], undef, 'Nothing before we start (arrays)'); |
| 558 | is ($name2->[0], undef, 'Nothing before we start'); |
| 559 | $name1->[0] = "Yummy"; |
| 560 | is ($name1->[0], "Yummy", 'Accessing via the correct name works'); |
| 561 | is ($name2->[0], undef, |
| 562 | 'Accessing via a different NUL-containing name gives nothing'); |
| 563 | ok (defined $name1->[0], 'defined via the correct name works'); |
| 564 | ok (!defined$name2->[0], |
| 565 | 'defined via a different NUL-containing name gives nothing'); |
| 566 | |
| 567 | my (undef, $one) = @{$name1}[2,3]; |
| 568 | my (undef, $two) = @{$name2}[2,3]; |
| 569 | is ($one, undef, 'Nothing before we start (array slices)'); |
| 570 | is ($two, undef, 'Nothing before we start'); |
| 571 | @{$name1}[2,3] = ("Very", "Yummy"); |
| 572 | (undef, $one) = @{$name1}[2,3]; |
| 573 | (undef, $two) = @{$name2}[2,3]; |
| 574 | is ($one, "Yummy", 'Accessing via the correct name works'); |
| 575 | is ($two, undef, |
| 576 | 'Accessing via a different NUL-containing name gives nothing'); |
| 577 | ok (defined $one, 'defined via the correct name works'); |
| 578 | ok (!defined $two, |
| 579 | 'defined via a different NUL-containing name gives nothing'); |
| 580 | |
| 581 | is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); |
| 582 | is ($name2->{PWOF}, undef, 'Nothing before we start'); |
| 583 | $name1->{PWOF} = "Yummy"; |
| 584 | is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); |
| 585 | is ($name2->{PWOF}, undef, |
| 586 | 'Accessing via a different NUL-containing name gives nothing'); |
| 587 | ok (defined $name1->{PWOF}, 'defined via the correct name works'); |
| 588 | ok (!defined $name2->{PWOF}, |
| 589 | 'defined via a different NUL-containing name gives nothing'); |
| 590 | |
| 591 | my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; |
| 592 | my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; |
| 593 | is ($one, undef, 'Nothing before we start (hash slices)'); |
| 594 | is ($two, undef, 'Nothing before we start'); |
| 595 | @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy"); |
| 596 | (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; |
| 597 | (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; |
| 598 | is ($one, "Yummy", 'Accessing via the correct name works'); |
| 599 | is ($two, undef, |
| 600 | 'Accessing via a different NUL-containing name gives nothing'); |
| 601 | ok (defined $one, 'defined via the correct name works'); |
| 602 | ok (!defined $two, |
| 603 | 'defined via a different NUL-containing name gives nothing'); |
| 604 | |
| 605 | $name1 = "Left"; $name2 = "Left\0Right"; |
| 606 | my $glob2 = *{$name2}; |
| 607 | |
| 608 | is ($glob1, undef, "We get different typeglobs. In fact, undef"); |
| 609 | |
| 610 | *{$name1} = sub {"One"}; |
| 611 | *{$name2} = sub {"Two"}; |
| 612 | |
| 613 | is (&{$name1}, "One"); |
| 614 | is (&{$name2}, "Two"); |
| 615 | } |
| 616 | |
| 617 | # test derefs after list slice |
| 618 | |
| 619 | is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' ); |
| 620 | is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' ); |
| 621 | is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' ); |
| 622 | is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' ); |
| 623 | is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' ); |
| 624 | is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); |
| 625 | |
| 626 | # deref on empty list shouldn't autovivify |
| 627 | { |
| 628 | local $@; |
| 629 | eval { ()[0]{foo} }; |
| 630 | like ( "$@", qr/Can't use an undefined value as a HASH reference/, |
| 631 | "deref of undef from list slice fails" ); |
| 632 | } |
| 633 | |
| 634 | # test dereferencing errors |
| 635 | { |
| 636 | format STDERR = |
| 637 | . |
| 638 | my $ref; |
| 639 | foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { |
| 640 | eval q/ $$ref /; |
| 641 | like($@, qr/Not a SCALAR reference/, "Scalar dereference"); |
| 642 | eval q/ @$ref /; |
| 643 | like($@, qr/Not an ARRAY reference/, "Array dereference"); |
| 644 | eval q/ %$ref /; |
| 645 | like($@, qr/Not a HASH reference/, "Hash dereference"); |
| 646 | eval q/ &$ref /; |
| 647 | like($@, qr/Not a CODE reference/, "Code dereference"); |
| 648 | } |
| 649 | |
| 650 | $ref = *STDERR{FORMAT}; |
| 651 | eval q/ *$ref /; |
| 652 | like($@, qr/Not a GLOB reference/, "Glob dereference"); |
| 653 | |
| 654 | $ref = *STDOUT{IO}; |
| 655 | eval q/ *$ref /; |
| 656 | is($@, '', "Glob dereference of PVIO is acceptable"); |
| 657 | |
| 658 | is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); |
| 659 | } |
| 660 | |
| 661 | # these will segfault if they fail |
| 662 | |
| 663 | my $pvbm = PVBM; |
| 664 | my $rpvbm = \$pvbm; |
| 665 | |
| 666 | ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); |
| 667 | ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); |
| 668 | ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); |
| 669 | ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); |
| 670 | ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); |
| 671 | ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); |
| 672 | ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); |
| 673 | |
| 674 | # bug 24254 |
| 675 | is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); |
| 676 | is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); |
| 677 | is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); |
| 678 | my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : ''; |
| 679 | is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n"); |
| 680 | is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n"); |
| 681 | is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); |
| 682 | |
| 683 | # bug 57564 |
| 684 | is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); |
| 685 | |
| 686 | # The mechanism for freeing objects in globs used to leave dangling |
| 687 | # pointers to freed SVs. To test this, we construct this nested structure: |
| 688 | # GV => blessed(AV) => RV => GV => blessed(SV) |
| 689 | # all with a refcnt of 1, and hope that the second GV gets processed first |
| 690 | # by do_clean_named_objs. Then when the first GV is processed, it mustn't |
| 691 | # find anything nasty left by the previous GV processing. |
| 692 | # The eval is stop things in the main body of the code holding a reference |
| 693 | # to a GV, and the print at the end seems to bee necessary to ensure |
| 694 | # the correct freeing order of *x and *y (no, I don't know why - DAPM). |
| 695 | |
| 696 | is (runperl( |
| 697 | prog => 'eval q[bless \@y; bless \$x; $y[0] = \*x; $z = \*y; ]; ' |
| 698 | . 'delete $::{x}; delete $::{y}; print qq{ok\n};', |
| 699 | stderr => 1), |
| 700 | "ok\n", 'freeing freed glob in global destruction'); |
| 701 | |
| 702 | |
| 703 | # Test undefined hash references as arguments to %{} in boolean context |
| 704 | # [perl #81750] |
| 705 | { |
| 706 | no strict 'refs'; |
| 707 | eval { my $foo; %$foo; }; ok !$@, '%$undef'; |
| 708 | eval { my $foo; scalar %$foo; }; ok !$@, 'scalar %$undef'; |
| 709 | eval { my $foo; !%$foo; }; ok !$@, '!%$undef'; |
| 710 | eval { my $foo; if ( %$foo) {} }; ok !$@, 'if ( %$undef) {}'; |
| 711 | eval { my $foo; if (!%$foo) {} }; ok !$@, 'if (!%$undef) {}'; |
| 712 | eval { my $foo; unless ( %$foo) {} }; ok !$@, 'unless ( %$undef) {}'; |
| 713 | eval { my $foo; unless (!%$foo) {} }; ok !$@, 'unless (!%$undef) {}'; |
| 714 | eval { my $foo; 1 if %$foo; }; ok !$@, '1 if %$undef'; |
| 715 | eval { my $foo; 1 if !%$foo; }; ok !$@, '1 if !%$undef'; |
| 716 | eval { my $foo; 1 unless %$foo; }; ok !$@, '1 unless %$undef;'; |
| 717 | eval { my $foo; 1 unless ! %$foo; }; ok !$@, '1 unless ! %$undef'; |
| 718 | eval { my $foo; %$foo ? 1 : 0; }; ok !$@, ' %$undef ? 1 : 0'; |
| 719 | eval { my $foo; !%$foo ? 1 : 0; }; ok !$@, '!%$undef ? 1 : 0'; |
| 720 | } |
| 721 | |
| 722 | # RT #88330 |
| 723 | # Make sure that a leaked thinggy with multiple weak references to |
| 724 | # it doesn't trigger a panic with multiple rounds of global cleanup |
| 725 | # (Perl_sv_clean_all). |
| 726 | |
| 727 | SKIP: { |
| 728 | skip_if_miniperl('no Scalar::Util under miniperl', 4); |
| 729 | |
| 730 | local $ENV{PERL_DESTRUCT_LEVEL} = 2; |
| 731 | |
| 732 | # we do all permutations of array/hash, 1ref/2ref, to account |
| 733 | # for the different way backref magic is stored |
| 734 | |
| 735 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 1 weak ref'); |
| 736 | use Scalar::Util qw(weaken); |
| 737 | my $r = []; |
| 738 | Internals::SvREFCNT(@$r, 9); |
| 739 | my $r1 = $r; |
| 740 | weaken($r1); |
| 741 | print "ok"; |
| 742 | EOF |
| 743 | |
| 744 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 2 weak refs'); |
| 745 | use Scalar::Util qw(weaken); |
| 746 | my $r = []; |
| 747 | Internals::SvREFCNT(@$r, 9); |
| 748 | my $r1 = $r; |
| 749 | weaken($r1); |
| 750 | my $r2 = $r; |
| 751 | weaken($r2); |
| 752 | print "ok"; |
| 753 | EOF |
| 754 | |
| 755 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 1 weak ref'); |
| 756 | use Scalar::Util qw(weaken); |
| 757 | my $r = {}; |
| 758 | Internals::SvREFCNT(%$r, 9); |
| 759 | my $r1 = $r; |
| 760 | weaken($r1); |
| 761 | print "ok"; |
| 762 | EOF |
| 763 | |
| 764 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 2 weak refs'); |
| 765 | use Scalar::Util qw(weaken); |
| 766 | my $r = {}; |
| 767 | Internals::SvREFCNT(%$r, 9); |
| 768 | my $r1 = $r; |
| 769 | weaken($r1); |
| 770 | my $r2 = $r; |
| 771 | weaken($r2); |
| 772 | print "ok"; |
| 773 | EOF |
| 774 | |
| 775 | } |
| 776 | |
| 777 | SKIP:{ |
| 778 | skip_if_miniperl "no Scalar::Util on miniperl", 1; |
| 779 | my $error; |
| 780 | *hassgropper::DESTROY = sub { |
| 781 | require Scalar::Util; |
| 782 | eval { Scalar::Util::weaken($_[0]) }; |
| 783 | $error = $@; |
| 784 | # This line caused a crash before weaken refused to weaken a |
| 785 | # read-only reference: |
| 786 | $do::not::overwrite::this = $_[0]; |
| 787 | }; |
| 788 | my $xs = bless [], "hassgropper"; |
| 789 | undef $xs; |
| 790 | like $error, qr/^Modification of a read-only/, |
| 791 | 'weaken refuses to weaken a read-only ref'; |
| 792 | # Now that the test has passed, avoid sabotaging global destruction: |
| 793 | undef *hassgropper::DESTROY; |
| 794 | undef $do::not::overwrite::this; |
| 795 | } |
| 796 | |
| 797 | |
| 798 | is ref( bless {}, "nul\0clean" ), "nul\0clean", "ref() is nul-clean"; |
| 799 | |
| 800 | # Test constants and references thereto. |
| 801 | for (3) { |
| 802 | eval { $_ = 4 }; |
| 803 | like $@, qr/^Modification of a read-only/, |
| 804 | 'assignment to value aliased to literal number'; |
| 805 | eval { ${\$_} = 4 }; |
| 806 | like $@, qr/^Modification of a read-only/, |
| 807 | 'refgen does not allow assignment to value aliased to literal number'; |
| 808 | } |
| 809 | for ("4eounthouonth") { |
| 810 | eval { $_ = 4 }; |
| 811 | like $@, qr/^Modification of a read-only/, |
| 812 | 'assignment to value aliased to literal string'; |
| 813 | eval { ${\$_} = 4 }; |
| 814 | like $@, qr/^Modification of a read-only/, |
| 815 | 'refgen does not allow assignment to value aliased to literal string'; |
| 816 | } |
| 817 | { |
| 818 | my $aref = \123; |
| 819 | is \$$aref, $aref, |
| 820 | '[perl #109746] referential identity of \literal under threads+mad' |
| 821 | } |
| 822 | |
| 823 | # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. |
| 824 | $test = curr_test(); |
| 825 | curr_test($test + 3); |
| 826 | # test global destruction |
| 827 | |
| 828 | my $test1 = $test + 1; |
| 829 | my $test2 = $test + 2; |
| 830 | |
| 831 | package FINALE; |
| 832 | |
| 833 | { |
| 834 | $ref3 = bless ["ok $test2\n"]; # package destruction |
| 835 | my $ref2 = bless ["ok $test1\n"]; # lexical destruction |
| 836 | local $ref1 = bless ["ok $test\n"]; # dynamic destruction |
| 837 | 1; # flush any temp values on stack |
| 838 | } |
| 839 | |
| 840 | DESTROY { |
| 841 | print $_[0][0]; |
| 842 | } |
| 843 | |