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