X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/250d67eb8e42c118b44bb5437965a1f4a8a0d828..a8b7548118623521a01940403176f14c40bf1320:/t/op/caller.t diff --git a/t/op/caller.t b/t/op/caller.t index 5d27ea5..1ffb5b3 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -3,14 +3,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; - plan( tests => 78 ); + set_up_inc('../lib'); + plan( tests => 100 ); # some tests are run in a BEGIN block } my @c; -print "# Tests with caller(0)\n"; +BEGIN { print "# Tests with caller(0)\n"; } @c = caller(0); ok( (!@c), "caller(0) in main program" ); @@ -19,7 +19,7 @@ eval { @c = caller(0) }; is( $c[3], "(eval)", "subroutine name in an eval {}" ); ok( !$c[4], "hasargs false in an eval {}" ); -eval q{ @c = (Caller(0))[3] }; +eval q{ @c = caller(0) }; is( $c[3], "(eval)", "subroutine name in an eval ''" ); ok( !$c[4], "hasargs false in an eval ''" ); @@ -27,12 +27,18 @@ sub { @c = caller(0) } -> (); is( $c[3], "main::__ANON__", "anonymous subroutine name" ); ok( $c[4], "hasargs true with anon sub" ); -# Bug 20020517.003, used to dump core +# Bug 20020517.003 (#9367), used to dump core sub foo { @c = caller(0) } my $fooref = delete $::{foo}; $fooref -> (); -is( $c[3], "(unknown)", "unknown subroutine name" ); -ok( $c[4], "hasargs true with unknown sub" ); +is( $c[3], "main::foo", "deleted subroutine name" ); +ok( $c[4], "hasargs true with deleted sub" ); + +BEGIN { + require strict; + is +(caller 0)[1], __FILE__, + "[perl #68712] filenames after require in a BEGIN block" +} print "# Tests with caller(1)\n"; @@ -60,32 +66,64 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo2 { f() } my $fooref2 = delete $::{foo2}; $fooref2 -> (); -is( $c[3], "(unknown)", "unknown subroutine name" ); -ok( $c[4], "hasargs true with unknown sub" ); +is( $c[3], "main::foo2", "deleted subroutine name" ); +ok( $c[4], "hasargs true with deleted sub" ); # See if caller() returns the correct warning mask +sub show_bits +{ + my $in = shift; + my $out = ''; + foreach (unpack('W*', $in)) { + $out .= sprintf('\x%02x', $_); + } + return $out; +} + +sub check_bits +{ + local $Level = $Level + 2; + my ($got, $exp, $desc) = @_; + if (! ok($got eq $exp, $desc)) { + diag(' got: ' . show_bits($got)); + diag('expected: ' . show_bits($exp)); + } +} + sub testwarn { my $w = shift; - is( (caller(0))[9], $w, "warnings match caller"); + my $id = shift; + check_bits( (caller(0))[9], $w, "warnings match caller ($id)"); } -# NB : extend the warning mask values below when new warnings are added { no warnings; - BEGIN { is( ${^WARNING_BITS}, "\0" x 12, 'all bits off via "no warnings"' ) } - testwarn("\0" x 12); + # Build the warnings mask dynamically + my ($default, $registered); + BEGIN { + for my $i (0..$warnings::LAST_BIT/2 - 1) { + vec($default, $i, 2) = 1; + } + $registered = $default; + vec($registered, $warnings::LAST_BIT/2, 2) = 1; + } + + BEGIN { check_bits( ${^WARNING_BITS}, "\0" x $warnings::BYTES, 'all bits off via "no warnings"' ) } + testwarn("\0" x $warnings::BYTES, 'no bits'); use warnings; - BEGIN { is( ${^WARNING_BITS}, "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\025", 'default bits on via "use warnings"' ); } - BEGIN { testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\025", "#1"); } + BEGIN { check_bits( ${^WARNING_BITS}, $default, + 'default bits on via "use warnings"' ); } + BEGIN { testwarn($default, 'all'); } # run-time : # the warning mask has been extended by warnings::register - testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55"); + testwarn($registered, 'ahead of w::r'); use warnings::register; - BEGIN { is( ${^WARNING_BITS}, "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", 'warning bits on via "use warnings::register"' ) } - testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55","#3"); + BEGIN { check_bits( ${^WARNING_BITS}, $registered, + 'warning bits on via "use warnings::register"' ) } + testwarn($registered, 'following w::r'); } @@ -132,6 +170,199 @@ sub hint_fetch { $results[10]->{$key}; } +{ + my $tmpfile = tempfile(); + + open my $fh, '>', $tmpfile or die "open $tmpfile: $!"; + print $fh <<'EOP'; +#!perl -wl +use strict; + +{ + package KAZASH ; + + sub DESTROY { + print "DESTROY"; + } +} + +@DB::args = bless [], 'KAZASH'; + +print $^P; +print scalar @DB::args; + +{ + local $^P = shift; +} + +@DB::args = (); # At this point, the object should be freed. + +print $^P; +print scalar @DB::args; + +# It shouldn't leak. +EOP + close $fh; + + foreach (0, 1) { + my $got = runperl(progfile => $tmpfile, args => [$_]); + $got =~ s/\s+/ /gs; + like($got, qr/\s*0 1 DESTROY 0 0\s*/, + "\@DB::args doesn't leak with \$^P = $_"); + } +} + +# This also used to leak [perl #97010]: +{ + my $gone; + sub fwib::DESTROY { ++$gone } + package DB; + sub { () = caller(0) }->(); # initialise PL_dbargs + @args = bless[],'fwib'; + sub { () = caller(0) }->(); # clobber @args without initialisation + ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL'; +} + +# And this crashed [perl #93320]: +sub { + package DB; + ()=caller(0); + undef *DB::args; + ()=caller(0); +}->(); +pass 'No crash when @DB::args is freed between caller calls'; + +# This also crashed: +package glelp; +sub TIEARRAY { bless [] } +sub EXTEND { } +sub CLEAR { } +sub FETCH { $_[0][$_[1]] } +sub STORE { $_[0][$_[1]] = $_[2] } +package DB; +tie @args, 'glelp'; +eval { sub { () = caller 0; } ->(1..3) }; +::like $@, qr "^Cannot set tied \@DB::args at ", + 'caller dies with tie @DB::args'; +::ok tied @args, '@DB::args is still tied'; +untie @args; +package main; + +# [perl #113486] +fresh_perl_is <<'END', "ok\n", {}, + { package foo; sub bar { main::bar() } } + sub bar { + delete $::{"foo::"}; + my $x = \($1+2); + my $y = \($1+2); # this is the one that reuses the mem addr, but + my $z = \($1+2); # try the others just in case + s/2// for $$x, $$y, $$z; # now SvOOK + $x = caller; + print "ok\n"; +}; +foo::bar +END + "No crash when freed stash is reused for PV with offset hack"; + +is eval "(caller 0)[6]", "(caller 0)[6]", + 'eval text returned by caller does not include \n;'; + +if (1) { + is (sub { (caller)[2] }->(), __LINE__, + '[perl #115768] caller gets line numbers from nulled cops'); +} +# Test it at the end of the program, too. +fresh_perl_is(<<'115768', 2, {}, + if (1) { + foo(); + } + sub foo { print +(caller)[2] } +115768 + '[perl #115768] caller gets line numbers from nulled cops (2)'); + +# PL_linestr should not be modifiable +eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"'; +pass "no assertion failure after modifying eval text via caller"; + +is eval "<(); + my $w; + local $SIG{__WARN__} = sub { $w++ }; + eval ' + use warnings; + BEGIN { ${^WARNING_BITS} = $bits } + local $^W = 1; + () = 1 + undef; + $^W = 0; + () = 1 + undef; + '; + is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}'; +} + +# [perl #126991] +sub getlineno { (caller)[2] } +my $line = eval "\n#line 3000000000\ngetlineno();"; +is $line, "3000000000", "check large line numbers are preserved"; + +# This was fixed with commit d4d03940c58a0177, which fixed bug #78742 +fresh_perl_is <<'END', "__ANON__::doof\n", {}, +package foo; +BEGIN {undef %foo::} +sub doof { caller(0) } +print +(doof())[3]; +END + "caller should not SEGV when the current package is undefined"; + +# caller should not SEGV when the eval entry has been cleared #120998 +fresh_perl_is <<'END', 'main', {}, +$SIG{__DIE__} = \&dbdie; +eval '/x'; +sub dbdie { + @x = caller(1); + print $x[0]; +} +END + "caller should not SEGV for eval '' stack frames"; + +TODO: { + local $::TODO = 'RT #7165: line number should be consistent for multiline subroutine calls'; + fresh_perl_is(<<'EOP', "6\n9\n", {}, 'RT #7165: line number should be consistent for multiline subroutine calls'); + sub tagCall { + my ($package, $file, $line) = caller; + print "$line\n"; + } + + tagCall + "abc"; + + tagCall + sub {}; +EOP +} + $::testing_caller = 1; -do './op/caller.pl'; +do './op/caller.pl' or die $@; + +{ + package RT129239; + BEGIN { + my ($pkg, $file, $line) = caller; + ::is $file, 'virtually/op/caller.t', "BEGIN block sees correct caller filename"; + ::is $line, 12345, "BEGIN block sees correct caller line"; + TODO: { + local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]"; + ::is $pkg, 'RT129239', "BEGIN block sees correct caller package"; + } +#line 12345 "virtually/op/caller.t" + } +}