1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
#!./perl
# Tests for caller()
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
plan( tests => 78 );
}
my @c;
print "# Tests with caller(0)\n";
@c = caller(0);
ok( (!@c), "caller(0) in main program" );
eval { @c = caller(0) };
is( $c[3], "(eval)", "subroutine name in an eval {}" );
ok( !$c[4], "hasargs false in an eval {}" );
eval q{ @c = (Caller(0))[3] };
is( $c[3], "(eval)", "subroutine name in an eval ''" );
ok( !$c[4], "hasargs false in an eval ''" );
sub { @c = caller(0) } -> ();
is( $c[3], "main::__ANON__", "anonymous subroutine name" );
ok( $c[4], "hasargs true with anon sub" );
# Bug 20020517.003, used to dump core
sub foo { @c = caller(0) }
my $fooref = delete $::{foo};
$fooref -> ();
is( $c[3], "(unknown)", "unknown subroutine name" );
ok( $c[4], "hasargs true with unknown sub" );
print "# Tests with caller(1)\n";
sub f { @c = caller(1) }
sub callf { f(); }
callf();
is( $c[3], "main::callf", "subroutine name" );
ok( $c[4], "hasargs true with callf()" );
&callf;
ok( !$c[4], "hasargs false with &callf" );
eval { f() };
is( $c[3], "(eval)", "subroutine name in an eval {}" );
ok( !$c[4], "hasargs false in an eval {}" );
eval q{ f() };
is( $c[3], "(eval)", "subroutine name in an eval ''" );
ok( !$c[4], "hasargs false in an eval ''" );
sub { f() } -> ();
is( $c[3], "main::__ANON__", "anonymous subroutine name" );
ok( $c[4], "hasargs true with anon sub" );
sub foo2 { f() }
my $fooref2 = delete $::{foo2};
$fooref2 -> ();
is( $c[3], "(unknown)", "unknown subroutine name" );
ok( $c[4], "hasargs true with unknown sub" );
# See if caller() returns the correct warning mask
sub show_bits
{
my $in = shift;
my $out = '';
foreach (unpack('W*', $in)) {
$out .= sprintf('\x%02x', $_);
}
return $out;
}
sub check_bits
{
local $Level = $Level + 2;
my ($got, $exp, $desc) = @_;
if (! ok($got eq $exp, $desc)) {
diag(' got: ' . show_bits($got));
diag('expected: ' . show_bits($exp));
}
}
sub testwarn {
my $w = shift;
my $id = shift;
check_bits( (caller(0))[9], $w, "warnings match caller ($id)");
}
{
no warnings;
# Build the warnings mask dynamically
my ($default, $registered);
BEGIN {
for my $i (0..$warnings::LAST_BIT/2 - 1) {
vec($default, $i, 2) = 1;
}
$registered = $default;
vec($registered, $warnings::LAST_BIT/2, 2) = 1;
}
BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 12, 'all bits off via "no warnings"' ) }
testwarn("\0" x 12, 'no bits');
use warnings;
BEGIN { check_bits( ${^WARNING_BITS}, $default,
'default bits on via "use warnings"' ); }
BEGIN { testwarn($default, 'all'); }
# run-time :
# the warning mask has been extended by warnings::register
testwarn($registered, 'ahead of w::r');
use warnings::register;
BEGIN { check_bits( ${^WARNING_BITS}, $registered,
'warning bits on via "use warnings::register"' ) }
testwarn($registered, 'following w::r');
}
# The next two cases test for a bug where caller ignored evals if
# the DB::sub glob existed but &DB::sub did not (for example, if
# $^P had been set but no debugger has been loaded). The tests
# thus assume that there is no &DB::sub: if there is one, they
# should both pass no matter whether or not this bug has been
# fixed.
my $debugger_test = q<
my @stackinfo = caller(0);
return scalar @stackinfo;
>;
sub pb { return (caller(0))[3] }
my $i = eval $debugger_test;
is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
is( eval 'pb()', 'main::pb', "actually return the right function name" );
my $saved_perldb = $^P;
$^P = 16;
$^P = $saved_perldb;
$i = eval $debugger_test;
is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
print "# caller can now return the compile time state of %^H\n";
sub hint_exists {
my $key = shift;
my $level = shift;
my @results = caller($level||0);
exists $results[10]->{$key};
}
sub hint_fetch {
my $key = shift;
my $level = shift;
my @results = caller($level||0);
$results[10]->{$key};
}
$::testing_caller = 1;
do './op/caller.pl' or die $@;
|
