This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
redo part of change 27374
[perl5.git] / t / op / caller.t
CommitLineData
07b8c804
RGS
1#!./perl
2# Tests for caller()
3
4BEGIN {
5 chdir 't' if -d 't';
6 @INC = '../lib';
7 require './test.pl';
9f769845 8 plan( tests => 77 );
07b8c804
RGS
9}
10
07b8c804
RGS
11my @c;
12
72699b0f
RGS
13print "# Tests with caller(0)\n";
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
RGS
21
22eval q{ @c = (Caller(0))[3] };
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
RGS
29
30# Bug 20020517.003, used to dump core
31sub foo { @c = caller(0) }
32my $fooref = delete $::{foo};
33$fooref -> ();
72699b0f
RGS
34is( $c[3], "(unknown)", "unknown subroutine name" );
35ok( $c[4], "hasargs true with unknown sub" );
36
37print "# Tests with caller(1)\n";
07b8c804
RGS
38
39sub f { @c = caller(1) }
40
72699b0f
RGS
41sub callf { f(); }
42callf();
43is( $c[3], "main::callf", "subroutine name" );
44ok( $c[4], "hasargs true with callf()" );
45&callf;
46ok( !$c[4], "hasargs false with &callf" );
47
07b8c804 48eval { f() };
72699b0f
RGS
49is( $c[3], "(eval)", "subroutine name in an eval {}" );
50ok( !$c[4], "hasargs false in an eval {}" );
07b8c804
RGS
51
52eval q{ f() };
72699b0f
RGS
53is( $c[3], "(eval)", "subroutine name in an eval ''" );
54ok( !$c[4], "hasargs false in an eval ''" );
07b8c804
RGS
55
56sub { f() } -> ();
72699b0f
RGS
57is( $c[3], "main::__ANON__", "anonymous subroutine name" );
58ok( $c[4], "hasargs true with anon sub" );
07b8c804
RGS
59
60sub foo2 { f() }
61my $fooref2 = delete $::{foo2};
62$fooref2 -> ();
72699b0f
RGS
63is( $c[3], "(unknown)", "unknown subroutine name" );
64ok( $c[4], "hasargs true with unknown sub" );
75b6c4ca
RGS
65
66# See if caller() returns the correct warning mask
67
68sub testwarn {
69 my $w = shift;
2db3864f 70 is( (caller(0))[9], $w, "warnings match caller");
75b6c4ca
RGS
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
AL
80 BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUU\025", 'default bits on via "use warnings"' ); }
81 BEGIN { testwarn("UUUUUUUUUUU\025", "#1"); }
75b6c4ca
RGS
82 # run-time :
83 # the warning mask has been extended by warnings::register
2db3864f
AL
84 testwarn("UUUUUUUUUUUU");
85
75b6c4ca 86 use warnings::register;
2db3864f
AL
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
99my $debugger_test = q<
100 my @stackinfo = caller(0);
101 return scalar @stackinfo;
102>;
103
104sub pb { return (caller(0))[3] }
105
106my $i = eval $debugger_test;
b3ca2e83 107is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
f2a7f298 108
109is( eval 'pb()', 'main::pb', "actually return the right function name" );
110
111my $saved_perldb = $^P;
112$^P = 16;
113$^P = $saved_perldb;
114
115$i = eval $debugger_test;
b3ca2e83 116is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
f2a7f298 117is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
118
71860c90
NC
119print "# caller can now return the compile time state of %^H\n";
120
121sub get_hash {
122 my $level = shift;
123 my @results = caller($level||0);
124 $results[10];
125}
126
b3ca2e83
NC
127sub get_dooot {
128 my $level = shift;
129 my @results = caller($level||0);
130 $results[10]->{dooot};
131}
71860c90
NC
132
133sub get_thikoosh {
b3ca2e83
NC
134 my $level = shift;
135 my @results = caller($level||0);
71860c90 136 $results[10]->{thikoosh};
b3ca2e83 137}
71860c90 138
b3ca2e83
NC
139sub dooot {
140 is(get_dooot(), undef);
71860c90 141 is(get_thikoosh(), undef);
b3ca2e83
NC
142 my $hash = get_hash();
143 ok(!exists $hash->{dooot});
71860c90 144 ok(!exists $hash->{thikoosh});
b3ca2e83
NC
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
NC
170 BEGIN {
171 $^H{dooot} = 1;
71860c90 172 $^H{thikoosh} = "SKREECH";
b3ca2e83 173 }
71860c90
NC
174 is(get_dooot(), 1);
175 is(get_thikoosh(), "SKREECH");
b3ca2e83
NC
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
NC
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
NC
195 }
196 dooot();
197 }
198 is(get_dooot(), 6 * 7);
71860c90 199 is(get_thikoosh(), "SKREECH");
b3ca2e83
NC
200 }
201 is(get_dooot(), 6 * 7);
71860c90 202 is(get_thikoosh(), "SKREECH");
b3ca2e83 203}
a24d89c9
NC
204
205print "# 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 $@;
226EOE
227}
4210e623
NC
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");
968f0fcb
NC
234
235 BEGIN {
236 $^H{dooot} = chr 256;
237 }
238 is(get_dooot(), chr 256, "Can do Unicode");
239
240 BEGIN {
241 $^H{dooot} = -42;
242 }
243 is(get_dooot(), -42, "Can do IVs");
244
245 BEGIN {
246 $^H{dooot} = ~0;
247 }
248 cmp_ok(get_dooot(), '>', 42, "Can do UVs");
249}
250
251{
252 my ($k1, $k2, $k3);
253 BEGIN {
254 $k1 = chr 163;
255 $k2 = $k1;
256 $k3 = $k1;
257 utf8::upgrade $k2;
258 utf8::encode $k3;
259
260 $^H{$k1} = 1;
261 $^H{$k2} = 2;
262 $^H{$k3} = 3;
263 }
264
265
266 is(get_hash()->{$k1}, 2, "UTF-8 or not, it's the same");
267 is(get_hash()->{$k2}, 2, "UTF-8 or not, it's the same");
268 is(get_hash()->{$k3}, 3, "Octect sequences and UTF-8 are distinct");
4210e623 269}
9f769845
NC
270
271{
272 my ($k1, $k2, $k3);
273 BEGIN {
274 ($k1, $k2, $k3) = ("\0", "\0\0", "\0\0\0");
275 $^H{$k1} = 1;
276 $^H{$k2} = 2;
277 $^H{$k3} = 3;
278 }
279
280 is(get_hash()->{$k1}, 1, "Keys with the same hash value don't clash");
281 is(get_hash()->{$k2}, 2, "Keys with the same hash value don't clash");
282 is(get_hash()->{$k3}, 3, "Keys with the same hash value don't clash");
283
284 BEGIN {
285 $^H{$k1} = "a";
286 $^H{$k2} = "b";
287 $^H{$k3} = "c";
288 }
289
290 is(get_hash()->{$k1}, "a", "Keys with the same hash value don't clash");
291 is(get_hash()->{$k2}, "b", "Keys with the same hash value don't clash");
292 is(get_hash()->{$k3}, "c", "Keys with the same hash value don't clash");
293}