This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f7c226a29082286913aa87bb0040601118d3575e
[perl5.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 => 61;
7
8 sub 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
19 my $Is_VMS = $^O eq 'VMS';
20
21 use Carp qw(carp cluck croak confess);
22
23 BEGIN {
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";
28 }
29
30 {
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 {
40     local $SIG{__WARN__} = sub {
41         like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+\.$/, 'ok 2\n';
42     };
43
44     carp "ok 2\n";
45 }
46
47 {
48     local $SIG{__WARN__} = sub {
49         like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+\.$/, 'carp 3';
50     };
51
52     carp 3;
53 }
54
55 sub sub_4 {
56     local $SIG{__WARN__} = sub {
57         like $_[0],
58             qr/^(\d+) at.+\b(?i:carp\.t) line \d+\.\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/,
59             'cluck 4';
60     };
61
62     cluck 4;
63 }
64
65 sub_4;
66
67 {
68     local $SIG{__DIE__} = sub {
69         like $_[0],
70             qr/^(\d+) at.+\b(?i:carp\.t) line \d+\.\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/,
71             'croak 5';
72     };
73
74     eval { croak 5 };
75 }
76
77 sub sub_6 {
78     local $SIG{__DIE__} = sub {
79         like $_[0],
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+$/,
81             'confess 6';
82     };
83
84     eval { confess 6 };
85 }
86
87 sub_6;
88
89 ok(1);
90
91 # test for caller_info API
92 my $eval = "use Carp; return Carp::caller_info(0);";
93 my %info = eval($eval);
94 is( $info{sub_name}, "eval '$eval'", 'caller_info API' );
95
96 # test for '...::CARP_NOT used only once' warning from Carp
97 my $warning;
98 eval {
99     BEGIN {
100         local $SIG{__WARN__} = sub {
101             if   ( defined $^S ) { warn $_[0] }
102             else                 { $warning = $_[0] }
103             }
104     }
105
106     package Z;
107
108     BEGIN {
109         eval { Carp::croak() };
110     }
111 };
112 ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
113
114 # Test the location of error messages.
115 like( A::short(), qr/^Error at C/, "Short messages skip carped package" );
116
117 {
118     local @C::ISA = "D";
119     like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
120 }
121
122 {
123     local @D::ISA = "C";
124     like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
125 }
126
127 {
128     local @D::ISA = "B";
129     local @B::ISA = "C";
130     like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
131 }
132
133 {
134     local @B::ISA = "D";
135     local @C::ISA = "B";
136     like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
137 }
138
139 {
140     local @C::CARP_NOT = "D";
141     like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
142 }
143
144 {
145     local @D::CARP_NOT = "C";
146     like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
147 }
148
149 {
150     local @D::CARP_NOT = "B";
151     local @B::CARP_NOT = "C";
152     like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
153 }
154
155 {
156     local @B::CARP_NOT = "D";
157     local @C::CARP_NOT = "B";
158     like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
159 }
160
161 {
162     local @D::ISA      = "C";
163     local @D::CARP_NOT = "B";
164     like( A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance" );
165 }
166
167 {
168     local @D::ISA      = "B";
169     local @D::CARP_NOT = "C";
170     like( A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance" );
171 }
172
173 # %Carp::Internal
174 {
175     local $Carp::Internal{C} = 1;
176     like( A::short(), qr/^Error at B/, "Short doesn't report Internal" );
177 }
178
179 {
180     local $Carp::Internal{D} = 1;
181     like( A::long(), qr/^Error at C/, "Long doesn't report Internal" );
182 }
183
184 # %Carp::CarpInternal
185 {
186     local $Carp::CarpInternal{D} = 1;
187     like(
188         A::short(), qr/^Error at B/,
189         "Short doesn't report calls to CarpInternal"
190     );
191 }
192
193 {
194     local $Carp::CarpInternal{D} = 1;
195     like( A::long(), qr/^Error at C/, "Long doesn't report CarpInternal" );
196 }
197
198 # tests for global variables
199 sub x { carp @_ }
200 sub w { cluck @_ }
201
202 # $Carp::Verbose;
203 {
204     my $aref = [
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+/
207     ];
208     my $i = 0;
209
210     for my $re (@$aref) {
211         local $Carp::Verbose = $i++;
212         local $SIG{__WARN__} = sub {
213             like $_[0], $re, 'Verbose';
214         };
215
216         package Z;
217         main::x('t');
218     }
219 }
220
221 # $Carp::MaxEvalLen
222 {
223     my $test_num = 1;
224     for ( 0, 4 ) {
225         my $txt = "Carp::cluck($test_num)";
226         local $Carp::MaxEvalLen = $_;
227         local $SIG{__WARN__} = sub {
228             "@_" =~ /'(.+?)(?:\n|')/s;
229             is length($1),
230                 length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ),
231                 'MaxEvalLen';
232         };
233         eval "$txt";
234         $test_num++;
235     }
236 }
237
238 # $Carp::MaxArgLen
239 {
240     for ( 0, 4 ) {
241         my $arg = 'testtest';
242         local $Carp::MaxArgLen = $_;
243         local $SIG{__WARN__} = sub {
244             "@_" =~ /'(.+?)'/;
245             is length($1),
246                 length( $_ ? substr( $arg, 0, $_ ) : substr( $arg, 0 ) ),
247                 'MaxArgLen';
248         };
249
250         package Z;
251         main::w($arg);
252     }
253 }
254
255 # $Carp::MaxArgNums
256 {
257     my $i    = 0;
258     my $aref = [
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+/,
261     ];
262
263     for (@$aref) {
264         local $Carp::MaxArgNums = $i++;
265         local $SIG{__WARN__} = sub {
266             like "@_", $_, 'MaxArgNums';
267         };
268
269         package Z;
270         main::w( 1 .. 4 );
271     }
272 }
273
274 # $Carp::CarpLevel
275 {
276     my $i    = 0;
277     my $aref = [
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+\.$/,
280     ];
281
282     for (@$aref) {
283         local $Carp::CarpLevel = $i++;
284         local $SIG{__WARN__} = sub {
285             like "@_", $_, 'CarpLevel';
286         };
287
288         package Z;
289         main::w(1);
290     }
291 }
292
293 SKIP:
294 {
295     skip "IPC::Open3::open3 needs porting", 2 if $Is_VMS;
296
297     # Check that croak() and confess() don't clobber $!
298     runperl(
299         prog   => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
300         stderr => 1
301     );
302
303     is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
304
305     runperl(
306         prog   => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
307         stderr => 1
308     );
309
310     is( $? >> 8, 42, 'confess() doesn\'t clobber $!' );
311 }
312
313 # undef used to be incorrectly reported as the string "undef"
314 sub cluck_undef {
315
316     local $SIG{__WARN__} = sub {
317         like $_[0],
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+$/,
319             "cluck doesn't quote undef";
320     };
321
322     cluck "Bang!"
323
324 }
325
326 cluck_undef( 0, "undef", 2, undef, 4 );
327
328 # check that Carp respects CORE::GLOBAL::caller override after Carp
329 # has been compiled
330 for 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;
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";
338     }
339     my $accum = '';
340     local *CORE::GLOBAL::caller = sub {
341         local *__ANON__ = "fakecaller";
342         my @c = CORE::caller(@_);
343         $c[0] ||= 'undef';
344         $accum .= "@c[0..3]\n";
345         if ( !$bodge_job && CORE::caller() eq 'DB' ) {
346
347             package DB;
348             return CORE::caller( ( $_[0] || 0 ) + 1 );
349         }
350         else {
351             return CORE::caller( ( $_[0] || 0 ) + 1 );
352         }
353     };
354     eval "scalar caller()";
355     like( $accum, qr/main::fakecaller/,
356         "test CORE::GLOBAL::caller override in eval" );
357     $accum = '';
358     my $got = A::long(42);
359     like( $accum, qr/main::fakecaller/,
360         "test CORE::GLOBAL::caller override in Carp" );
361     my $package = 'A';
362     my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
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" );
374     }
375     my $arg = $bodge_job ? $warning : 42;
376     like(
377         $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
378         'Correct arguments for A'
379     );
380 } }
381
382 SKIP: {
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     };
393
394     my $got = A::long(42);
395
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 }
402
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].
405 SKIP:
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 }
421
422 SKIP:
423 {
424     skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS;
425     skip("B:: always created when static", 1)
426       if $Config{static_ext} =~ /\bB\b/;
427     is(
428       runperl(
429         prog => q<
430           use Carp;
431           $SIG{__WARN__} = sub{};
432           carp (qq(A duck, but which duck?));
433           print q(ok) unless exists $::{q(B::)};
434         >,
435       ),
436       'ok',
437       'Carp does not autovivify *B::',
438     );
439 }
440
441 # [perl #96672]
442 <D::DATA> for 1..2;
443 eval { croak 'heek' };
444 $@ =~ s/\n.*//; # just check first line
445 is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n",
446     'last handle line num is mentioned';
447
448 SKIP:
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 }
465
466 # New tests go here
467
468 # line 1 "A"
469 package A;
470
471 sub short {
472     B::short();
473 }
474
475 sub long {
476     B::long();
477 }
478
479 # line 1 "B"
480 package B;
481
482 sub short {
483     C::short();
484 }
485
486 sub long {
487     C::long();
488 }
489
490 # line 1 "C"
491 package C;
492
493 sub short {
494     D::short();
495 }
496
497 sub long {
498     D::long();
499 }
500
501 # line 1 "D"
502 package D;
503
504 sub short {
505     eval { Carp::croak("Error") };
506     return $@;
507 }
508
509 sub long {
510     eval { Carp::confess("Error") };
511     return $@;
512 }
513
514 # Put new tests at "new tests go here"
515 __DATA__
516 1
517 2
518 3