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