13 BEGIN { print "# Tests with caller(0)\n"; }
16 ok( (!@c), "caller(0) in main program" );
18 eval { @c = caller(0) };
19 is( $c[3], "(eval)", "subroutine name in an eval {}" );
20 ok( !$c[4], "hasargs false in an eval {}" );
22 eval q{ @c = caller(0) };
23 is( $c[3], "(eval)", "subroutine name in an eval ''" );
24 ok( !$c[4], "hasargs false in an eval ''" );
26 sub { @c = caller(0) } -> ();
27 is( $c[3], "main::__ANON__", "anonymous subroutine name" );
28 ok( $c[4], "hasargs true with anon sub" );
30 # Bug 20020517.003, used to dump core
31 sub foo { @c = caller(0) }
32 my $fooref = delete $::{foo};
34 is( $c[3], "main::foo", "deleted subroutine name" );
35 ok( $c[4], "hasargs true with deleted sub" );
39 is +(caller 0)[1], __FILE__,
40 "[perl #68712] filenames after require in a BEGIN block"
43 print "# Tests with caller(1)\n";
45 sub f { @c = caller(1) }
49 is( $c[3], "main::callf", "subroutine name" );
50 ok( $c[4], "hasargs true with callf()" );
52 ok( !$c[4], "hasargs false with &callf" );
55 is( $c[3], "(eval)", "subroutine name in an eval {}" );
56 ok( !$c[4], "hasargs false in an eval {}" );
59 is( $c[3], "(eval)", "subroutine name in an eval ''" );
60 ok( !$c[4], "hasargs false in an eval ''" );
63 is( $c[3], "main::__ANON__", "anonymous subroutine name" );
64 ok( $c[4], "hasargs true with anon sub" );
67 my $fooref2 = delete $::{foo2};
69 is( $c[3], "main::foo2", "deleted subroutine name" );
70 ok( $c[4], "hasargs true with deleted sub" );
72 # See if caller() returns the correct warning mask
78 foreach (unpack('W*', $in)) {
79 $out .= sprintf('\x%02x', $_);
86 local $Level = $Level + 2;
87 my ($got, $exp, $desc) = @_;
88 if (! ok($got eq $exp, $desc)) {
89 diag(' got: ' . show_bits($got));
90 diag('expected: ' . show_bits($exp));
97 check_bits( (caller(0))[9], $w, "warnings match caller ($id)");
102 # Build the warnings mask dynamically
103 my ($default, $registered);
105 for my $i (0..$warnings::LAST_BIT/2 - 1) {
106 vec($default, $i, 2) = 1;
108 $registered = $default;
109 vec($registered, $warnings::LAST_BIT/2, 2) = 1;
112 BEGIN { check_bits( ${^WARNING_BITS}, "\0" x $warnings::BYTES, 'all bits off via "no warnings"' ) }
113 testwarn("\0" x $warnings::BYTES, 'no bits');
116 BEGIN { check_bits( ${^WARNING_BITS}, $default,
117 'default bits on via "use warnings"' ); }
118 BEGIN { testwarn($default, 'all'); }
120 # the warning mask has been extended by warnings::register
121 testwarn($registered, 'ahead of w::r');
123 use warnings::register;
124 BEGIN { check_bits( ${^WARNING_BITS}, $registered,
125 'warning bits on via "use warnings::register"' ) }
126 testwarn($registered, 'following w::r');
130 # The next two cases test for a bug where caller ignored evals if
131 # the DB::sub glob existed but &DB::sub did not (for example, if
132 # $^P had been set but no debugger has been loaded). The tests
133 # thus assume that there is no &DB::sub: if there is one, they
134 # should both pass no matter whether or not this bug has been
137 my $debugger_test = q<
138 my @stackinfo = caller(0);
139 return scalar @stackinfo;
142 sub pb { return (caller(0))[3] }
144 my $i = eval $debugger_test;
145 is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
147 is( eval 'pb()', 'main::pb', "actually return the right function name" );
149 my $saved_perldb = $^P;
153 $i = eval $debugger_test;
154 is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
155 is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
157 print "# caller can now return the compile time state of %^H\n";
162 my @results = caller($level||0);
163 exists $results[10]->{$key};
169 my @results = caller($level||0);
170 $results[10]->{$key};
174 my $tmpfile = tempfile();
176 open my $fh, '>', $tmpfile or die "open $tmpfile: $!";
189 @DB::args = bless [], 'KAZASH';
192 print scalar @DB::args;
198 @DB::args = (); # At this point, the object should be freed.
201 print scalar @DB::args;
208 my $got = runperl(progfile => $tmpfile, args => [$_]);
210 like($got, qr/\s*0 1 DESTROY 0 0\s*/,
211 "\@DB::args doesn't leak with \$^P = $_");
215 # This also used to leak [perl #97010]:
218 sub fwib::DESTROY { ++$gone }
220 sub { () = caller(0) }->(); # initialise PL_dbargs
221 @args = bless[],'fwib';
222 sub { () = caller(0) }->(); # clobber @args without initialisation
223 ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL';
226 # And this crashed [perl #93320]:
233 pass 'No crash when @DB::args is freed between caller calls';
237 sub TIEARRAY { bless [] }
240 sub FETCH { $_[0][$_[1]] }
241 sub STORE { $_[0][$_[1]] = $_[2] }
244 eval { sub { () = caller 0; } ->(1..3) };
245 ::like $@, qr "^Cannot set tied \@DB::args at ",
246 'caller dies with tie @DB::args';
247 ::ok tied @args, '@DB::args is still tied';
252 fresh_perl_is <<'END', "ok\n", {},
253 { package foo; sub bar { main::bar() } }
257 my $y = \($1+2); # this is the one that reuses the mem addr, but
258 my $z = \($1+2); # try the others just in case
259 s/2// for $$x, $$y, $$z; # now SvOOK
265 "No crash when freed stash is reused for PV with offset hack";
267 is eval "(caller 0)[6]", "(caller 0)[6]",
268 'eval text returned by caller does not include \n;';
271 is (sub { (caller)[2] }->(), __LINE__,
272 '[perl #115768] caller gets line numbers from nulled cops');
274 # Test it at the end of the program, too.
275 fresh_perl_is(<<'115768', 2, {},
279 sub foo { print +(caller)[2] }
281 '[perl #115768] caller gets line numbers from nulled cops (2)');
283 # PL_linestr should not be modifiable
284 eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"';
285 pass "no assertion failure after modifying eval text via caller";
287 is eval "<<END;\nfoo\nEND\n(caller 0)[6]",
288 "<<END;\nfoo\nEND\n(caller 0)[6]",
289 'here-docs do not gut eval text';
290 is eval "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
291 "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
292 'here-docs in quote-like ops do not gut eval text';
294 # The bitmask should be assignable to ${^WARNING_BITS} without resulting in
295 # different warnings settings.
297 my $ bits = sub { (caller 0)[9] }->();
299 local $SIG{__WARN__} = sub { $w++ };
302 BEGIN { ${^WARNING_BITS} = $bits }
308 is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}';
311 # This was fixed with commit d4d03940c58a0177, which fixed bug #78742
312 fresh_perl_is <<'END', "__ANON__::doof\n", {},
315 sub doof { caller(0) }
318 "caller should not SEGV when the current package is undefined";
320 # caller should not SEGV when the eval entry has been cleared #120998
321 fresh_perl_is <<'END', 'main', {},
322 $SIG{__DIE__} = \&dbdie;
329 "caller should not SEGV for eval '' stack frames";
331 $::testing_caller = 1;
333 do './op/caller.pl' or die $@;