latest switch/say/~~
[p5sagit/p5-mst-13.2.git] / lib / Carp.t
CommitLineData
0e25c5fd 1BEGIN {
2 chdir 't' if -d 't';
3 @INC = '../lib';
ce707141 4 require './test.pl';
0e25c5fd 5}
6
4b09a709 7my $Is_VMS = $^O eq 'VMS';
8
0e25c5fd 9use Carp qw(carp cluck croak confess);
10
62e1ddac 11plan tests => 21;
0e25c5fd 12
ce707141 13ok 1;
0e25c5fd 14
ce707141 15{ local $SIG{__WARN__} = sub {
16 like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' };
0e25c5fd 17
ce707141 18 carp "ok 2\n";
22dc90ad 19
ce707141 20}
21
22{ local $SIG{__WARN__} = sub {
23 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' };
0e25c5fd 24
ce707141 25 carp 3;
26
27}
0e25c5fd 28
29sub sub_4 {
30
ce707141 31local $SIG{__WARN__} = sub {
32 like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 'cluck 4' };
0e25c5fd 33
34cluck 4;
35
36}
37
38sub_4;
39
ce707141 40{ local $SIG{__DIE__} = sub {
41 like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 'croak 5' };
0e25c5fd 42
ce707141 43 eval { croak 5 };
44}
0e25c5fd 45
46sub sub_6 {
ce707141 47 local $SIG{__DIE__} = sub {
48 like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/, 'confess 6' };
0e25c5fd 49
50 eval { confess 6 };
51}
52
53sub_6;
54
ce707141 55ok(1);
0e25c5fd 56
976ea96e 57# test for caller_info API
58my $eval = "use Carp::Heavy; return Carp::caller_info(0);";
59my %info = eval($eval);
ce707141 60is($info{sub_name}, "eval '$eval'", 'caller_info API');
b5777b26 61
62# test for '...::CARP_NOT used only once' warning from Carp::Heavy
63my $warning;
64eval {
65 BEGIN {
66 $^W = 1;
ce707141 67 local $SIG{__WARN__} =
b5777b26 68 sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
69 }
22dc90ad 70 package Z;
b5777b26 71 BEGIN { eval { Carp::croak() } }
72};
ce707141 73ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/;
22dc90ad 74
75
76# tests for global variables
77sub x { carp @_ }
78sub w { cluck @_ }
79
80# $Carp::Verbose;
81{ my $aref = [
ce707141 82 qr/t at \S*(?i:carp.t) line \d+/,
83 qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
22dc90ad 84 ];
ce707141 85 my $i = 0;
22dc90ad 86
87 for my $re (@$aref) {
88 local $Carp::Verbose = $i++;
89 local $SIG{__WARN__} = sub {
ce707141 90 like $_[0], $re, 'Verbose';
22dc90ad 91 };
92 package Z;
93 main::x('t');
94 }
95}
96
97# $Carp::MaxEvalLen
ce707141 98{ my $test_num = 1;
22dc90ad 99 for(0,4) {
100 my $txt = "Carp::cluck($test_num)";
101 local $Carp::MaxEvalLen = $_;
102 local $SIG{__WARN__} = sub {
103 "@_"=~/'(.+?)(?:\n|')/s;
ce707141 104 is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
22dc90ad 105 };
106 eval "$txt"; $test_num++;
107 }
108}
109
110# $Carp::MaxArgLen
ce707141 111{
22dc90ad 112 for(0,4) {
113 my $arg = 'testtest';
114 local $Carp::MaxArgLen = $_;
115 local $SIG{__WARN__} = sub {
116 "@_"=~/'(.+?)'/;
ce707141 117 is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
22dc90ad 118 };
119
120 package Z;
121 main::w($arg);
122 }
123}
124
125# $Carp::MaxArgNums
ce707141 126{ my $i = 0;
22dc90ad 127 my $aref = [
ce707141 128 qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/,
129 qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/,
22dc90ad 130 ];
131
132 for(@$aref) {
133 local $Carp::MaxArgNums = $i++;
134 local $SIG{__WARN__} = sub {
ce707141 135 like "@_", $_, 'MaxArgNums';
22dc90ad 136 };
137
138 package Z;
139 main::w(1..4);
140 }
141}
142
143# $Carp::CarpLevel
ce707141 144{ my $i = 0;
22dc90ad 145 my $aref = [
ce707141 146 qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
147 qr/1 at \S*(?i:carp.t) line \d+$/,
22dc90ad 148 ];
149
150 for (@$aref) {
151 local $Carp::CarpLevel = $i++;
152 local $SIG{__WARN__} = sub {
ce707141 153 like "@_", $_, 'CarpLevel';
22dc90ad 154 };
155
156 package Z;
157 main::w(1);
158 }
159}
62e1ddac 160
4b09a709 161
162{
163 local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
164
165 # Check that croak() and confess() don't clobber $!
166 runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
167 stderr => 1);
168
169 is($?>>8, 42, 'croak() doesn\'t clobber $!');
170
171 runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
172 stderr => 1);
173
174 is($?>>8, 42, 'confess() doesn\'t clobber $!');
175}