This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
diag.t: Allow underscore in warnings categories
[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';
b2ef6d44 8 plan( tests => 81 );
07b8c804
RGS
9}
10
07b8c804
RGS
11my @c;
12
b2ef6d44 13BEGIN { print "# Tests with caller(0)\n"; }
72699b0f 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 -> ();
803f2748
DM
34is( $c[3], "main::__ANON__", "deleted subroutine name" );
35ok( $c[4], "hasargs true with deleted sub" );
72699b0f 36
b2ef6d44
FC
37BEGIN {
38 require strict;
39 is +(caller 0)[1], __FILE__,
40 "[perl #68712] filenames after require in a BEGIN block"
41}
42
72699b0f 43print "# Tests with caller(1)\n";
07b8c804
RGS
44
45sub f { @c = caller(1) }
46
72699b0f
RGS
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
07b8c804 54eval { f() };
72699b0f
RGS
55is( $c[3], "(eval)", "subroutine name in an eval {}" );
56ok( !$c[4], "hasargs false in an eval {}" );
07b8c804
RGS
57
58eval q{ f() };
72699b0f
RGS
59is( $c[3], "(eval)", "subroutine name in an eval ''" );
60ok( !$c[4], "hasargs false in an eval ''" );
07b8c804
RGS
61
62sub { f() } -> ();
72699b0f
RGS
63is( $c[3], "main::__ANON__", "anonymous subroutine name" );
64ok( $c[4], "hasargs true with anon sub" );
07b8c804
RGS
65
66sub foo2 { f() }
67my $fooref2 = delete $::{foo2};
68$fooref2 -> ();
803f2748
DM
69is( $c[3], "main::__ANON__", "deleted subroutine name" );
70ok( $c[4], "hasargs true with deleted sub" );
75b6c4ca
RGS
71
72# See if caller() returns the correct warning mask
73
886f1e3e
JH
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{
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
94sub 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 }
886f1e3e
JH
111 BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 12, 'all bits off via "no warnings"' ) }
112 testwarn("\0" x 12, 'no bits');
2db3864f 113
75b6c4ca 114 use warnings;
ac27d13b
NC
115 BEGIN { check_bits( ${^WARNING_BITS}, $default,
116 'default bits on via "use warnings"' ); }
117 BEGIN { testwarn($default, 'all'); }
75b6c4ca
RGS
118 # run-time :
119 # the warning mask has been extended by warnings::register
ac27d13b 120 testwarn($registered, 'ahead of w::r');
2db3864f 121
75b6c4ca 122 use warnings::register;
ac27d13b
NC
123 BEGIN { check_bits( ${^WARNING_BITS}, $registered,
124 'warning bits on via "use warnings::register"' ) }
125 testwarn($registered, 'following w::r');
75b6c4ca 126}
f2a7f298 127
128
129# The next two cases test for a bug where caller ignored evals if
130# the DB::sub glob existed but &DB::sub did not (for example, if
131# $^P had been set but no debugger has been loaded). The tests
132# thus assume that there is no &DB::sub: if there is one, they
133# should both pass no matter whether or not this bug has been
134# fixed.
135
136my $debugger_test = q<
137 my @stackinfo = caller(0);
138 return scalar @stackinfo;
139>;
140
141sub pb { return (caller(0))[3] }
142
143my $i = eval $debugger_test;
b3ca2e83 144is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
f2a7f298 145
146is( eval 'pb()', 'main::pb', "actually return the right function name" );
147
148my $saved_perldb = $^P;
149$^P = 16;
150$^P = $saved_perldb;
151
152$i = eval $debugger_test;
b3ca2e83 153is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
f2a7f298 154is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
155
71860c90
NC
156print "# caller can now return the compile time state of %^H\n";
157
d8c5b3c5
NC
158sub hint_exists {
159 my $key = shift;
71860c90
NC
160 my $level = shift;
161 my @results = caller($level||0);
d8c5b3c5 162 exists $results[10]->{$key};
71860c90
NC
163}
164
d8c5b3c5
NC
165sub hint_fetch {
166 my $key = shift;
b3ca2e83
NC
167 my $level = shift;
168 my @results = caller($level||0);
d8c5b3c5 169 $results[10]->{$key};
b3ca2e83 170}
71860c90 171
5b235299
NC
172{
173 my $tmpfile = tempfile();
174
175 open my $fh, '>', $tmpfile or die "open $tmpfile: $!";
176 print $fh <<'EOP';
177#!perl -wl
178use strict;
179
180{
181 package KAZASH ;
182
183 sub DESTROY {
184 print "DESTROY";
185 }
186}
187
188@DB::args = bless [], 'KAZASH';
189
190print $^P;
191print scalar @DB::args;
192
193{
194 local $^P = shift;
195}
196
197@DB::args = (); # At this point, the object should be freed.
198
199print $^P;
200print scalar @DB::args;
201
202# It shouldn't leak.
203EOP
ade9cf97 204 close $fh;
5b235299
NC
205
206 foreach (0, 1) {
207 my $got = runperl(progfile => $tmpfile, args => [$_]);
208 $got =~ s/\s+/ /gs;
209 like($got, qr/\s*0 1 DESTROY 0 0\s*/,
210 "\@DB::args doesn't leak with \$^P = $_");
211 }
212}
213
d8c5b3c5 214$::testing_caller = 1;
a24d89c9 215
e81465be 216do './op/caller.pl' or die $@;