This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix MGVTBL structures in perl.h
[perl5.git] / t / op / caller.t
CommitLineData
07b8c804
RGS
1#!./perl
2# Tests for caller()
3
4BEGIN {
5 chdir 't' if -d 't';
6 @INC = '../lib';
7 require './test.pl';
75b6c4ca 8 plan( tests => 27 );
07b8c804
RGS
9}
10
07b8c804
RGS
11my @c;
12
72699b0f
RGS
13print "# Tests with caller(0)\n";
14
07b8c804
RGS
15@c = caller(0);
16ok( (!@c), "caller(0) in main program" );
17
18eval { @c = caller(0) };
72699b0f
RGS
19is( $c[3], "(eval)", "subroutine name in an eval {}" );
20ok( !$c[4], "hasargs false in an eval {}" );
07b8c804
RGS
21
22eval q{ @c = (Caller(0))[3] };
72699b0f
RGS
23is( $c[3], "(eval)", "subroutine name in an eval ''" );
24ok( !$c[4], "hasargs false in an eval ''" );
07b8c804
RGS
25
26sub { @c = caller(0) } -> ();
72699b0f
RGS
27is( $c[3], "main::__ANON__", "anonymous subroutine name" );
28ok( $c[4], "hasargs true with anon sub" );
07b8c804
RGS
29
30# Bug 20020517.003, used to dump core
31sub foo { @c = caller(0) }
32my $fooref = delete $::{foo};
33$fooref -> ();
72699b0f
RGS
34is( $c[3], "(unknown)", "unknown subroutine name" );
35ok( $c[4], "hasargs true with unknown sub" );
36
37print "# Tests with caller(1)\n";
07b8c804
RGS
38
39sub f { @c = caller(1) }
40
72699b0f
RGS
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
RGS
49is( $c[3], "(eval)", "subroutine name in an eval {}" );
50ok( !$c[4], "hasargs false in an eval {}" );
07b8c804
RGS
51
52eval q{ f() };
72699b0f
RGS
53is( $c[3], "(eval)", "subroutine name in an eval ''" );
54ok( !$c[4], "hasargs false in an eval ''" );
07b8c804
RGS
55
56sub { f() } -> ();
72699b0f
RGS
57is( $c[3], "main::__ANON__", "anonymous subroutine name" );
58ok( $c[4], "hasargs true with anon sub" );
07b8c804
RGS
59
60sub foo2 { f() }
61my $fooref2 = delete $::{foo2};
62$fooref2 -> ();
72699b0f
RGS
63is( $c[3], "(unknown)", "unknown subroutine name" );
64ok( $c[4], "hasargs true with unknown sub" );
75b6c4ca
RGS
65
66# See if caller() returns the correct warning mask
67
68sub 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}