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