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