Commit | Line | Data |
07b8c804 |
1 | #!./perl |
2 | # Tests for caller() |
3 | |
4 | BEGIN { |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | require './test.pl'; |
4210e623 |
8 | plan( tests => 65 ); |
07b8c804 |
9 | } |
10 | |
07b8c804 |
11 | my @c; |
12 | |
72699b0f |
13 | print "# Tests with caller(0)\n"; |
14 | |
07b8c804 |
15 | @c = caller(0); |
16 | ok( (!@c), "caller(0) in main program" ); |
17 | |
18 | eval { @c = caller(0) }; |
72699b0f |
19 | is( $c[3], "(eval)", "subroutine name in an eval {}" ); |
20 | ok( !$c[4], "hasargs false in an eval {}" ); |
07b8c804 |
21 | |
22 | eval q{ @c = (Caller(0))[3] }; |
72699b0f |
23 | is( $c[3], "(eval)", "subroutine name in an eval ''" ); |
24 | ok( !$c[4], "hasargs false in an eval ''" ); |
07b8c804 |
25 | |
26 | sub { @c = caller(0) } -> (); |
72699b0f |
27 | is( $c[3], "main::__ANON__", "anonymous subroutine name" ); |
28 | ok( $c[4], "hasargs true with anon sub" ); |
07b8c804 |
29 | |
30 | # Bug 20020517.003, used to dump core |
31 | sub foo { @c = caller(0) } |
32 | my $fooref = delete $::{foo}; |
33 | $fooref -> (); |
72699b0f |
34 | is( $c[3], "(unknown)", "unknown subroutine name" ); |
35 | ok( $c[4], "hasargs true with unknown sub" ); |
36 | |
37 | print "# Tests with caller(1)\n"; |
07b8c804 |
38 | |
39 | sub f { @c = caller(1) } |
40 | |
72699b0f |
41 | sub callf { f(); } |
42 | callf(); |
43 | is( $c[3], "main::callf", "subroutine name" ); |
44 | ok( $c[4], "hasargs true with callf()" ); |
45 | &callf; |
46 | ok( !$c[4], "hasargs false with &callf" ); |
47 | |
07b8c804 |
48 | eval { f() }; |
72699b0f |
49 | is( $c[3], "(eval)", "subroutine name in an eval {}" ); |
50 | ok( !$c[4], "hasargs false in an eval {}" ); |
07b8c804 |
51 | |
52 | eval q{ f() }; |
72699b0f |
53 | is( $c[3], "(eval)", "subroutine name in an eval ''" ); |
54 | ok( !$c[4], "hasargs false in an eval ''" ); |
07b8c804 |
55 | |
56 | sub { f() } -> (); |
72699b0f |
57 | is( $c[3], "main::__ANON__", "anonymous subroutine name" ); |
58 | ok( $c[4], "hasargs true with anon sub" ); |
07b8c804 |
59 | |
60 | sub foo2 { f() } |
61 | my $fooref2 = delete $::{foo2}; |
62 | $fooref2 -> (); |
72699b0f |
63 | is( $c[3], "(unknown)", "unknown subroutine name" ); |
64 | ok( $c[4], "hasargs true with unknown sub" ); |
75b6c4ca |
65 | |
66 | # See if caller() returns the correct warning mask |
67 | |
68 | sub testwarn { |
69 | my $w = shift; |
2db3864f |
70 | is( (caller(0))[9], $w, "warnings match caller"); |
75b6c4ca |
71 | } |
72 | |
73 | # NB : extend the warning mask values below when new warnings are added |
74 | { |
75 | no warnings; |
2db3864f |
76 | BEGIN { is( ${^WARNING_BITS}, "\0" x 12, 'all bits off via "no warnings"' ) } |
75b6c4ca |
77 | testwarn("\0" x 12); |
2db3864f |
78 | |
75b6c4ca |
79 | use warnings; |
2db3864f |
80 | BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUU\025", 'default bits on via "use warnings"' ); } |
81 | BEGIN { testwarn("UUUUUUUUUUU\025", "#1"); } |
75b6c4ca |
82 | # run-time : |
83 | # the warning mask has been extended by warnings::register |
2db3864f |
84 | testwarn("UUUUUUUUUUUU"); |
85 | |
75b6c4ca |
86 | use warnings::register; |
2db3864f |
87 | BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUUU", 'warning bits on via "use warnings::register"' ) } |
88 | testwarn("UUUUUUUUUUUU","#3"); |
75b6c4ca |
89 | } |
f2a7f298 |
90 | |
91 | |
92 | # The next two cases test for a bug where caller ignored evals if |
93 | # the DB::sub glob existed but &DB::sub did not (for example, if |
94 | # $^P had been set but no debugger has been loaded). The tests |
95 | # thus assume that there is no &DB::sub: if there is one, they |
96 | # should both pass no matter whether or not this bug has been |
97 | # fixed. |
98 | |
99 | my $debugger_test = q< |
100 | my @stackinfo = caller(0); |
101 | return scalar @stackinfo; |
102 | >; |
103 | |
104 | sub pb { return (caller(0))[3] } |
105 | |
106 | my $i = eval $debugger_test; |
b3ca2e83 |
107 | is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); |
f2a7f298 |
108 | |
109 | is( eval 'pb()', 'main::pb', "actually return the right function name" ); |
110 | |
111 | my $saved_perldb = $^P; |
112 | $^P = 16; |
113 | $^P = $saved_perldb; |
114 | |
115 | $i = eval $debugger_test; |
b3ca2e83 |
116 | is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); |
f2a7f298 |
117 | is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); |
118 | |
71860c90 |
119 | print "# caller can now return the compile time state of %^H\n"; |
120 | |
121 | sub get_hash { |
122 | my $level = shift; |
123 | my @results = caller($level||0); |
124 | $results[10]; |
125 | } |
126 | |
b3ca2e83 |
127 | sub get_dooot { |
128 | my $level = shift; |
129 | my @results = caller($level||0); |
130 | $results[10]->{dooot}; |
131 | } |
71860c90 |
132 | |
133 | sub get_thikoosh { |
b3ca2e83 |
134 | my $level = shift; |
135 | my @results = caller($level||0); |
71860c90 |
136 | $results[10]->{thikoosh}; |
b3ca2e83 |
137 | } |
71860c90 |
138 | |
b3ca2e83 |
139 | sub dooot { |
140 | is(get_dooot(), undef); |
71860c90 |
141 | is(get_thikoosh(), undef); |
b3ca2e83 |
142 | my $hash = get_hash(); |
143 | ok(!exists $hash->{dooot}); |
71860c90 |
144 | ok(!exists $hash->{thikoosh}); |
b3ca2e83 |
145 | is(get_dooot(1), 54); |
146 | BEGIN { |
147 | $^H{dooot} = 42; |
148 | } |
149 | is(get_dooot(), 6 * 7); |
150 | is(get_dooot(1), 54); |
151 | |
152 | BEGIN { |
153 | $^H{dooot} = undef; |
154 | } |
155 | is(get_dooot(), undef); |
156 | $hash = get_hash(); |
157 | ok(exists $hash->{dooot}); |
158 | |
159 | BEGIN { |
160 | delete $^H{dooot}; |
161 | } |
162 | is(get_dooot(), undef); |
163 | $hash = get_hash(); |
164 | ok(!exists $hash->{dooot}); |
165 | is(get_dooot(1), 54); |
166 | } |
167 | { |
168 | is(get_dooot(), undef); |
71860c90 |
169 | is(get_thikoosh(), undef); |
b3ca2e83 |
170 | BEGIN { |
171 | $^H{dooot} = 1; |
71860c90 |
172 | $^H{thikoosh} = "SKREECH"; |
b3ca2e83 |
173 | } |
71860c90 |
174 | is(get_dooot(), 1); |
175 | is(get_thikoosh(), "SKREECH"); |
b3ca2e83 |
176 | |
177 | BEGIN { |
178 | $^H{dooot} = 42; |
179 | } |
180 | { |
181 | { |
182 | BEGIN { |
183 | $^H{dooot} = 6 * 9; |
184 | } |
185 | is(get_dooot(), 54); |
71860c90 |
186 | is(get_thikoosh(), "SKREECH"); |
b3ca2e83 |
187 | { |
188 | BEGIN { |
189 | delete $^H{dooot}; |
190 | } |
191 | is(get_dooot(), undef); |
192 | my $hash = get_hash(); |
193 | ok(!exists $hash->{dooot}); |
71860c90 |
194 | is(get_thikoosh(), "SKREECH"); |
b3ca2e83 |
195 | } |
196 | dooot(); |
197 | } |
198 | is(get_dooot(), 6 * 7); |
71860c90 |
199 | is(get_thikoosh(), "SKREECH"); |
b3ca2e83 |
200 | } |
201 | is(get_dooot(), 6 * 7); |
71860c90 |
202 | is(get_thikoosh(), "SKREECH"); |
b3ca2e83 |
203 | } |
a24d89c9 |
204 | |
205 | print "# which now works inside evals\n"; |
206 | |
207 | { |
208 | BEGIN { |
209 | $^H{dooot} = 42; |
210 | } |
211 | is(get_dooot(), 6 * 7); |
212 | |
213 | eval "is(get_dooot(), 6 * 7); 1" or die $@; |
214 | |
215 | eval <<'EOE' or die $@; |
216 | is(get_dooot(), 6 * 7); |
217 | eval "is(get_dooot(), 6 * 7); 1" or die $@; |
218 | BEGIN { |
219 | $^H{dooot} = 54; |
220 | } |
221 | is(get_dooot(), 54); |
222 | eval "is(get_dooot(), 54); 1" or die $@; |
223 | eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@; |
224 | is(get_dooot(), 54); |
225 | eval "is(get_dooot(), 54); 1" or die $@; |
226 | EOE |
227 | } |
4210e623 |
228 | |
229 | { |
230 | BEGIN { |
231 | $^H{dooot} = "FIP\0FOP\0FIDDIT\0FAP"; |
232 | } |
233 | is(get_dooot(), "FIP\0FOP\0FIDDIT\0FAP", "Can do embedded 0 bytes"); |
234 | } |