lib/Carp.t

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