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