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'; | |
f2a7f298 | 8 | plan( tests => 31 ); |
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 | ||
68 | sub testwarn { | |
69 | my $w = shift; | |
2db3864f | 70 | is( (caller(0))[9], $w, "warnings match caller"); |
75b6c4ca RGS |
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 AL |
80 | BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUU\025", 'default bits on via "use warnings"' ); } |
81 | BEGIN { testwarn("UUUUUUUUUUU\025", "#1"); } | |
75b6c4ca RGS |
82 | # run-time : |
83 | # the warning mask has been extended by warnings::register | |
2db3864f AL |
84 | testwarn("UUUUUUUUUUUU"); |
85 | ||
75b6c4ca | 86 | use warnings::register; |
2db3864f AL |
87 | BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUUU", 'warning bits on via "use warnings::register"' ) } |
88 | testwarn("UUUUUUUUUUUU","#3"); | |
75b6c4ca | 89 | } |
f2a7f298 DG |
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; | |
107 | is( $i, 10, "do not skip over eval (and caller returns 10 elements)" ); | |
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; | |
116 | is( $i, 10, 'do not skip over eval even if $^P had been on at some point' ); | |
117 | is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); | |
118 |