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'; |
d8c5b3c5 |
8 | plan( tests => 78 ); |
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 | |
886f1e3e |
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 | { |
80 | my ($got, $exp, $desc) = @_; |
81 | if (! ok($got eq $exp, $desc)) { |
82 | diag(' got: ' . show_bits($got)); |
83 | diag('expected: ' . show_bits($exp)); |
84 | } |
85 | } |
86 | |
75b6c4ca |
87 | sub testwarn { |
88 | my $w = shift; |
886f1e3e |
89 | my $id = shift; |
90 | check_bits( (caller(0))[9], $w, "warnings match caller ($id)"); |
75b6c4ca |
91 | } |
92 | |
93 | # NB : extend the warning mask values below when new warnings are added |
94 | { |
95 | no warnings; |
886f1e3e |
96 | BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 12, 'all bits off via "no warnings"' ) } |
97 | testwarn("\0" x 12, 'no bits'); |
2db3864f |
98 | |
75b6c4ca |
99 | use warnings; |
886f1e3e |
100 | BEGIN { check_bits( ${^WARNING_BITS}, "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", 'default bits on via "use warnings"' ); } |
101 | BEGIN { testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", 'all'); } |
75b6c4ca |
102 | # run-time : |
103 | # the warning mask has been extended by warnings::register |
886f1e3e |
104 | testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", 'ahead of w::r'); |
2db3864f |
105 | |
75b6c4ca |
106 | use warnings::register; |
886f1e3e |
107 | BEGIN { check_bits( ${^WARNING_BITS}, "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", 'warning bits on via "use warnings::register"' ) } |
108 | testwarn("\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", 'following w::r'); |
75b6c4ca |
109 | } |
f2a7f298 |
110 | |
111 | |
112 | # The next two cases test for a bug where caller ignored evals if |
113 | # the DB::sub glob existed but &DB::sub did not (for example, if |
114 | # $^P had been set but no debugger has been loaded). The tests |
115 | # thus assume that there is no &DB::sub: if there is one, they |
116 | # should both pass no matter whether or not this bug has been |
117 | # fixed. |
118 | |
119 | my $debugger_test = q< |
120 | my @stackinfo = caller(0); |
121 | return scalar @stackinfo; |
122 | >; |
123 | |
124 | sub pb { return (caller(0))[3] } |
125 | |
126 | my $i = eval $debugger_test; |
b3ca2e83 |
127 | is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); |
f2a7f298 |
128 | |
129 | is( eval 'pb()', 'main::pb', "actually return the right function name" ); |
130 | |
131 | my $saved_perldb = $^P; |
132 | $^P = 16; |
133 | $^P = $saved_perldb; |
134 | |
135 | $i = eval $debugger_test; |
b3ca2e83 |
136 | is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); |
f2a7f298 |
137 | is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); |
138 | |
71860c90 |
139 | print "# caller can now return the compile time state of %^H\n"; |
140 | |
d8c5b3c5 |
141 | sub hint_exists { |
142 | my $key = shift; |
71860c90 |
143 | my $level = shift; |
144 | my @results = caller($level||0); |
d8c5b3c5 |
145 | exists $results[10]->{$key}; |
71860c90 |
146 | } |
147 | |
d8c5b3c5 |
148 | sub hint_fetch { |
149 | my $key = shift; |
b3ca2e83 |
150 | my $level = shift; |
151 | my @results = caller($level||0); |
d8c5b3c5 |
152 | $results[10]->{$key}; |
b3ca2e83 |
153 | } |
71860c90 |
154 | |
d8c5b3c5 |
155 | $::testing_caller = 1; |
a24d89c9 |
156 | |
e81465be |
157 | do './op/caller.pl' or die $@; |