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