This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[cpan#100183] Add missing "<FH> chunk #" phrase to Carp messages
[perl5.git] / dist / Carp / t / Carp.t
CommitLineData
a894cef1
RGS
1use warnings;
2no warnings "once";
0fd3c67a 3use Config;
a894cef1 4
634ff085 5use IPC::Open3 1.0103 qw(open3);
2f7a15bf 6use Test::More tests => 67;
476b2fe1
Z
7
8sub runperl {
9 my(%args) = @_;
10 my($w, $r);
c8bca606 11
c8bca606
PR
12 local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
13
476b2fe1
Z
14 my $pid = open3($w, $r, undef, $^X, "-e", $args{prog});
15 close $w;
16 my $output = "";
17 while(<$r>) { $output .= $_; }
18 waitpid($pid, 0);
19 return $output;
20}
21
4b09a709
MS
22my $Is_VMS = $^O eq 'VMS';
23
0e25c5fd
JH
24use Carp qw(carp cluck croak confess);
25
7154346b 26BEGIN {
d38ea511
DR
27 # This test must be run at BEGIN time, because code later in this file
28 # sets CORE::GLOBAL::caller
29 ok !exists $CORE::GLOBAL::{caller},
30 "Loading doesn't create CORE::GLOBAL::caller";
7154346b 31}
0e25c5fd 32
d38ea511 33{
a7b5f7a1 34 my $line = __LINE__; my $str = Carp::longmess("foo");
d7687301
RS
35 is(
36 $str,
a7b5f7a1 37 "foo at $0 line $line.\n",
d7687301
RS
38 "we don't overshoot the top stack frame",
39 );
40}
41
6ca94a7e
SF
42package MyClass;
43
44sub new { return bless +{ field => ['value1', 'SecondVal'] }; }
45
46package main;
47
48{
49 my $err = Carp::longmess(MyClass->new);
50
51 # See:
52 # https://rt.cpan.org/Public/Bug/Display.html?id=107225
53 is_deeply(
54 $err->{field},
55 ['value1', 'SecondVal',],
56 "longmess returns sth meaningful in scalar context when passed a ref.",
57 );
58}
59
d7687301 60{
d38ea511 61 local $SIG{__WARN__} = sub {
879b0cab 62 like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+\.$/, 'ok 2\n';
d38ea511 63 };
22dc90ad 64
d38ea511 65 carp "ok 2\n";
ce707141
CB
66}
67
d38ea511
DR
68{
69 local $SIG{__WARN__} = sub {
879b0cab 70 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+\.$/, 'carp 3';
d38ea511 71 };
ce707141 72
d38ea511 73 carp 3;
ce707141 74}
0e25c5fd
JH
75
76sub sub_4 {
d38ea511
DR
77 local $SIG{__WARN__} = sub {
78 like $_[0],
879b0cab 79 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\.\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/,
d38ea511
DR
80 'cluck 4';
81 };
0e25c5fd 82
d38ea511 83 cluck 4;
0e25c5fd
JH
84}
85
86sub_4;
87
d38ea511
DR
88{
89 local $SIG{__DIE__} = sub {
90 like $_[0],
879b0cab 91 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\.\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/,
d38ea511
DR
92 'croak 5';
93 };
0e25c5fd 94
d38ea511 95 eval { croak 5 };
ce707141 96}
0e25c5fd
JH
97
98sub sub_6 {
ce707141 99 local $SIG{__DIE__} = sub {
d38ea511 100 like $_[0],
879b0cab 101 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+$/,
d38ea511
DR
102 'confess 6';
103 };
0e25c5fd
JH
104
105 eval { confess 6 };
106}
107
108sub_6;
109
ce707141 110ok(1);
0e25c5fd 111
976ea96e 112# test for caller_info API
ba7a4549 113my $eval = "use Carp; return Carp::caller_info(0);";
976ea96e 114my %info = eval($eval);
d38ea511 115is( $info{sub_name}, "eval '$eval'", 'caller_info API' );
b5777b26 116
ba7a4549 117# test for '...::CARP_NOT used only once' warning from Carp
b5777b26 118my $warning;
efc2495a 119eval { do {
b5777b26 120 BEGIN {
d38ea511
DR
121 local $SIG{__WARN__} = sub {
122 if ( defined $^S ) { warn $_[0] }
123 else { $warning = $_[0] }
124 }
b5777b26 125 }
d38ea511 126
22dc90ad 127 package Z;
d38ea511
DR
128
129 BEGIN {
130 eval { Carp::croak() };
131 }
efc2495a 132} };
ba7a4549 133ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
22dc90ad 134
d735c2ef 135# Test the location of error messages.
c6e3faea 136like( XA::short(), qr/^Error at XC/, "Short messages skip carped package" );
d735c2ef
BT
137
138{
c6e3faea
Z
139 local @XC::ISA = "XD";
140 like( XA::short(), qr/^Error at XB/, "Short messages skip inheritance" );
d735c2ef
BT
141}
142
143{
c6e3faea
Z
144 local @XD::ISA = "XC";
145 like( XA::short(), qr/^Error at XB/, "Short messages skip inheritance" );
d735c2ef
BT
146}
147
148{
c6e3faea
Z
149 local @XD::ISA = "XB";
150 local @XB::ISA = "XC";
151 like( XA::short(), qr/^Error at XA/, "Inheritance is transitive" );
d735c2ef
BT
152}
153
154{
c6e3faea
Z
155 local @XB::ISA = "XD";
156 local @XC::ISA = "XB";
157 like( XA::short(), qr/^Error at XA/, "Inheritance is transitive" );
d735c2ef
BT
158}
159
160{
c6e3faea
Z
161 local @XC::CARP_NOT = "XD";
162 like( XA::short(), qr/^Error at XB/, "Short messages see \@CARP_NOT" );
d735c2ef
BT
163}
164
165{
c6e3faea
Z
166 local @XD::CARP_NOT = "XC";
167 like( XA::short(), qr/^Error at XB/, "Short messages see \@CARP_NOT" );
d735c2ef
BT
168}
169
170{
c6e3faea
Z
171 local @XD::CARP_NOT = "XB";
172 local @XB::CARP_NOT = "XC";
173 like( XA::short(), qr/^Error at XA/, "\@CARP_NOT is transitive" );
d735c2ef
BT
174}
175
176{
c6e3faea
Z
177 local @XB::CARP_NOT = "XD";
178 local @XC::CARP_NOT = "XB";
179 like( XA::short(), qr/^Error at XA/, "\@CARP_NOT is transitive" );
d735c2ef
BT
180}
181
182{
c6e3faea
Z
183 local @XD::ISA = "XC";
184 local @XD::CARP_NOT = "XB";
185 like( XA::short(), qr/^Error at XC/, "\@CARP_NOT overrides inheritance" );
d735c2ef
BT
186}
187
188{
c6e3faea
Z
189 local @XD::ISA = "XB";
190 local @XD::CARP_NOT = "XC";
191 like( XA::short(), qr/^Error at XB/, "\@CARP_NOT overrides inheritance" );
d735c2ef
BT
192}
193
194# %Carp::Internal
195{
c6e3faea
Z
196 local $Carp::Internal{XC} = 1;
197 like( XA::short(), qr/^Error at XB/, "Short doesn't report Internal" );
d735c2ef
BT
198}
199
200{
c6e3faea
Z
201 local $Carp::Internal{XD} = 1;
202 like( XA::long(), qr/^Error at XC/, "Long doesn't report Internal" );
d735c2ef
BT
203}
204
205# %Carp::CarpInternal
206{
c6e3faea 207 local $Carp::CarpInternal{XD} = 1;
d38ea511 208 like(
c6e3faea 209 XA::short(), qr/^Error at XB/,
d38ea511
DR
210 "Short doesn't report calls to CarpInternal"
211 );
d735c2ef
BT
212}
213
214{
c6e3faea
Z
215 local $Carp::CarpInternal{XD} = 1;
216 like( XA::long(), qr/^Error at XC/, "Long doesn't report CarpInternal" );
d735c2ef 217}
22dc90ad
JB
218
219# tests for global variables
220sub x { carp @_ }
221sub w { cluck @_ }
222
223# $Carp::Verbose;
d38ea511
DR
224{
225 my $aref = [
879b0cab 226 qr/t at \S*(?i:carp.t) line \d+\./,
6ffbec2c 227 qr/t at \S*(?i:carp.t) line \d+\.\n\s*main::x\("t"\) called at \S*(?i:carp.t) line \d+/
22dc90ad 228 ];
ce707141 229 my $i = 0;
22dc90ad
JB
230
231 for my $re (@$aref) {
232 local $Carp::Verbose = $i++;
233 local $SIG{__WARN__} = sub {
ce707141 234 like $_[0], $re, 'Verbose';
d38ea511
DR
235 };
236
22dc90ad
JB
237 package Z;
238 main::x('t');
239 }
240}
241
242# $Carp::MaxEvalLen
d38ea511
DR
243{
244 my $test_num = 1;
245 for ( 0, 4 ) {
22dc90ad
JB
246 my $txt = "Carp::cluck($test_num)";
247 local $Carp::MaxEvalLen = $_;
248 local $SIG{__WARN__} = sub {
d38ea511
DR
249 "@_" =~ /'(.+?)(?:\n|')/s;
250 is length($1),
251 length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ),
252 'MaxEvalLen';
253 };
254 eval "$txt";
255 $test_num++;
22dc90ad
JB
256 }
257}
258
22dc90ad 259# $Carp::MaxArgNums
d38ea511 260{
22dc90ad 261 my $aref = [
bc150b6c 262 [ -1 => '(...)' ],
263 [ 0 => '(1, 2, 3, 4)' ],
264 [ '0 but true' => '(...)' ],
265 [ 1 => '(1, ...)' ],
266 [ 3 => '(1, 2, 3, ...)' ],
267 [ 4 => '(1, 2, 3, 4)' ],
268 [ 5 => '(1, 2, 3, 4)' ],
22dc90ad
JB
269 ];
270
d38ea511 271 for (@$aref) {
bc150b6c 272 my ($arg_count, $expected_signature) = @$_;
273
274 my $expected = join('',
275 '1234 at \S*(?i:carp.t) line \d+\.\n\s*main::w',
276 quotemeta $expected_signature,
277 ' called at \S*(?i:carp.t) line \d+'
278 );
279
280 local $Carp::MaxArgNums = $arg_count;
22dc90ad 281 local $SIG{__WARN__} = sub {
bc150b6c 282 like "@_", qr/$expected/, "MaxArgNums=$arg_count";
d38ea511 283 };
22dc90ad
JB
284
285 package Z;
d38ea511 286 main::w( 1 .. 4 );
22dc90ad
JB
287 }
288}
289
290# $Carp::CarpLevel
d38ea511
DR
291{
292 my $i = 0;
22dc90ad 293 my $aref = [
879b0cab
Z
294 qr/1 at \S*(?i:carp.t) line \d+\.\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
295 qr/1 at \S*(?i:carp.t) line \d+\.$/,
22dc90ad
JB
296 ];
297
298 for (@$aref) {
299 local $Carp::CarpLevel = $i++;
300 local $SIG{__WARN__} = sub {
d38ea511
DR
301 like "@_", $_, 'CarpLevel';
302 };
22dc90ad
JB
303
304 package Z;
305 main::w(1);
306 }
307}
62e1ddac 308
be109f01 309SKIP:
4b09a709 310{
be109f01 311 skip "IPC::Open3::open3 needs porting", 2 if $Is_VMS;
4b09a709
MS
312
313 # Check that croak() and confess() don't clobber $!
d38ea511
DR
314 runperl(
315 prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
316 stderr => 1
317 );
4b09a709 318
d38ea511 319 is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
4b09a709 320
d38ea511
DR
321 runperl(
322 prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
323 stderr => 1
324 );
4b09a709 325
d38ea511 326 is( $? >> 8, 42, 'confess() doesn\'t clobber $!' );
4b09a709 327}
d735c2ef 328
9cb6ed42
NC
329# undef used to be incorrectly reported as the string "undef"
330sub cluck_undef {
331
d38ea511
DR
332 local $SIG{__WARN__} = sub {
333 like $_[0],
6ffbec2c 334 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+$/,
d38ea511
DR
335 "cluck doesn't quote undef";
336 };
9cb6ed42 337
d38ea511 338 cluck "Bang!"
9cb6ed42
NC
339
340}
341
d38ea511 342cluck_undef( 0, "undef", 2, undef, 4 );
9cb6ed42 343
248ae9a5
DG
344# check that Carp respects CORE::GLOBAL::caller override after Carp
345# has been compiled
40c2103f
Z
346for my $bodge_job ( 2, 1, 0 ) { SKIP: {
347 skip "can't safely detect incomplete caller override on perl $]", 6
348 if $bodge_job && !Carp::CALLER_OVERRIDE_CHECK_OK;
d38ea511
DR
349 print '# ', ( $bodge_job ? 'Not ' : '' ),
350 "setting \@DB::args in caller override\n";
11d55ae1
PM
351 if ( $bodge_job == 1 ) {
352 require B;
353 print "# required B\n";
354 }
248ae9a5 355 my $accum = '';
a894cef1 356 local *CORE::GLOBAL::caller = sub {
d38ea511
DR
357 local *__ANON__ = "fakecaller";
358 my @c = CORE::caller(@_);
a894cef1
RGS
359 $c[0] ||= 'undef';
360 $accum .= "@c[0..3]\n";
d38ea511
DR
361 if ( !$bodge_job && CORE::caller() eq 'DB' ) {
362
eff7e72c 363 package DB;
d38ea511
DR
364 return CORE::caller( ( $_[0] || 0 ) + 1 );
365 }
366 else {
367 return CORE::caller( ( $_[0] || 0 ) + 1 );
eff7e72c 368 }
a894cef1 369 };
248ae9a5 370 eval "scalar caller()";
d38ea511
DR
371 like( $accum, qr/main::fakecaller/,
372 "test CORE::GLOBAL::caller override in eval" );
248ae9a5 373 $accum = '';
11d55ae1 374 my $got = XA::long(42);
d38ea511
DR
375 like( $accum, qr/main::fakecaller/,
376 "test CORE::GLOBAL::caller override in Carp" );
c6e3faea 377 my $package = 'XA';
bf236c8e 378 my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
d38ea511
DR
379 my $warning
380 = $bodge_job
381 ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
382 : '';
383
384 for ( 0 .. 2 ) {
385 my $previous_package = $package;
386 ++$package;
387 like( $got,
388 qr/${package}::long\($warning\) called at $previous_package line \d+/,
389 "Correct arguments for $package" );
eff7e72c 390 }
bf236c8e 391 my $arg = $bodge_job ? $warning : 42;
d38ea511 392 like(
c6e3faea
Z
393 $got, qr!XA::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
394 'Correct arguments for XA'
d38ea511 395 );
40c2103f
Z
396} }
397
398SKIP: {
399 skip "can't safely detect incomplete caller override on perl $]", 1
400 unless Carp::CALLER_OVERRIDE_CHECK_OK;
401 eval q{
402 no warnings 'redefine';
403 sub CORE::GLOBAL::caller {
404 my $height = $_[0];
405 $height++;
406 return CORE::caller($height);
407 }
408 };
bf236c8e 409
c6e3faea 410 my $got = XA::long(42);
bf236c8e 411
40c2103f
Z
412 like(
413 $got,
c6e3faea
Z
414 qr!XA::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
415 'Correct arguments for XA'
40c2103f
Z
416 );
417}
bf236c8e 418
018c7c82
FC
419# UTF8-flagged strings should not cause Carp to try to load modules (even
420# implicitly via utf8_heavy.pl) after a syntax error [perl #82854].
be109f01
CB
421SKIP:
422{
423 skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS;
424 like(
425 runperl(
426 prog => q<
427 use utf8; use strict; use Carp;
428 BEGIN { $SIG{__DIE__} = sub { Carp::croak qq(aaaaa$_[0]) } }
429 $c
430 >,
431 stderr=>1,
432 ),
433 qr/aaaaa/,
434 'Carp can handle UTF8-flagged strings after a syntax error',
435 );
436}
018c7c82 437
ca80cbdc 438# [perl #96672]
c6e3faea 439<XD::DATA> for 1..2;
ca80cbdc
FC
440eval { croak 'heek' };
441$@ =~ s/\n.*//; # just check first line
879b0cab 442is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n",
ca80cbdc
FC
443 'last handle line num is mentioned';
444
2f7a15bf
AC
445# [cpan #100183]
446{
447 local $/ = \6;
448 <XD::DATA>;
449 eval { croak 'jeek' };
450 $@ =~ s/\n.*//; # just check first line
451 is $@, "jeek at ".__FILE__." line ".(__LINE__-2).", <DATA> chunk 3.\n",
452 'last handle chunk num is mentioned';
453}
454
be109f01
CB
455SKIP:
456{
457 skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS;
458 like(
459 runperl(
460 prog => q<
461 open FH, q-Makefile.PL-;
462 <FH>; # set PL_last_in_gv
463 BEGIN { *CORE::GLOBAL::die = sub { die Carp::longmess(@_) } };
464 use Carp;
465 die fumpts;
466 >,
467 ),
468 qr 'fumpts',
469 'Carp::longmess works inside CORE::GLOBAL::die',
470 );
471}
ca80cbdc 472
1a4f8f41
BF
473{
474 package Foo::No::CARP_NOT;
475 eval { Carp::croak(1) };
476 ::is_deeply(
477 [ keys %Foo::No::CARP_NOT:: ],
478 [],
479 "Carp doesn't create CARP_NOT or ISA in the caller if they don't exist"
480 );
79f8d0e8
BF
481
482 package Foo::No::Autovivify;
483 $CARP_NOT = 1;
484 eval { Carp::croak(1) };
485 ::ok(
486 !defined *{$Foo::No::Autovivify::{CARP_NOT}}{ARRAY},
487 "Carp doesn't autovivify the CARP_NOT or ISA arrays if the globs exists but they lack the ARRAY slot"
488 );
1a4f8f41
BF
489}
490
bf236c8e
NC
491# New tests go here
492
c6e3faea
Z
493# line 1 "XA"
494package XA;
d38ea511 495
d735c2ef 496sub short {
c6e3faea 497 XB::short();
d735c2ef
BT
498}
499
500sub long {
c6e3faea 501 XB::long();
d735c2ef
BT
502}
503
c6e3faea
Z
504# line 1 "XB"
505package XB;
d38ea511 506
d735c2ef 507sub short {
c6e3faea 508 XC::short();
d735c2ef
BT
509}
510
511sub long {
c6e3faea 512 XC::long();
d735c2ef
BT
513}
514
c6e3faea
Z
515# line 1 "XC"
516package XC;
d38ea511 517
d735c2ef 518sub short {
c6e3faea 519 XD::short();
d735c2ef
BT
520}
521
522sub long {
c6e3faea 523 XD::long();
d735c2ef
BT
524}
525
c6e3faea
Z
526# line 1 "XD"
527package XD;
d38ea511 528
d735c2ef 529sub short {
d38ea511 530 eval { Carp::croak("Error") };
d735c2ef
BT
531 return $@;
532}
533
534sub long {
d38ea511 535 eval { Carp::confess("Error") };
d735c2ef
BT
536 return $@;
537}
bf236c8e
NC
538
539# Put new tests at "new tests go here"
ca80cbdc
FC
540__DATA__
5411
5422
5433
2f7a15bf 544abcdefghijklmnopqrstuvwxyz