Commit | Line | Data |
---|---|---|
07b8c804 RGS |
1 | #!./perl |
2 | # Tests for caller() | |
3 | ||
4 | BEGIN { | |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
7 | require './test.pl'; | |
e7886211 | 8 | plan( tests => 86 ); |
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 RGS |
21 | |
22 | eval q{ @c = (Caller(0))[3] }; | |
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 RGS |
29 | |
30 | # Bug 20020517.003, used to dump core | |
31 | sub foo { @c = caller(0) } | |
32 | my $fooref = delete $::{foo}; | |
33 | $fooref -> (); | |
803f2748 DM |
34 | is( $c[3], "main::__ANON__", "deleted subroutine name" ); |
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 -> (); | |
803f2748 DM |
69 | is( $c[3], "main::__ANON__", "deleted subroutine name" ); |
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; | |
109 | vec($registered, $warnings::LAST_BIT/2, 2) = 1; | |
110 | } | |
3a329473 KW |
111 | |
112 | # The repetition number must be set to the value of $BYTES in | |
113 | # lib/warnings.pm | |
8457b38f KW |
114 | BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 13, 'all bits off via "no warnings"' ) } |
115 | testwarn("\0" x 13, 'no bits'); | |
2db3864f | 116 | |
75b6c4ca | 117 | use warnings; |
ac27d13b NC |
118 | BEGIN { check_bits( ${^WARNING_BITS}, $default, |
119 | 'default bits on via "use warnings"' ); } | |
120 | BEGIN { testwarn($default, 'all'); } | |
75b6c4ca RGS |
121 | # run-time : |
122 | # the warning mask has been extended by warnings::register | |
ac27d13b | 123 | testwarn($registered, 'ahead of w::r'); |
2db3864f | 124 | |
75b6c4ca | 125 | use warnings::register; |
ac27d13b NC |
126 | BEGIN { check_bits( ${^WARNING_BITS}, $registered, |
127 | 'warning bits on via "use warnings::register"' ) } | |
128 | testwarn($registered, 'following w::r'); | |
75b6c4ca | 129 | } |
f2a7f298 DG |
130 | |
131 | ||
132 | # The next two cases test for a bug where caller ignored evals if | |
133 | # the DB::sub glob existed but &DB::sub did not (for example, if | |
134 | # $^P had been set but no debugger has been loaded). The tests | |
135 | # thus assume that there is no &DB::sub: if there is one, they | |
136 | # should both pass no matter whether or not this bug has been | |
137 | # fixed. | |
138 | ||
139 | my $debugger_test = q< | |
140 | my @stackinfo = caller(0); | |
141 | return scalar @stackinfo; | |
142 | >; | |
143 | ||
144 | sub pb { return (caller(0))[3] } | |
145 | ||
146 | my $i = eval $debugger_test; | |
b3ca2e83 | 147 | is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); |
f2a7f298 DG |
148 | |
149 | is( eval 'pb()', 'main::pb', "actually return the right function name" ); | |
150 | ||
151 | my $saved_perldb = $^P; | |
152 | $^P = 16; | |
153 | $^P = $saved_perldb; | |
154 | ||
155 | $i = eval $debugger_test; | |
b3ca2e83 | 156 | is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); |
f2a7f298 DG |
157 | is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); |
158 | ||
71860c90 NC |
159 | print "# caller can now return the compile time state of %^H\n"; |
160 | ||
d8c5b3c5 NC |
161 | sub hint_exists { |
162 | my $key = shift; | |
71860c90 NC |
163 | my $level = shift; |
164 | my @results = caller($level||0); | |
d8c5b3c5 | 165 | exists $results[10]->{$key}; |
71860c90 NC |
166 | } |
167 | ||
d8c5b3c5 NC |
168 | sub hint_fetch { |
169 | my $key = shift; | |
b3ca2e83 NC |
170 | my $level = shift; |
171 | my @results = caller($level||0); | |
d8c5b3c5 | 172 | $results[10]->{$key}; |
b3ca2e83 | 173 | } |
71860c90 | 174 | |
5b235299 NC |
175 | { |
176 | my $tmpfile = tempfile(); | |
177 | ||
178 | open my $fh, '>', $tmpfile or die "open $tmpfile: $!"; | |
179 | print $fh <<'EOP'; | |
180 | #!perl -wl | |
181 | use strict; | |
182 | ||
183 | { | |
184 | package KAZASH ; | |
185 | ||
186 | sub DESTROY { | |
187 | print "DESTROY"; | |
188 | } | |
189 | } | |
190 | ||
191 | @DB::args = bless [], 'KAZASH'; | |
192 | ||
193 | print $^P; | |
194 | print scalar @DB::args; | |
195 | ||
196 | { | |
197 | local $^P = shift; | |
198 | } | |
199 | ||
200 | @DB::args = (); # At this point, the object should be freed. | |
201 | ||
202 | print $^P; | |
203 | print scalar @DB::args; | |
204 | ||
205 | # It shouldn't leak. | |
206 | EOP | |
ade9cf97 | 207 | close $fh; |
5b235299 NC |
208 | |
209 | foreach (0, 1) { | |
210 | my $got = runperl(progfile => $tmpfile, args => [$_]); | |
211 | $got =~ s/\s+/ /gs; | |
212 | like($got, qr/\s*0 1 DESTROY 0 0\s*/, | |
213 | "\@DB::args doesn't leak with \$^P = $_"); | |
214 | } | |
215 | } | |
216 | ||
af80dd86 FC |
217 | # This also used to leak [perl #97010]: |
218 | { | |
219 | my $gone; | |
220 | sub fwib::DESTROY { ++$gone } | |
221 | package DB; | |
222 | sub { () = caller(0) }->(); # initialise PL_dbargs | |
223 | @args = bless[],'fwib'; | |
224 | sub { () = caller(0) }->(); # clobber @args without initialisation | |
225 | ::is $gone, 1, 'caller does not leak @DB::args elems when AvREAL'; | |
226 | } | |
227 | ||
e1a80902 FC |
228 | # And this crashed [perl #93320]: |
229 | sub { | |
230 | package DB; | |
231 | ()=caller(0); | |
232 | undef *DB::args; | |
233 | ()=caller(0); | |
234 | }->(); | |
235 | pass 'No crash when @DB::args is freed between caller calls'; | |
236 | ||
f8c10543 FC |
237 | # This also crashed: |
238 | package glelp; | |
239 | sub TIEARRAY { bless [] } | |
240 | sub EXTEND { } | |
241 | sub CLEAR { } | |
242 | sub FETCH { $_[0][$_[1]] } | |
243 | sub STORE { $_[0][$_[1]] = $_[2] } | |
244 | package DB; | |
245 | tie @args, 'glelp'; | |
7355df7e FC |
246 | eval { sub { () = caller 0; } ->(1..3) }; |
247 | ::like $@, qr "^Cannot set tied \@DB::args at ", | |
248 | 'caller dies with tie @DB::args'; | |
249 | ::ok tied @args, '@DB::args is still tied'; | |
f8c10543 FC |
250 | untie @args; |
251 | package main; | |
252 | ||
e7886211 FC |
253 | # [perl #113486] |
254 | fresh_perl_is <<'END', "ok\n", {}, | |
255 | { package foo; sub bar { main::bar() } } | |
256 | sub bar { | |
257 | delete $::{"foo::"}; | |
258 | my $x = \($1+2); | |
259 | my $y = \($1+2); # this is the one that reuses the mem addr, but | |
260 | my $z = \($1+2); # try the others just in case | |
261 | s/2// for $$x, $$y, $$z; # now SvOOK | |
262 | $x = caller; | |
263 | print "ok\n"; | |
264 | }; | |
265 | foo::bar | |
266 | END | |
267 | "No crash when freed stash is reused for PV with offset hack"; | |
268 | ||
d8c5b3c5 | 269 | $::testing_caller = 1; |
a24d89c9 | 270 | |
e81465be | 271 | do './op/caller.pl' or die $@; |