This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regcharclass.h: #defines for non-chars by UTF8 length
[perl5.git] / t / op / caller.t
... / ...
CommitLineData
1#!./perl
2# Tests for caller()
3
4BEGIN {
5 chdir 't' if -d 't';
6 require './test.pl';
7 set_up_inc('../lib');
8 plan( tests => 97 ); # some tests are run in a BEGIN block
9}
10
11my @c;
12
13BEGIN { print "# Tests with caller(0)\n"; }
14
15@c = caller(0);
16ok( (!@c), "caller(0) in main program" );
17
18eval { @c = caller(0) };
19is( $c[3], "(eval)", "subroutine name in an eval {}" );
20ok( !$c[4], "hasargs false in an eval {}" );
21
22eval q{ @c = caller(0) };
23is( $c[3], "(eval)", "subroutine name in an eval ''" );
24ok( !$c[4], "hasargs false in an eval ''" );
25
26sub { @c = caller(0) } -> ();
27is( $c[3], "main::__ANON__", "anonymous subroutine name" );
28ok( $c[4], "hasargs true with anon sub" );
29
30# Bug 20020517.003 (#9367), used to dump core
31sub foo { @c = caller(0) }
32my $fooref = delete $::{foo};
33$fooref -> ();
34is( $c[3], "main::foo", "deleted subroutine name" );
35ok( $c[4], "hasargs true with deleted sub" );
36
37BEGIN {
38 require strict;
39 is +(caller 0)[1], __FILE__,
40 "[perl #68712] filenames after require in a BEGIN block"
41}
42
43print "# Tests with caller(1)\n";
44
45sub f { @c = caller(1) }
46
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
54eval { f() };
55is( $c[3], "(eval)", "subroutine name in an eval {}" );
56ok( !$c[4], "hasargs false in an eval {}" );
57
58eval q{ f() };
59is( $c[3], "(eval)", "subroutine name in an eval ''" );
60ok( !$c[4], "hasargs false in an eval ''" );
61
62sub { f() } -> ();
63is( $c[3], "main::__ANON__", "anonymous subroutine name" );
64ok( $c[4], "hasargs true with anon sub" );
65
66sub foo2 { f() }
67my $fooref2 = delete $::{foo2};
68$fooref2 -> ();
69is( $c[3], "main::foo2", "deleted subroutine name" );
70ok( $c[4], "hasargs true with deleted sub" );
71
72# See if caller() returns the correct warning mask
73
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{
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));
91 }
92}
93
94sub testwarn {
95 my $w = shift;
96 my $id = shift;
97 check_bits( (caller(0))[9], $w, "warnings match caller ($id)");
98}
99
100{
101 no warnings;
102 BEGIN { check_bits( ${^WARNING_BITS}, "\0" x $warnings::BYTES, 'all bits off via "no warnings"' ) }
103 testwarn("\0" x $warnings::BYTES, 'no bits');
104
105 use warnings;
106 BEGIN { check_bits( ${^WARNING_BITS}, "\x55" x $warnings::BYTES,
107 'default bits on via "use warnings"' ); }
108 testwarn("\x55" x $warnings::BYTES, 'all');
109}
110
111
112# The next two cases test for a bug where caller ignored evals if
113# the DB::sub glob existed but &DB::sub did not (for example, if
114# $^P had been set but no debugger has been loaded). The tests
115# thus assume that there is no &DB::sub: if there is one, they
116# should both pass no matter whether or not this bug has been
117# fixed.
118
119my $debugger_test = q<
120 my @stackinfo = caller(0);
121 return scalar @stackinfo;
122>;
123
124sub pb { return (caller(0))[3] }
125
126my $i = eval $debugger_test;
127is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
128
129is( eval 'pb()', 'main::pb', "actually return the right function name" );
130
131my $saved_perldb = $^P;
132$^P = 16;
133$^P = $saved_perldb;
134
135$i = eval $debugger_test;
136is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
137is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
138
139print "# caller can now return the compile time state of %^H\n";
140
141sub hint_exists {
142 my $key = shift;
143 my $level = shift;
144 my @results = caller($level||0);
145 exists $results[10]->{$key};
146}
147
148sub hint_fetch {
149 my $key = shift;
150 my $level = shift;
151 my @results = caller($level||0);
152 $results[10]->{$key};
153}
154
155{
156 my $tmpfile = tempfile();
157
158 open my $fh, '>', $tmpfile or die "open $tmpfile: $!";
159 print $fh <<'EOP';
160#!perl -wl
161use strict;
162
163{
164 package KAZASH ;
165
166 sub DESTROY {
167 print "DESTROY";
168 }
169}
170
171@DB::args = bless [], 'KAZASH';
172
173print $^P;
174print scalar @DB::args;
175
176{
177 local $^P = shift;
178}
179
180@DB::args = (); # At this point, the object should be freed.
181
182print $^P;
183print scalar @DB::args;
184
185# It shouldn't leak.
186EOP
187 close $fh;
188
189 foreach (0, 1) {
190 my $got = runperl(progfile => $tmpfile, args => [$_]);
191 $got =~ s/\s+/ /gs;
192 like($got, qr/\s*0 1 DESTROY 0 0\s*/,
193 "\@DB::args doesn't leak with \$^P = $_");
194 }
195}
196
197# This also used to leak [perl #97010]:
198{
199 my $gone;
200 sub fwib::DESTROY { ++$gone }
201 package DB;
202 sub { () = caller(0) }->(); # initialise PL_dbargs
203 @args = bless[],'fwib';
204 sub { () = caller(0) }->(); # clobber @args without initialisation
205 ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL';
206}
207
208# And this crashed [perl #93320]:
209sub {
210 package DB;
211 ()=caller(0);
212 undef *DB::args;
213 ()=caller(0);
214}->();
215pass 'No crash when @DB::args is freed between caller calls';
216
217# This also crashed:
218package glelp;
219sub TIEARRAY { bless [] }
220sub EXTEND { }
221sub CLEAR { }
222sub FETCH { $_[0][$_[1]] }
223sub STORE { $_[0][$_[1]] = $_[2] }
224package DB;
225tie @args, 'glelp';
226eval { sub { () = caller 0; } ->(1..3) };
227::like $@, qr "^Cannot set tied \@DB::args at ",
228 'caller dies with tie @DB::args';
229::ok tied @args, '@DB::args is still tied';
230untie @args;
231package main;
232
233# [perl #113486]
234fresh_perl_is <<'END', "ok\n", {},
235 { package foo; sub bar { main::bar() } }
236 sub bar {
237 delete $::{"foo::"};
238 my $x = \($1+2);
239 my $y = \($1+2); # this is the one that reuses the mem addr, but
240 my $z = \($1+2); # try the others just in case
241 s/2// for $$x, $$y, $$z; # now SvOOK
242 $x = caller;
243 print "ok\n";
244};
245foo::bar
246END
247 "No crash when freed stash is reused for PV with offset hack";
248
249is eval "(caller 0)[6]", "(caller 0)[6]",
250 'eval text returned by caller does not include \n;';
251
252if (1) {
253 is (sub { (caller)[2] }->(), __LINE__,
254 '[perl #115768] caller gets line numbers from nulled cops');
255}
256# Test it at the end of the program, too.
257fresh_perl_is(<<'115768', 2, {},
258 if (1) {
259 foo();
260 }
261 sub foo { print +(caller)[2] }
262115768
263 '[perl #115768] caller gets line numbers from nulled cops (2)');
264
265# PL_linestr should not be modifiable
266eval '"${;BEGIN{ ${\(caller 2)[6]} = *foo }}"';
267pass "no assertion failure after modifying eval text via caller";
268
269is eval "<<END;\nfoo\nEND\n(caller 0)[6]",
270 "<<END;\nfoo\nEND\n(caller 0)[6]",
271 'here-docs do not gut eval text';
272is eval "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
273 "s//<<END/e;\nfoo\nEND\n(caller 0)[6]",
274 'here-docs in quote-like ops do not gut eval text';
275
276# The bitmask should be assignable to ${^WARNING_BITS} without resulting in
277# different warnings settings.
278{
279 my $ bits = sub { (caller 0)[9] }->();
280 my $w;
281 local $SIG{__WARN__} = sub { $w++ };
282 eval '
283 use warnings;
284 BEGIN { ${^WARNING_BITS} = $bits }
285 local $^W = 1;
286 () = 1 + undef;
287 $^W = 0;
288 () = 1 + undef;
289 ';
290 is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}';
291}
292
293# [perl #126991]
294sub getlineno { (caller)[2] }
295my $line = eval "\n#line 3000000000\ngetlineno();";
296is $line, "3000000000", "check large line numbers are preserved";
297
298# This was fixed with commit d4d03940c58a0177, which fixed bug #78742
299fresh_perl_is <<'END', "__ANON__::doof\n", {},
300package foo;
301BEGIN {undef %foo::}
302sub doof { caller(0) }
303print +(doof())[3];
304END
305 "caller should not SEGV when the current package is undefined";
306
307# caller should not SEGV when the eval entry has been cleared #120998
308fresh_perl_is <<'END', 'main', {},
309$SIG{__DIE__} = \&dbdie;
310eval '/x';
311sub dbdie {
312 @x = caller(1);
313 print $x[0];
314}
315END
316 "caller should not SEGV for eval '' stack frames";
317
318TODO: {
319 local $::TODO = 'RT #7165: line number should be consistent for multiline subroutine calls';
320 fresh_perl_is(<<'EOP', "6\n9\n", {}, 'RT #7165: line number should be consistent for multiline subroutine calls');
321 sub tagCall {
322 my ($package, $file, $line) = caller;
323 print "$line\n";
324 }
325
326 tagCall
327 "abc";
328
329 tagCall
330 sub {};
331EOP
332}
333
334$::testing_caller = 1;
335
336do './op/caller.pl' or die $@;
337
338{
339 package RT129239;
340 BEGIN {
341 my ($pkg, $file, $line) = caller;
342 ::is $file, 'virtually/op/caller.t', "BEGIN block sees correct caller filename";
343 ::is $line, 12345, "BEGIN block sees correct caller line";
344 TODO: {
345 local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]";
346 ::is $pkg, 'RT129239', "BEGIN block sees correct caller package";
347 }
348#line 12345 "virtually/op/caller.t"
349 }
350}