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 => 62;
   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 { do {
  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( XA::short(), qr/^Error at XC/, "Short messages skip carped package" );
 116
 117 {
 118     local @XC::ISA = "XD";
 119     like( XA::short(), qr/^Error at XB/, "Short messages skip inheritance" );
 120 }
 121
 122 {
 123     local @XD::ISA = "XC";
 124     like( XA::short(), qr/^Error at XB/, "Short messages skip inheritance" );
 125 }
 126
 127 {
 128     local @XD::ISA = "XB";
 129     local @XB::ISA = "XC";
 130     like( XA::short(), qr/^Error at XA/, "Inheritance is transitive" );
 131 }
 132
 133 {
 134     local @XB::ISA = "XD";
 135     local @XC::ISA = "XB";
 136     like( XA::short(), qr/^Error at XA/, "Inheritance is transitive" );
 137 }
 138
 139 {
 140     local @XC::CARP_NOT = "XD";
 141     like( XA::short(), qr/^Error at XB/, "Short messages see \@CARP_NOT" );
 142 }
 143
 144 {
 145     local @XD::CARP_NOT = "XC";
 146     like( XA::short(), qr/^Error at XB/, "Short messages see \@CARP_NOT" );
 147 }
 148
 149 {
 150     local @XD::CARP_NOT = "XB";
 151     local @XB::CARP_NOT = "XC";
 152     like( XA::short(), qr/^Error at XA/, "\@CARP_NOT is transitive" );
 153 }
 154
 155 {
 156     local @XB::CARP_NOT = "XD";
 157     local @XC::CARP_NOT = "XB";
 158     like( XA::short(), qr/^Error at XA/, "\@CARP_NOT is transitive" );
 159 }
 160
 161 {
 162     local @XD::ISA      = "XC";
 163     local @XD::CARP_NOT = "XB";
 164     like( XA::short(), qr/^Error at XC/, "\@CARP_NOT overrides inheritance" );
 165 }
 166
 167 {
 168     local @XD::ISA      = "XB";
 169     local @XD::CARP_NOT = "XC";
 170     like( XA::short(), qr/^Error at XB/, "\@CARP_NOT overrides inheritance" );
 171 }
 172
 173 # %Carp::Internal
 174 {
 175     local $Carp::Internal{XC} = 1;
 176     like( XA::short(), qr/^Error at XB/, "Short doesn't report Internal" );
 177 }
 178
 179 {
 180     local $Carp::Internal{XD} = 1;
 181     like( XA::long(), qr/^Error at XC/, "Long doesn't report Internal" );
 182 }
 183
 184 # %Carp::CarpInternal
 185 {
 186     local $Carp::CarpInternal{XD} = 1;
 187     like(
 188         XA::short(), qr/^Error at XB/,
 189         "Short doesn't report calls to CarpInternal"
 190     );
 191 }
 192
 193 {
 194     local $Carp::CarpInternal{XD} = 1;
 195     like( XA::long(), qr/^Error at XC/, "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 = XA::long(42);
 359     like( $accum, qr/main::fakecaller/,
 360         "test CORE::GLOBAL::caller override in Carp" );
 361     my $package = 'XA';
 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!XA::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
 378         'Correct arguments for XA'
 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 = XA::long(42);
 395
 396     like(
 397         $got,
 398         qr!XA::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 XA'
 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 # [perl #96672]
 423 <XD::DATA> for 1..2;
 424 eval { croak 'heek' };
 425 $@ =~ s/\n.*//; # just check first line
 426 is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n",
 427     'last handle line num is mentioned';
 428
 429 SKIP:
 430 {
 431     skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS;
 432     like(
 433       runperl(
 434         prog => q<
 435           open FH, q-Makefile.PL-;
 436           <FH>;  # set PL_last_in_gv
 437           BEGIN { *CORE::GLOBAL::die = sub { die Carp::longmess(@_) } };
 438           use Carp;
 439           die fumpts;
 440         >,
 441       ),
 442       qr 'fumpts',
 443       'Carp::longmess works inside CORE::GLOBAL::die',
 444     );
 445 }
 446
 447 {
 448     package Foo::No::CARP_NOT;
 449     eval { Carp::croak(1) };
 450     ::is_deeply(
 451         [ keys %Foo::No::CARP_NOT:: ],
 452         [],
 453         "Carp doesn't create CARP_NOT or ISA in the caller if they don't exist"
 454     );
 455
 456     package Foo::No::Autovivify;
 457     $CARP_NOT = 1;
 458     eval { Carp::croak(1) };
 459     ::ok(
 460         !defined *{$Foo::No::Autovivify::{CARP_NOT}}{ARRAY},
 461         "Carp doesn't autovivify the CARP_NOT or ISA arrays if the globs exists but they lack the ARRAY slot"
 462     );
 463 }
 464
 465 # New tests go here
 466
 467 # line 1 "XA"
 468 package XA;
 469
 470 sub short {
 471     XB::short();
 472 }
 473
 474 sub long {
 475     XB::long();
 476 }
 477
 478 # line 1 "XB"
 479 package XB;
 480
 481 sub short {
 482     XC::short();
 483 }
 484
 485 sub long {
 486     XC::long();
 487 }
 488
 489 # line 1 "XC"
 490 package XC;
 491
 492 sub short {
 493     XD::short();
 494 }
 495
 496 sub long {
 497     XD::long();
 498 }
 499
 500 # line 1 "XD"
 501 package XD;
 502
 503 sub short {
 504     eval { Carp::croak("Error") };
 505     return $@;
 506 }
 507
 508 sub long {
 509     eval { Carp::confess("Error") };
 510     return $@;
 511 }
 512
 513 # Put new tests at "new tests go here"
 514 __DATA__
 515 1
 516 2
 517 3