Commit | Line | Data |
---|---|---|
07b8c804 RGS |
1 | #!./perl |
2 | # Tests for caller() | |
3 | ||
4 | BEGIN { | |
5 | chdir 't' if -d 't'; | |
07b8c804 | 6 | require './test.pl'; |
624c42e2 | 7 | set_up_inc('../lib'); |
df22331b | 8 | plan( tests => 100 ); # some tests are run in a BEGIN block |
07b8c804 RGS |
9 | } |
10 | ||
07b8c804 RGS |
11 | my @c; |
12 | ||
b2ef6d44 | 13 | BEGIN { print "# Tests with caller(0)\n"; } |
72699b0f | 14 | |
07b8c804 RGS |
15 | @c = caller(0); |
16 | ok( (!@c), "caller(0) in main program" ); | |
17 | ||
18 | eval { @c = caller(0) }; | |
72699b0f RGS |
19 | is( $c[3], "(eval)", "subroutine name in an eval {}" ); |
20 | ok( !$c[4], "hasargs false in an eval {}" ); | |
07b8c804 | 21 | |
47301516 | 22 | eval q{ @c = caller(0) }; |
72699b0f RGS |
23 | is( $c[3], "(eval)", "subroutine name in an eval ''" ); |
24 | ok( !$c[4], "hasargs false in an eval ''" ); | |
07b8c804 RGS |
25 | |
26 | sub { @c = caller(0) } -> (); | |
72699b0f RGS |
27 | is( $c[3], "main::__ANON__", "anonymous subroutine name" ); |
28 | ok( $c[4], "hasargs true with anon sub" ); | |
07b8c804 | 29 | |
ee95e30c | 30 | # Bug 20020517.003 (#9367), used to dump core |
07b8c804 RGS |
31 | sub foo { @c = caller(0) } |
32 | my $fooref = delete $::{foo}; | |
33 | $fooref -> (); | |
2eaf799e | 34 | is( $c[3], "main::foo", "deleted subroutine name" ); |
803f2748 | 35 | ok( $c[4], "hasargs true with deleted sub" ); |
72699b0f | 36 | |
b2ef6d44 FC |
37 | BEGIN { |
38 | require strict; | |
39 | is +(caller 0)[1], __FILE__, | |
40 | "[perl #68712] filenames after require in a BEGIN block" | |
41 | } | |
42 | ||
72699b0f | 43 | print "# Tests with caller(1)\n"; |
07b8c804 RGS |
44 | |
45 | sub f { @c = caller(1) } | |
46 | ||
72699b0f RGS |
47 | sub callf { f(); } |
48 | callf(); | |
49 | is( $c[3], "main::callf", "subroutine name" ); | |
50 | ok( $c[4], "hasargs true with callf()" ); | |
51 | &callf; | |
52 | ok( !$c[4], "hasargs false with &callf" ); | |
53 | ||
07b8c804 | 54 | eval { f() }; |
72699b0f RGS |
55 | is( $c[3], "(eval)", "subroutine name in an eval {}" ); |
56 | ok( !$c[4], "hasargs false in an eval {}" ); | |
07b8c804 RGS |
57 | |
58 | eval q{ f() }; | |
72699b0f RGS |
59 | is( $c[3], "(eval)", "subroutine name in an eval ''" ); |
60 | ok( !$c[4], "hasargs false in an eval ''" ); | |
07b8c804 RGS |
61 | |
62 | sub { f() } -> (); | |
72699b0f RGS |
63 | is( $c[3], "main::__ANON__", "anonymous subroutine name" ); |
64 | ok( $c[4], "hasargs true with anon sub" ); | |
07b8c804 RGS |
65 | |
66 | sub foo2 { f() } | |
67 | my $fooref2 = delete $::{foo2}; | |
68 | $fooref2 -> (); | |
2eaf799e | 69 | is( $c[3], "main::foo2", "deleted subroutine name" ); |
803f2748 | 70 | ok( $c[4], "hasargs true with deleted sub" ); |
75b6c4ca RGS |
71 | |
72 | # See if caller() returns the correct warning mask | |
73 | ||
886f1e3e JH |
74 | sub 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 | ||
84 | sub 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 |
94 | sub 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 DG |
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 | ||
137 | my $debugger_test = q< | |
138 | my @stackinfo = caller(0); | |
139 | return scalar @stackinfo; | |
140 | >; | |
141 | ||
142 | sub pb { return (caller(0))[3] } | |
143 | ||
144 | my $i = eval $debugger_test; | |
b3ca2e83 | 145 | is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); |
f2a7f298 DG |
146 | |
147 | is( eval 'pb()', 'main::pb', "actually return the right function name" ); | |
148 | ||
149 | my $saved_perldb = $^P; | |
150 | $^P = 16; | |
151 | $^P = $saved_perldb; | |
152 | ||
153 | $i = eval $debugger_test; | |
b3ca2e83 | 154 | is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); |
f2a7f298 DG |
155 | is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); |
156 | ||
71860c90 NC |
157 | print "# caller can now return the compile time state of %^H\n"; |
158 | ||
d8c5b3c5 NC |
159 | sub 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 |
166 | sub 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 | |
179 | use strict; | |
180 | ||
181 | { | |
182 | package KAZASH ; | |
183 | ||
184 | sub DESTROY { | |
185 | print "DESTROY"; | |
186 | } | |
187 | } | |
188 | ||
189 | @DB::args = bless [], 'KAZASH'; | |
190 | ||
191 | print $^P; | |
192 | print scalar @DB::args; | |
193 | ||
194 | { | |
195 | local $^P = shift; | |
196 | } | |
197 | ||
198 | @DB::args = (); # At this point, the object should be freed. | |
199 | ||
200 | print $^P; | |
201 | print scalar @DB::args; | |
202 | ||
203 | # It shouldn't leak. | |
204 | EOP | |
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]: |
227 | sub { | |
228 | package DB; | |
229 | ()=caller(0); | |
230 | undef *DB::args; | |
231 | ()=caller(0); | |
232 | }->(); | |
233 | pass 'No crash when @DB::args is freed between caller calls'; | |
234 | ||
f8c10543 FC |
235 | # This also crashed: |
236 | package glelp; | |
237 | sub TIEARRAY { bless [] } | |
238 | sub EXTEND { } | |
239 | sub CLEAR { } | |
240 | sub FETCH { $_[0][$_[1]] } | |
241 | sub STORE { $_[0][$_[1]] = $_[2] } | |
242 | package DB; | |
243 | tie @args, 'glelp'; | |
7355df7e FC |
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'; | |
f8c10543 FC |
248 | untie @args; |
249 | package main; | |
250 | ||
e7886211 FC |
251 | # [perl #113486] |
252 | fresh_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 | }; | |
263 | foo::bar | |
264 | END | |
265 | "No crash when freed stash is reused for PV with offset hack"; | |
266 | ||
19bcb54e FC |
267 | is eval "(caller 0)[6]", "(caller 0)[6]", |
268 | 'eval text returned by caller does not include \n;'; | |
269 | ||
25502127 FC |
270 | if (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. | |
275 | fresh_perl_is(<<'115768', 2, {}, | |
276 | if (1) { | |
277 | foo(); | |
278 | } | |
279 | sub foo { print +(caller)[2] } | |
280 | 115768 | |
281 | '[perl #115768] caller gets line numbers from nulled cops (2)'); | |
282 | ||
19bcb54e FC |
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"; | |
286 | ||
d37427bc FC |
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'; | |
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] |
312 | sub getlineno { (caller)[2] } | |
313 | my $line = eval "\n#line 3000000000\ngetlineno();"; | |
314 | is $line, "3000000000", "check large line numbers are preserved"; | |
315 | ||
aee674b7 NC |
316 | # This was fixed with commit d4d03940c58a0177, which fixed bug #78742 |
317 | fresh_perl_is <<'END', "__ANON__::doof\n", {}, | |
318 | package foo; | |
319 | BEGIN {undef %foo::} | |
320 | sub doof { caller(0) } | |
321 | print +(doof())[3]; | |
322 | END | |
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 | |
326 | fresh_perl_is <<'END', 'main', {}, | |
327 | $SIG{__DIE__} = \&dbdie; | |
328 | eval '/x'; | |
329 | sub dbdie { | |
330 | @x = caller(1); | |
331 | print $x[0]; | |
332 | } | |
333 | END | |
334 | "caller should not SEGV for eval '' stack frames"; | |
335 | ||
7e466429 DC |
336 | TODO: { |
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 {}; | |
349 | EOP | |
350 | } | |
351 | ||
d8c5b3c5 | 352 | $::testing_caller = 1; |
a24d89c9 | 353 | |
e81465be | 354 | do './op/caller.pl' or die $@; |
df22331b LM |
355 | |
356 | { | |
357 | package RT129239; | |
358 | BEGIN { | |
359 | my ($pkg, $file, $line) = caller; | |
360 | ::is $file, 'virtually/op/caller.t', "BEGIN block sees correct caller filename"; | |
361 | ::is $line, 12345, "BEGIN block sees correct caller line"; | |
362 | TODO: { | |
363 | local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]"; | |
364 | ::is $pkg, 'RT129239', "BEGIN block sees correct caller package"; | |
365 | } | |
366 | #line 12345 "virtually/op/caller.t" | |
367 | } | |
368 | } |