This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add legacy.pm to Maintainers
[perl5.git] / lib / Carp.t
CommitLineData
0e25c5fd
JH
1BEGIN {
2 chdir 't' if -d 't';
3 @INC = '../lib';
ce707141 4 require './test.pl';
0e25c5fd
JH
5}
6
4b09a709
MS
7my $Is_VMS = $^O eq 'VMS';
8
0e25c5fd
JH
9use Carp qw(carp cluck croak confess);
10
9cb6ed42 11plan tests => 37;
0e25c5fd 12
ce707141 13ok 1;
0e25c5fd 14
ce707141
CB
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
CB
20}
21
22{ local $SIG{__WARN__} = sub {
23 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' };
0e25c5fd 24
ce707141
CB
25 carp 3;
26
27}
0e25c5fd
JH
28
29sub sub_4 {
30
ce707141
CB
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
JH
33
34cluck 4;
35
36}
37
38sub_4;
39
ce707141
CB
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
CB
43 eval { croak 5 };
44}
0e25c5fd
JH
45
46sub sub_6 {
ce707141
CB
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
JH
49
50 eval { confess 6 };
51}
52
53sub_6;
54
ce707141 55ok(1);
0e25c5fd 56
976ea96e 57# test for caller_info API
ba7a4549 58my $eval = "use Carp; return Carp::caller_info(0);";
976ea96e 59my %info = eval($eval);
ce707141 60is($info{sub_name}, "eval '$eval'", 'caller_info API');
b5777b26 61
ba7a4549 62# test for '...::CARP_NOT used only once' warning from Carp
b5777b26
RB
63my $warning;
64eval {
65 BEGIN {
66 $^W = 1;
ce707141 67 local $SIG{__WARN__} =
b5777b26
RB
68 sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
69 }
22dc90ad 70 package Z;
b5777b26
RB
71 BEGIN { eval { Carp::croak() } }
72};
ba7a4549 73ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
22dc90ad 74
d735c2ef
BT
75# Test the location of error messages.
76like(A::short(), qr/^Error at C/, "Short messages skip carped package");
77
78{
79 local @C::ISA = "D";
80 like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
81}
82
83{
84 local @D::ISA = "C";
85 like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
86}
87
88{
89 local @D::ISA = "B";
90 local @B::ISA = "C";
91 like(A::short(), qr/^Error at A/, "Inheritance is transitive");
92}
93
94{
95 local @B::ISA = "D";
96 local @C::ISA = "B";
97 like(A::short(), qr/^Error at A/, "Inheritance is transitive");
98}
99
100{
101 local @C::CARP_NOT = "D";
102 like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
103}
104
105{
106 local @D::CARP_NOT = "C";
107 like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
108}
109
110{
111 local @D::CARP_NOT = "B";
112 local @B::CARP_NOT = "C";
113 like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
114}
115
116{
117 local @B::CARP_NOT = "D";
118 local @C::CARP_NOT = "B";
119 like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
120}
121
122{
123 local @D::ISA = "C";
124 local @D::CARP_NOT = "B";
125 like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance");
126}
127
128{
129 local @D::ISA = "B";
130 local @D::CARP_NOT = "C";
131 like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance");
132}
133
134# %Carp::Internal
135{
136 local $Carp::Internal{C} = 1;
137 like(A::short(), qr/^Error at B/, "Short doesn't report Internal");
138}
139
140{
141 local $Carp::Internal{D} = 1;
142 like(A::long(), qr/^Error at C/, "Long doesn't report Internal");
143}
144
145# %Carp::CarpInternal
146{
147 local $Carp::CarpInternal{D} = 1;
148 like(A::short(), qr/^Error at B/
149 , "Short doesn't report calls to CarpInternal");
150}
151
152{
153 local $Carp::CarpInternal{D} = 1;
154 like(A::long(), qr/^Error at C/, "Long doesn't report CarpInternal");
155}
22dc90ad
JB
156
157# tests for global variables
158sub x { carp @_ }
159sub w { cluck @_ }
160
161# $Carp::Verbose;
162{ my $aref = [
ce707141
CB
163 qr/t at \S*(?i:carp.t) line \d+/,
164 qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
22dc90ad 165 ];
ce707141 166 my $i = 0;
22dc90ad
JB
167
168 for my $re (@$aref) {
169 local $Carp::Verbose = $i++;
170 local $SIG{__WARN__} = sub {
ce707141 171 like $_[0], $re, 'Verbose';
22dc90ad
JB
172 };
173 package Z;
174 main::x('t');
175 }
176}
177
178# $Carp::MaxEvalLen
ce707141 179{ my $test_num = 1;
22dc90ad
JB
180 for(0,4) {
181 my $txt = "Carp::cluck($test_num)";
182 local $Carp::MaxEvalLen = $_;
183 local $SIG{__WARN__} = sub {
184 "@_"=~/'(.+?)(?:\n|')/s;
ce707141 185 is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
22dc90ad
JB
186 };
187 eval "$txt"; $test_num++;
188 }
189}
190
191# $Carp::MaxArgLen
ce707141 192{
22dc90ad
JB
193 for(0,4) {
194 my $arg = 'testtest';
195 local $Carp::MaxArgLen = $_;
196 local $SIG{__WARN__} = sub {
197 "@_"=~/'(.+?)'/;
ce707141 198 is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
22dc90ad
JB
199 };
200
201 package Z;
202 main::w($arg);
203 }
204}
205
206# $Carp::MaxArgNums
ce707141 207{ my $i = 0;
22dc90ad 208 my $aref = [
ce707141
CB
209 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+/,
210 qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/,
22dc90ad
JB
211 ];
212
213 for(@$aref) {
214 local $Carp::MaxArgNums = $i++;
215 local $SIG{__WARN__} = sub {
ce707141 216 like "@_", $_, 'MaxArgNums';
22dc90ad
JB
217 };
218
219 package Z;
220 main::w(1..4);
221 }
222}
223
224# $Carp::CarpLevel
ce707141 225{ my $i = 0;
22dc90ad 226 my $aref = [
ce707141
CB
227 qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
228 qr/1 at \S*(?i:carp.t) line \d+$/,
22dc90ad
JB
229 ];
230
231 for (@$aref) {
232 local $Carp::CarpLevel = $i++;
233 local $SIG{__WARN__} = sub {
ce707141 234 like "@_", $_, 'CarpLevel';
22dc90ad
JB
235 };
236
237 package Z;
238 main::w(1);
239 }
240}
62e1ddac 241
4b09a709
MS
242{
243 local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
244
245 # Check that croak() and confess() don't clobber $!
246 runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
247 stderr => 1);
248
249 is($?>>8, 42, 'croak() doesn\'t clobber $!');
250
251 runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
252 stderr => 1);
253
254 is($?>>8, 42, 'confess() doesn\'t clobber $!');
255}
d735c2ef 256
9cb6ed42
NC
257# undef used to be incorrectly reported as the string "undef"
258sub cluck_undef {
259
260local $SIG{__WARN__} = sub {
261 like $_[0], qr/^Bang! at.+\b(?i:carp\.t) line \d+\n\tmain::cluck_undef\(0, 'undef', 2, undef, 4\) called at.+\b(?i:carp\.t) line \d+$/, "cluck doesn't quote undef" };
262
263cluck "Bang!"
264
265}
266
267cluck_undef (0, "undef", 2, undef, 4);
268
d735c2ef
BT
269# line 1 "A"
270package A;
271sub short {
272 B::short();
273}
274
275sub long {
276 B::long();
277}
278
279# line 1 "B"
280package B;
281sub short {
282 C::short();
283}
284
285sub long {
286 C::long();
287}
288
289# line 1 "C"
290package C;
291sub short {
292 D::short();
293}
294
295sub long {
296 D::long();
297}
298
299# line 1 "D"
300package D;
301sub short {
302 eval{ Carp::croak("Error") };
303 return $@;
304}
305
306sub long {
307 eval{ Carp::confess("Error") };
308 return $@;
309}