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