Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.git] / t / op / caller.t
CommitLineData
07b8c804 1#!./perl
2# Tests for caller()
3
4BEGIN {
5 chdir 't' if -d 't';
6 @INC = '../lib';
7 require './test.pl';
d8c5b3c5 8 plan( tests => 78 );
07b8c804 9}
10
07b8c804 11my @c;
12
72699b0f 13print "# Tests with caller(0)\n";
14
07b8c804 15@c = caller(0);
16ok( (!@c), "caller(0) in main program" );
17
18eval { @c = caller(0) };
72699b0f 19is( $c[3], "(eval)", "subroutine name in an eval {}" );
20ok( !$c[4], "hasargs false in an eval {}" );
07b8c804 21
22eval q{ @c = (Caller(0))[3] };
72699b0f 23is( $c[3], "(eval)", "subroutine name in an eval ''" );
24ok( !$c[4], "hasargs false in an eval ''" );
07b8c804 25
26sub { @c = caller(0) } -> ();
72699b0f 27is( $c[3], "main::__ANON__", "anonymous subroutine name" );
28ok( $c[4], "hasargs true with anon sub" );
07b8c804 29
30# Bug 20020517.003, used to dump core
31sub foo { @c = caller(0) }
32my $fooref = delete $::{foo};
33$fooref -> ();
72699b0f 34is( $c[3], "(unknown)", "unknown subroutine name" );
35ok( $c[4], "hasargs true with unknown sub" );
36
37print "# Tests with caller(1)\n";
07b8c804 38
39sub f { @c = caller(1) }
40
72699b0f 41sub callf { f(); }
42callf();
43is( $c[3], "main::callf", "subroutine name" );
44ok( $c[4], "hasargs true with callf()" );
45&callf;
46ok( !$c[4], "hasargs false with &callf" );
47
07b8c804 48eval { f() };
72699b0f 49is( $c[3], "(eval)", "subroutine name in an eval {}" );
50ok( !$c[4], "hasargs false in an eval {}" );
07b8c804 51
52eval q{ f() };
72699b0f 53is( $c[3], "(eval)", "subroutine name in an eval ''" );
54ok( !$c[4], "hasargs false in an eval ''" );
07b8c804 55
56sub { f() } -> ();
72699b0f 57is( $c[3], "main::__ANON__", "anonymous subroutine name" );
58ok( $c[4], "hasargs true with anon sub" );
07b8c804 59
60sub foo2 { f() }
61my $fooref2 = delete $::{foo2};
62$fooref2 -> ();
72699b0f 63is( $c[3], "(unknown)", "unknown subroutine name" );
64ok( $c[4], "hasargs true with unknown sub" );
75b6c4ca 65
66# See if caller() returns the correct warning mask
67
886f1e3e 68sub 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
78sub check_bits
79{
ac27d13b 80 local $Level = $Level + 2;
886f1e3e 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 88sub testwarn {
89 my $w = shift;
886f1e3e 90 my $id = shift;
91 check_bits( (caller(0))[9], $w, "warnings match caller ($id)");
75b6c4ca 92}
93
75b6c4ca 94{
95 no warnings;
ac27d13b 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 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 109 BEGIN { check_bits( ${^WARNING_BITS}, $default,
110 'default bits on via "use warnings"' ); }
111 BEGIN { testwarn($default, 'all'); }
75b6c4ca 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 117 BEGIN { check_bits( ${^WARNING_BITS}, $registered,
118 'warning bits on via "use warnings::register"' ) }
119 testwarn($registered, 'following w::r');
75b6c4ca 120}
f2a7f298 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
130my $debugger_test = q<
131 my @stackinfo = caller(0);
132 return scalar @stackinfo;
133>;
134
135sub pb { return (caller(0))[3] }
136
137my $i = eval $debugger_test;
b3ca2e83 138is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
f2a7f298 139
140is( eval 'pb()', 'main::pb', "actually return the right function name" );
141
142my $saved_perldb = $^P;
143$^P = 16;
144$^P = $saved_perldb;
145
146$i = eval $debugger_test;
b3ca2e83 147is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
f2a7f298 148is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
149
71860c90 150print "# caller can now return the compile time state of %^H\n";
151
d8c5b3c5 152sub hint_exists {
153 my $key = shift;
71860c90 154 my $level = shift;
155 my @results = caller($level||0);
d8c5b3c5 156 exists $results[10]->{$key};
71860c90 157}
158
d8c5b3c5 159sub hint_fetch {
160 my $key = shift;
b3ca2e83 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 168do './op/caller.pl' or die $@;