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