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