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