lib/Carp.t

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