This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add new release to perlhist
[perl5.git] / t / op / caller.t
CommitLineData
07b8c804
RGS
1#!./perl
2# Tests for caller()
3
4BEGIN {
5 chdir 't' if -d 't';
07b8c804 6 require './test.pl';
624c42e2 7 set_up_inc('../lib');
07b8c804
RGS
8}
9
d190dde9
N
10my @tests;
11plan( tests => 100 );
12
13print "# Tests with caller(0)\n";
14
15foreach my $t ( @tests ) {
16 my $s = \&{'main::'.$t->{type}};
17 $s->( @{$t->{args}}, $t->{txt} );
18}
19print "# end of BEGIN tests\n";
07b8c804 20
d190dde9 21my @c;
72699b0f 22
07b8c804
RGS
23@c = caller(0);
24ok( (!@c), "caller(0) in main program" );
25
26eval { @c = caller(0) };
72699b0f
RGS
27is( $c[3], "(eval)", "subroutine name in an eval {}" );
28ok( !$c[4], "hasargs false in an eval {}" );
07b8c804 29
47301516 30eval q{ @c = caller(0) };
72699b0f
RGS
31is( $c[3], "(eval)", "subroutine name in an eval ''" );
32ok( !$c[4], "hasargs false in an eval ''" );
07b8c804
RGS
33
34sub { @c = caller(0) } -> ();
72699b0f
RGS
35is( $c[3], "main::__ANON__", "anonymous subroutine name" );
36ok( $c[4], "hasargs true with anon sub" );
07b8c804 37
ee95e30c 38# Bug 20020517.003 (#9367), used to dump core
07b8c804
RGS
39sub foo { @c = caller(0) }
40my $fooref = delete $::{foo};
41$fooref -> ();
2eaf799e 42is( $c[3], "main::foo", "deleted subroutine name" );
803f2748 43ok( $c[4], "hasargs true with deleted sub" );
72699b0f 44
b2ef6d44
FC
45BEGIN {
46 require strict;
d190dde9
N
47 push @tests, { type => 'is', args => [ +(caller 0)[1], __FILE__ ],
48 txt => "[perl #68712] filenames after require in a BEGIN block" };
b2ef6d44
FC
49}
50
72699b0f 51print "# Tests with caller(1)\n";
07b8c804
RGS
52
53sub f { @c = caller(1) }
54
72699b0f
RGS
55sub callf { f(); }
56callf();
57is( $c[3], "main::callf", "subroutine name" );
58ok( $c[4], "hasargs true with callf()" );
59&callf;
60ok( !$c[4], "hasargs false with &callf" );
61
07b8c804 62eval { f() };
72699b0f
RGS
63is( $c[3], "(eval)", "subroutine name in an eval {}" );
64ok( !$c[4], "hasargs false in an eval {}" );
07b8c804
RGS
65
66eval q{ f() };
72699b0f
RGS
67is( $c[3], "(eval)", "subroutine name in an eval ''" );
68ok( !$c[4], "hasargs false in an eval ''" );
07b8c804
RGS
69
70sub { f() } -> ();
72699b0f
RGS
71is( $c[3], "main::__ANON__", "anonymous subroutine name" );
72ok( $c[4], "hasargs true with anon sub" );
07b8c804
RGS
73
74sub foo2 { f() }
75my $fooref2 = delete $::{foo2};
76$fooref2 -> ();
2eaf799e 77is( $c[3], "main::foo2", "deleted subroutine name" );
803f2748 78ok( $c[4], "hasargs true with deleted sub" );
75b6c4ca
RGS
79
80# See if caller() returns the correct warning mask
81
886f1e3e
JH
82sub show_bits
83{
84 my $in = shift;
85 my $out = '';
86 foreach (unpack('W*', $in)) {
87 $out .= sprintf('\x%02x', $_);
88 }
89 return $out;
90}
91
92sub check_bits
93{
ac27d13b 94 local $Level = $Level + 2;
886f1e3e
JH
95 my ($got, $exp, $desc) = @_;
96 if (! ok($got eq $exp, $desc)) {
97 diag(' got: ' . show_bits($got));
98 diag('expected: ' . show_bits($exp));
99 }
100}
101
75b6c4ca
RGS
102sub testwarn {
103 my $w = shift;
886f1e3e
JH
104 my $id = shift;
105 check_bits( (caller(0))[9], $w, "warnings match caller ($id)");
75b6c4ca
RGS
106}
107
d190dde9
N
108sub get_caller_0_9 {
109 return (caller(0))[9];
110}
111
112sub get_caller_0_9 {
113 return (caller(0))[9];
114}
115
116sub get_caller_0_9 {
117 return (caller(0))[9];
118}
119
75b6c4ca
RGS
120{
121 no warnings;
ac27d13b
NC
122 # Build the warnings mask dynamically
123 my ($default, $registered);
124 BEGIN {
125 for my $i (0..$warnings::LAST_BIT/2 - 1) {
126 vec($default, $i, 2) = 1;
127 }
128 $registered = $default;
3c3f8cd6 129 vec($registered, $warnings::LAST_BIT/2, 2) = 1;
ac27d13b 130 }
3a329473 131
d190dde9
N
132 BEGIN {
133 push @tests, { type => 'check_bits', args => [ ${^WARNING_BITS}, "\0" x $warnings::BYTES ],
134 txt => 'all bits off via "no warnings"' };
135 }
fa4d2728 136 testwarn("\0" x $warnings::BYTES, 'no bits');
2db3864f 137
3c3f8cd6 138 use warnings;
d190dde9
N
139 BEGIN {
140 push @tests, { type => 'check_bits', args => [ ${^WARNING_BITS}, $default ], txt => 'default bits on via "use warnings"' };
141 }
142 BEGIN {
143 push @tests, { type => 'check_bits', args => [ get_caller_0_9(), $default ], txt => 'warnings match caller' };
144 }
75b6c4ca
RGS
145 # run-time :
146 # the warning mask has been extended by warnings::register
ac27d13b 147 testwarn($registered, 'ahead of w::r');
2db3864f 148
75b6c4ca 149 use warnings::register;
d190dde9
N
150 BEGIN {
151 push @tests, { type => 'check_bits', args => [ ${^WARNING_BITS}, $registered ], txt => 'warning bits on via "use warnings::register"' };
152 }
ac27d13b 153 testwarn($registered, 'following w::r');
75b6c4ca 154}
f2a7f298 155
156
157# The next two cases test for a bug where caller ignored evals if
d190dde9 158# the DB::sub glob existed but &DB::sub did not (for example, if
f2a7f298 159# $^P had been set but no debugger has been loaded). The tests
d190dde9 160# thus assume that there is no &DB::sub: if there is one, they
f2a7f298 161# should both pass no matter whether or not this bug has been
162# fixed.
163
164my $debugger_test = q<
165 my @stackinfo = caller(0);
166 return scalar @stackinfo;
167>;
168
169sub pb { return (caller(0))[3] }
170
171my $i = eval $debugger_test;
b3ca2e83 172is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
f2a7f298 173
174is( eval 'pb()', 'main::pb', "actually return the right function name" );
175
176my $saved_perldb = $^P;
177$^P = 16;
178$^P = $saved_perldb;
179
180$i = eval $debugger_test;
b3ca2e83 181is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
f2a7f298 182is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
183
71860c90
NC
184print "# caller can now return the compile time state of %^H\n";
185
d8c5b3c5
NC
186sub hint_exists {
187 my $key = shift;
71860c90
NC
188 my $level = shift;
189 my @results = caller($level||0);
d8c5b3c5 190 exists $results[10]->{$key};
71860c90
NC
191}
192
d8c5b3c5
NC
193sub hint_fetch {
194 my $key = shift;
b3ca2e83
NC
195 my $level = shift;
196 my @results = caller($level||0);
d8c5b3c5 197 $results[10]->{$key};
b3ca2e83 198}
71860c90 199
5b235299
NC
200{
201 my $tmpfile = tempfile();
202
203 open my $fh, '>', $tmpfile or die "open $tmpfile: $!";
204 print $fh <<'EOP';
205#!perl -wl
206use strict;
207
208{
209 package KAZASH ;
210
211 sub DESTROY {
212 print "DESTROY";
213 }
214}
215
216@DB::args = bless [], 'KAZASH';
217
218print $^P;
219print scalar @DB::args;
220
221{
222 local $^P = shift;
223}
224
225@DB::args = (); # At this point, the object should be freed.
226
227print $^P;
228print scalar @DB::args;
229
230# It shouldn't leak.
231EOP
ade9cf97 232 close $fh;
5b235299
NC
233
234 foreach (0, 1) {
235 my $got = runperl(progfile => $tmpfile, args => [$_]);
236 $got =~ s/\s+/ /gs;
237 like($got, qr/\s*0 1 DESTROY 0 0\s*/,
238 "\@DB::args doesn't leak with \$^P = $_");
239 }
240}
241
af80dd86
FC
242# This also used to leak [perl #97010]:
243{
244 my $gone;
245 sub fwib::DESTROY { ++$gone }
246 package DB;
247 sub { () = caller(0) }->(); # initialise PL_dbargs
248 @args = bless[],'fwib';
249 sub { () = caller(0) }->(); # clobber @args without initialisation
250 ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL';
251}
252
e1a80902
FC
253# And this crashed [perl #93320]:
254sub {
255 package DB;
256 ()=caller(0);
257 undef *DB::args;
258 ()=caller(0);
259}->();
260pass 'No crash when @DB::args is freed between caller calls';
261
f8c10543
FC
262# This also crashed:
263package glelp;
264sub TIEARRAY { bless [] }
265sub EXTEND { }
266sub CLEAR { }
267sub FETCH { $_[0][$_[1]] }
268sub STORE { $_[0][$_[1]] = $_[2] }
269package DB;
270tie @args, 'glelp';
7355df7e
FC
271eval { sub { () = caller 0; } ->(1..3) };
272::like $@, qr "^Cannot set tied \@DB::args at ",
273 'caller dies with tie @DB::args';
274::ok tied @args, '@DB::args is still tied';
f8c10543
FC
275untie @args;
276package main;
277
e7886211
FC
278# [perl #113486]
279fresh_perl_is <<'END', "ok\n", {},
280 { package foo; sub bar { main::bar() } }
281 sub bar {
282 delete $::{"foo::"};
283 my $x = \($1+2);
284 my $y = \($1+2); # this is the one that reuses the mem addr, but
285 my $z = \($1+2); # try the others just in case
286 s/2// for $$x, $$y, $$z; # now SvOOK
287 $x = caller;
288 print "ok\n";
289};
290foo::bar
291END
292 "No crash when freed stash is reused for PV with offset hack";
293
19bcb54e
FC
294is eval "(caller 0)[6]", "(caller 0)[6]",
295 'eval text returned by caller does not include \n;';
296
25502127
FC
297if (1) {
298 is (sub { (caller)[2] }->(), __LINE__,
299 '[perl #115768] caller gets line numbers from nulled cops');
300}
301# Test it at the end of the program, too.
302fresh_perl_is(<<'115768', 2, {},
303 if (1) {
304 foo();
305 }
306 sub foo { print +(caller)[2] }
307115768
308 '[perl #115768] caller gets line numbers from nulled cops (2)');
309
19bcb54e
FC
310# PL_linestr should not be modifiable
311eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"';
312pass "no assertion failure after modifying eval text via caller";
313
d37427bc
FC
314is eval "<<END;\nfoo\nEND\n(caller 0)[6]",
315 "<<END;\nfoo\nEND\n(caller 0)[6]",
316 'here-docs do not gut eval text';
317is eval "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
318 "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
319 'here-docs in quote-like ops do not gut eval text';
320
f07626ad
FC
321# The bitmask should be assignable to ${^WARNING_BITS} without resulting in
322# different warnings settings.
323{
324 my $ bits = sub { (caller 0)[9] }->();
325 my $w;
326 local $SIG{__WARN__} = sub { $w++ };
327 eval '
328 use warnings;
329 BEGIN { ${^WARNING_BITS} = $bits }
330 local $^W = 1;
331 () = 1 + undef;
332 $^W = 0;
333 () = 1 + undef;
334 ';
335 is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}';
336}
337
e9e9e546
TC
338# [perl #126991]
339sub getlineno { (caller)[2] }
340my $line = eval "\n#line 3000000000\ngetlineno();";
341is $line, "3000000000", "check large line numbers are preserved";
342
aee674b7
NC
343# This was fixed with commit d4d03940c58a0177, which fixed bug #78742
344fresh_perl_is <<'END', "__ANON__::doof\n", {},
345package foo;
d190dde9 346INIT {undef %foo::} # adjust test for B::C
aee674b7
NC
347sub doof { caller(0) }
348print +(doof())[3];
349END
350 "caller should not SEGV when the current package is undefined";
78beb4ca
TC
351
352# caller should not SEGV when the eval entry has been cleared #120998
353fresh_perl_is <<'END', 'main', {},
354$SIG{__DIE__} = \&dbdie;
355eval '/x';
356sub dbdie {
357 @x = caller(1);
358 print $x[0];
359}
360END
361 "caller should not SEGV for eval '' stack frames";
362
7e466429
DC
363TODO: {
364 local $::TODO = 'RT #7165: line number should be consistent for multiline subroutine calls';
365 fresh_perl_is(<<'EOP', "6\n9\n", {}, 'RT #7165: line number should be consistent for multiline subroutine calls');
366 sub tagCall {
367 my ($package, $file, $line) = caller;
368 print "$line\n";
369 }
d190dde9 370
7e466429
DC
371 tagCall
372 "abc";
d190dde9 373
7e466429
DC
374 tagCall
375 sub {};
376EOP
377}
378
d8c5b3c5 379$::testing_caller = 1;
a24d89c9 380
e81465be 381do './op/caller.pl' or die $@;
df22331b
LM
382
383{
384 package RT129239;
385 BEGIN {
386 my ($pkg, $file, $line) = caller;
d190dde9
N
387# push @tests, { type => 'is', args => [ +(caller 0)[1], __FILE__ ],
388# txt => "[perl #68712] filenames after require in a BEGIN block" };
389
390 push @tests, { type => 'is', args => [ $file, 'virtually/op/caller.t' ], txt => "BEGIN block sees correct caller filename" };
391 push @tests, { type => 'is', args => [ $line, 12345 ], txt => "BEGIN block sees correct caller line" };
392 #TODO: {
393 # local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]";
394 # push @tests, { type => is, args => [ $pkg, 'RT129239' ], txt => "BEGIN block sees correct caller package" };
395 #}
396 push @tests, { type => 'ok', txt => 'SKIPPING the BEGIN TODO test above' };
df22331b
LM
397#line 12345 "virtually/op/caller.t"
398 }
399}