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 | |
68 | sub testwarn { |
69 | my $w = shift; |
2db3864f |
70 | is( (caller(0))[9], $w, "warnings match caller"); |
75b6c4ca |
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 |
80 | BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUU\025", 'default bits on via "use warnings"' ); } |
81 | BEGIN { testwarn("UUUUUUUUUUU\025", "#1"); } |
75b6c4ca |
82 | # run-time : |
83 | # the warning mask has been extended by warnings::register |
2db3864f |
84 | testwarn("UUUUUUUUUUUU"); |
85 | |
75b6c4ca |
86 | use warnings::register; |
2db3864f |
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 | |
99 | my $debugger_test = q< |
100 | my @stackinfo = caller(0); |
101 | return scalar @stackinfo; |
102 | >; |
103 | |
104 | sub pb { return (caller(0))[3] } |
105 | |
106 | my $i = eval $debugger_test; |
b3ca2e83 |
107 | is( $i, 11, "do not skip over eval (and caller returns 10 elements)" ); |
f2a7f298 |
108 | |
109 | is( eval 'pb()', 'main::pb', "actually return the right function name" ); |
110 | |
111 | my $saved_perldb = $^P; |
112 | $^P = 16; |
113 | $^P = $saved_perldb; |
114 | |
115 | $i = eval $debugger_test; |
b3ca2e83 |
116 | is( $i, 11, 'do not skip over eval even if $^P had been on at some point' ); |
f2a7f298 |
117 | is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); |
118 | |
71860c90 |
119 | print "# caller can now return the compile time state of %^H\n"; |
120 | |
d8c5b3c5 |
121 | sub hint_exists { |
122 | my $key = shift; |
71860c90 |
123 | my $level = shift; |
124 | my @results = caller($level||0); |
d8c5b3c5 |
125 | exists $results[10]->{$key}; |
71860c90 |
126 | } |
127 | |
d8c5b3c5 |
128 | sub hint_fetch { |
129 | my $key = shift; |
b3ca2e83 |
130 | my $level = shift; |
131 | my @results = caller($level||0); |
d8c5b3c5 |
132 | $results[10]->{$key}; |
b3ca2e83 |
133 | } |
71860c90 |
134 | |
d8c5b3c5 |
135 | $::testing_caller = 1; |
a24d89c9 |
136 | |
d8c5b3c5 |
137 | do './op/caller.pl'; |