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