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