This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
use the correct type for a format field width parameter
[perl5.git] / lib / Carp.t
CommitLineData
0e25c5fd 1BEGIN {
d38ea511
DR
2 chdir 't' if -d 't';
3 @INC = '../lib';
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
7154346b 14BEGIN {
1a6d5308 15 plan tests => 58;
0e25c5fd 16
d38ea511
DR
17 # This test must be run at BEGIN time, because code later in this file
18 # sets CORE::GLOBAL::caller
19 ok !exists $CORE::GLOBAL::{caller},
20 "Loading doesn't create CORE::GLOBAL::caller";
7154346b 21}
0e25c5fd 22
d38ea511
DR
23{
24 local $SIG{__WARN__} = sub {
25 like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n';
26 };
22dc90ad 27
d38ea511 28 carp "ok 2\n";
ce707141
CB
29}
30
d38ea511
DR
31{
32 local $SIG{__WARN__} = sub {
33 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3';
34 };
ce707141 35
d38ea511 36 carp 3;
ce707141 37}
0e25c5fd
JH
38
39sub sub_4 {
d38ea511
DR
40 local $SIG{__WARN__} = sub {
41 like $_[0],
42 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/,
43 'cluck 4';
44 };
0e25c5fd 45
d38ea511 46 cluck 4;
0e25c5fd
JH
47}
48
49sub_4;
50
d38ea511
DR
51{
52 local $SIG{__DIE__} = sub {
53 like $_[0],
54 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/,
55 'croak 5';
56 };
0e25c5fd 57
d38ea511 58 eval { croak 5 };
ce707141 59}
0e25c5fd
JH
60
61sub sub_6 {
ce707141 62 local $SIG{__DIE__} = sub {
d38ea511
DR
63 like $_[0],
64 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+$/,
65 'confess 6';
66 };
0e25c5fd
JH
67
68 eval { confess 6 };
69}
70
71sub_6;
72
ce707141 73ok(1);
0e25c5fd 74
976ea96e 75# test for caller_info API
ba7a4549 76my $eval = "use Carp; return Carp::caller_info(0);";
976ea96e 77my %info = eval($eval);
d38ea511 78is( $info{sub_name}, "eval '$eval'", 'caller_info API' );
b5777b26 79
ba7a4549 80# test for '...::CARP_NOT used only once' warning from Carp
b5777b26
RB
81my $warning;
82eval {
83 BEGIN {
d38ea511
DR
84 local $SIG{__WARN__} = sub {
85 if ( defined $^S ) { warn $_[0] }
86 else { $warning = $_[0] }
87 }
b5777b26 88 }
d38ea511 89
22dc90ad 90 package Z;
d38ea511
DR
91
92 BEGIN {
93 eval { Carp::croak() };
94 }
b5777b26 95};
ba7a4549 96ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
22dc90ad 97
d735c2ef 98# Test the location of error messages.
d38ea511 99like( A::short(), qr/^Error at C/, "Short messages skip carped package" );
d735c2ef
BT
100
101{
102 local @C::ISA = "D";
d38ea511 103 like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
d735c2ef
BT
104}
105
106{
107 local @D::ISA = "C";
d38ea511 108 like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
d735c2ef
BT
109}
110
111{
112 local @D::ISA = "B";
113 local @B::ISA = "C";
d38ea511 114 like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
d735c2ef
BT
115}
116
117{
118 local @B::ISA = "D";
119 local @C::ISA = "B";
d38ea511 120 like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
d735c2ef
BT
121}
122
123{
124 local @C::CARP_NOT = "D";
d38ea511 125 like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
d735c2ef
BT
126}
127
128{
129 local @D::CARP_NOT = "C";
d38ea511 130 like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
d735c2ef
BT
131}
132
133{
134 local @D::CARP_NOT = "B";
135 local @B::CARP_NOT = "C";
d38ea511 136 like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
d735c2ef
BT
137}
138
139{
140 local @B::CARP_NOT = "D";
141 local @C::CARP_NOT = "B";
d38ea511 142 like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
d735c2ef
BT
143}
144
145{
d38ea511 146 local @D::ISA = "C";
d735c2ef 147 local @D::CARP_NOT = "B";
d38ea511 148 like( A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance" );
d735c2ef
BT
149}
150
151{
d38ea511 152 local @D::ISA = "B";
d735c2ef 153 local @D::CARP_NOT = "C";
d38ea511 154 like( A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance" );
d735c2ef
BT
155}
156
157# %Carp::Internal
158{
159 local $Carp::Internal{C} = 1;
d38ea511 160 like( A::short(), qr/^Error at B/, "Short doesn't report Internal" );
d735c2ef
BT
161}
162
163{
164 local $Carp::Internal{D} = 1;
d38ea511 165 like( A::long(), qr/^Error at C/, "Long doesn't report Internal" );
d735c2ef
BT
166}
167
168# %Carp::CarpInternal
169{
170 local $Carp::CarpInternal{D} = 1;
d38ea511
DR
171 like(
172 A::short(), qr/^Error at B/,
173 "Short doesn't report calls to CarpInternal"
174 );
d735c2ef
BT
175}
176
177{
178 local $Carp::CarpInternal{D} = 1;
d38ea511 179 like( A::long(), qr/^Error at C/, "Long doesn't report CarpInternal" );
d735c2ef 180}
22dc90ad
JB
181
182# tests for global variables
183sub x { carp @_ }
184sub w { cluck @_ }
185
186# $Carp::Verbose;
d38ea511
DR
187{
188 my $aref = [
ce707141
CB
189 qr/t at \S*(?i:carp.t) line \d+/,
190 qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
22dc90ad 191 ];
ce707141 192 my $i = 0;
22dc90ad
JB
193
194 for my $re (@$aref) {
195 local $Carp::Verbose = $i++;
196 local $SIG{__WARN__} = sub {
ce707141 197 like $_[0], $re, 'Verbose';
d38ea511
DR
198 };
199
22dc90ad
JB
200 package Z;
201 main::x('t');
202 }
203}
204
205# $Carp::MaxEvalLen
d38ea511
DR
206{
207 my $test_num = 1;
208 for ( 0, 4 ) {
22dc90ad
JB
209 my $txt = "Carp::cluck($test_num)";
210 local $Carp::MaxEvalLen = $_;
211 local $SIG{__WARN__} = sub {
d38ea511
DR
212 "@_" =~ /'(.+?)(?:\n|')/s;
213 is length($1),
214 length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ),
215 'MaxEvalLen';
216 };
217 eval "$txt";
218 $test_num++;
22dc90ad
JB
219 }
220}
221
222# $Carp::MaxArgLen
ce707141 223{
d38ea511 224 for ( 0, 4 ) {
22dc90ad
JB
225 my $arg = 'testtest';
226 local $Carp::MaxArgLen = $_;
227 local $SIG{__WARN__} = sub {
d38ea511
DR
228 "@_" =~ /'(.+?)'/;
229 is length($1),
230 length( $_ ? substr( $arg, 0, $_ ) : substr( $arg, 0 ) ),
231 'MaxArgLen';
232 };
22dc90ad
JB
233
234 package Z;
235 main::w($arg);
236 }
237}
238
239# $Carp::MaxArgNums
d38ea511
DR
240{
241 my $i = 0;
22dc90ad 242 my $aref = [
ce707141
CB
243 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+/,
244 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
245 ];
246
d38ea511 247 for (@$aref) {
22dc90ad
JB
248 local $Carp::MaxArgNums = $i++;
249 local $SIG{__WARN__} = sub {
d38ea511
DR
250 like "@_", $_, 'MaxArgNums';
251 };
22dc90ad
JB
252
253 package Z;
d38ea511 254 main::w( 1 .. 4 );
22dc90ad
JB
255 }
256}
257
258# $Carp::CarpLevel
d38ea511
DR
259{
260 my $i = 0;
22dc90ad 261 my $aref = [
ce707141
CB
262 qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
263 qr/1 at \S*(?i:carp.t) line \d+$/,
22dc90ad
JB
264 ];
265
266 for (@$aref) {
267 local $Carp::CarpLevel = $i++;
268 local $SIG{__WARN__} = sub {
d38ea511
DR
269 like "@_", $_, 'CarpLevel';
270 };
22dc90ad
JB
271
272 package Z;
273 main::w(1);
274 }
275}
62e1ddac 276
4b09a709
MS
277{
278 local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
279
280 # Check that croak() and confess() don't clobber $!
d38ea511
DR
281 runperl(
282 prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
283 stderr => 1
284 );
4b09a709 285
d38ea511 286 is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
4b09a709 287
d38ea511
DR
288 runperl(
289 prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
290 stderr => 1
291 );
4b09a709 292
d38ea511 293 is( $? >> 8, 42, 'confess() doesn\'t clobber $!' );
4b09a709 294}
d735c2ef 295
9cb6ed42
NC
296# undef used to be incorrectly reported as the string "undef"
297sub cluck_undef {
298
d38ea511
DR
299 local $SIG{__WARN__} = sub {
300 like $_[0],
301 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+$/,
302 "cluck doesn't quote undef";
303 };
9cb6ed42 304
d38ea511 305 cluck "Bang!"
9cb6ed42
NC
306
307}
308
d38ea511 309cluck_undef( 0, "undef", 2, undef, 4 );
9cb6ed42 310
248ae9a5
DG
311# check that Carp respects CORE::GLOBAL::caller override after Carp
312# has been compiled
d38ea511
DR
313for my $bodge_job ( 2, 1, 0 ) {
314 print '# ', ( $bodge_job ? 'Not ' : '' ),
315 "setting \@DB::args in caller override\n";
316 if ( $bodge_job == 1 ) {
317 require B;
318 print "# required B\n";
bf236c8e 319 }
248ae9a5 320 my $accum = '';
a894cef1 321 local *CORE::GLOBAL::caller = sub {
d38ea511
DR
322 local *__ANON__ = "fakecaller";
323 my @c = CORE::caller(@_);
a894cef1
RGS
324 $c[0] ||= 'undef';
325 $accum .= "@c[0..3]\n";
d38ea511
DR
326 if ( !$bodge_job && CORE::caller() eq 'DB' ) {
327
eff7e72c 328 package DB;
d38ea511
DR
329 return CORE::caller( ( $_[0] || 0 ) + 1 );
330 }
331 else {
332 return CORE::caller( ( $_[0] || 0 ) + 1 );
eff7e72c 333 }
a894cef1 334 };
248ae9a5 335 eval "scalar caller()";
d38ea511
DR
336 like( $accum, qr/main::fakecaller/,
337 "test CORE::GLOBAL::caller override in eval" );
248ae9a5 338 $accum = '';
eff7e72c 339 my $got = A::long(42);
d38ea511
DR
340 like( $accum, qr/main::fakecaller/,
341 "test CORE::GLOBAL::caller override in Carp" );
eff7e72c 342 my $package = 'A';
bf236c8e 343 my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
d38ea511
DR
344 my $warning
345 = $bodge_job
346 ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
347 : '';
348
349 for ( 0 .. 2 ) {
350 my $previous_package = $package;
351 ++$package;
352 like( $got,
353 qr/${package}::long\($warning\) called at $previous_package line \d+/,
354 "Correct arguments for $package" );
eff7e72c 355 }
bf236c8e 356 my $arg = $bodge_job ? $warning : 42;
d38ea511
DR
357 like(
358 $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
359 'Correct arguments for A'
360 );
248ae9a5
DG
361}
362
bf236c8e
NC
363eval <<'EOT';
364no warnings 'redefine';
365sub CORE::GLOBAL::caller {
366 my $height = $_[0];
367 $height++;
368 return CORE::caller($height);
369}
370EOT
371
372my $got = A::long(42);
373
d38ea511
DR
374like(
375 $got,
376 qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
377 'Correct arguments for A'
378);
bf236c8e 379
018c7c82
FC
380# UTF8-flagged strings should not cause Carp to try to load modules (even
381# implicitly via utf8_heavy.pl) after a syntax error [perl #82854].
382fresh_perl_like(
383 q<
384 use utf8; use strict; use Carp;
385 BEGIN { $SIG{__DIE__} = sub { Carp::croak "aaaaa$_[0]" } }
386 $c
387 >,
388 qr/aaaaa/,
389 {stderr=>1},
390 'Carp can handle UTF8-flagged strings after a syntax error',
391);
392
1a6d5308
FC
393fresh_perl_is(
394 q<
395 use Carp;
396 $SIG{__WARN__} = sub{};
397 carp ("A duck, but which duck?");
398 print "ok" unless exists $::{"B::"};
399 >,
400 'ok',
401 {},
402 'Carp does not autovivify *B::'
403);
404
bf236c8e
NC
405# New tests go here
406
d735c2ef
BT
407# line 1 "A"
408package A;
d38ea511 409
d735c2ef
BT
410sub short {
411 B::short();
412}
413
414sub long {
415 B::long();
416}
417
418# line 1 "B"
419package B;
d38ea511 420
d735c2ef
BT
421sub short {
422 C::short();
423}
424
425sub long {
426 C::long();
427}
428
429# line 1 "C"
430package C;
d38ea511 431
d735c2ef
BT
432sub short {
433 D::short();
434}
435
436sub long {
437 D::long();
438}
439
440# line 1 "D"
441package D;
d38ea511 442
d735c2ef 443sub short {
d38ea511 444 eval { Carp::croak("Error") };
d735c2ef
BT
445 return $@;
446}
447
448sub long {
d38ea511 449 eval { Carp::confess("Error") };
d735c2ef
BT
450 return $@;
451}
bf236c8e
NC
452
453# Put new tests at "new tests go here"
454__END__