This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
move Carp to ext/Carp, preparing for dual-lifing
[perl5.git] / ext / Carp / t / Carp.t
CommitLineData
a894cef1
RGS
1use warnings;
2no warnings "once";
0fd3c67a 3use Config;
a894cef1 4
476b2fe1
Z
5use IPC::Open3 1.0104 qw(open3);
6use Test::More tests => 58;
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 {
32 like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n';
33 };
22dc90ad 34
d38ea511 35 carp "ok 2\n";
ce707141
CB
36}
37
d38ea511
DR
38{
39 local $SIG{__WARN__} = sub {
40 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3';
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],
49 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/,
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],
61 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/,
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
DR
70 like $_[0],
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+$/,
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 = [
ce707141
CB
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 = [
ce707141
CB
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 = [
ce707141
CB
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
4b09a709
MS
284{
285 local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
286
287 # Check that croak() and confess() don't clobber $!
d38ea511
DR
288 runperl(
289 prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
290 stderr => 1
291 );
4b09a709 292
d38ea511 293 is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
4b09a709 294
d38ea511
DR
295 runperl(
296 prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
297 stderr => 1
298 );
4b09a709 299
d38ea511 300 is( $? >> 8, 42, 'confess() doesn\'t clobber $!' );
4b09a709 301}
d735c2ef 302
9cb6ed42
NC
303# undef used to be incorrectly reported as the string "undef"
304sub cluck_undef {
305
d38ea511
DR
306 local $SIG{__WARN__} = sub {
307 like $_[0],
308 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+$/,
309 "cluck doesn't quote undef";
310 };
9cb6ed42 311
d38ea511 312 cluck "Bang!"
9cb6ed42
NC
313
314}
315
d38ea511 316cluck_undef( 0, "undef", 2, undef, 4 );
9cb6ed42 317
248ae9a5
DG
318# check that Carp respects CORE::GLOBAL::caller override after Carp
319# has been compiled
d38ea511
DR
320for my $bodge_job ( 2, 1, 0 ) {
321 print '# ', ( $bodge_job ? 'Not ' : '' ),
322 "setting \@DB::args in caller override\n";
323 if ( $bodge_job == 1 ) {
324 require B;
325 print "# required B\n";
bf236c8e 326 }
248ae9a5 327 my $accum = '';
a894cef1 328 local *CORE::GLOBAL::caller = sub {
d38ea511
DR
329 local *__ANON__ = "fakecaller";
330 my @c = CORE::caller(@_);
a894cef1
RGS
331 $c[0] ||= 'undef';
332 $accum .= "@c[0..3]\n";
d38ea511
DR
333 if ( !$bodge_job && CORE::caller() eq 'DB' ) {
334
eff7e72c 335 package DB;
d38ea511
DR
336 return CORE::caller( ( $_[0] || 0 ) + 1 );
337 }
338 else {
339 return CORE::caller( ( $_[0] || 0 ) + 1 );
eff7e72c 340 }
a894cef1 341 };
248ae9a5 342 eval "scalar caller()";
d38ea511
DR
343 like( $accum, qr/main::fakecaller/,
344 "test CORE::GLOBAL::caller override in eval" );
248ae9a5 345 $accum = '';
eff7e72c 346 my $got = A::long(42);
d38ea511
DR
347 like( $accum, qr/main::fakecaller/,
348 "test CORE::GLOBAL::caller override in Carp" );
eff7e72c 349 my $package = 'A';
bf236c8e 350 my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
d38ea511
DR
351 my $warning
352 = $bodge_job
353 ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
354 : '';
355
356 for ( 0 .. 2 ) {
357 my $previous_package = $package;
358 ++$package;
359 like( $got,
360 qr/${package}::long\($warning\) called at $previous_package line \d+/,
361 "Correct arguments for $package" );
eff7e72c 362 }
bf236c8e 363 my $arg = $bodge_job ? $warning : 42;
d38ea511
DR
364 like(
365 $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
366 'Correct arguments for A'
367 );
248ae9a5
DG
368}
369
bf236c8e
NC
370eval <<'EOT';
371no warnings 'redefine';
372sub CORE::GLOBAL::caller {
373 my $height = $_[0];
374 $height++;
375 return CORE::caller($height);
376}
377EOT
378
379my $got = A::long(42);
380
d38ea511
DR
381like(
382 $got,
383 qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
384 'Correct arguments for A'
385);
bf236c8e 386
018c7c82
FC
387# UTF8-flagged strings should not cause Carp to try to load modules (even
388# implicitly via utf8_heavy.pl) after a syntax error [perl #82854].
476b2fe1
Z
389like(
390 runperl(
391 prog => q<
392 use utf8; use strict; use Carp;
393 BEGIN { $SIG{__DIE__} = sub { Carp::croak "aaaaa$_[0]" } }
394 $c
395 >,
396 stderr=>1,
397 ),
398 qr/aaaaa/,
399 'Carp can handle UTF8-flagged strings after a syntax error',
018c7c82
FC
400);
401
0fd3c67a
TC
402SKIP:
403{
404 skip("B:: always created when static", 1)
405 if $Config{static_ext} =~ /\bB\b/;
476b2fe1
Z
406 is(
407 runperl(
408 prog => q<
409 use Carp;
410 $SIG{__WARN__} = sub{};
411 carp ("A duck, but which duck?");
412 print "ok" unless exists $::{"B::"};
413 >,
414 ),
415 'ok',
416 'Carp does not autovivify *B::',
0fd3c67a 417 );
476b2fe1 418}
1a6d5308 419
bf236c8e
NC
420# New tests go here
421
d735c2ef
BT
422# line 1 "A"
423package A;
d38ea511 424
d735c2ef
BT
425sub short {
426 B::short();
427}
428
429sub long {
430 B::long();
431}
432
433# line 1 "B"
434package B;
d38ea511 435
d735c2ef
BT
436sub short {
437 C::short();
438}
439
440sub long {
441 C::long();
442}
443
444# line 1 "C"
445package C;
d38ea511 446
d735c2ef
BT
447sub short {
448 D::short();
449}
450
451sub long {
452 D::long();
453}
454
455# line 1 "D"
456package D;
d38ea511 457
d735c2ef 458sub short {
d38ea511 459 eval { Carp::croak("Error") };
d735c2ef
BT
460 return $@;
461}
462
463sub long {
d38ea511 464 eval { Carp::confess("Error") };
d735c2ef
BT
465 return $@;
466}
bf236c8e
NC
467
468# Put new tests at "new tests go here"
469__END__