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 => 21;
  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::Heavy; 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::Heavy
  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::Heavy/;
  74
  75
  76 # tests for global variables
  77 sub x { carp @_ }
  78 sub w { cluck @_ }
  79
  80 # $Carp::Verbose;
  81 {   my $aref = [
  82         qr/t at \S*(?i:carp.t) line \d+/,
  83         qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
  84     ];
  85     my $i = 0;
  86
  87     for my $re (@$aref) {
  88         local $Carp::Verbose = $i++;
  89         local $SIG{__WARN__} = sub {
  90             like $_[0], $re, 'Verbose';
  91         };
  92         package Z;
  93         main::x('t');
  94     }
  95 }
  96
  97 # $Carp::MaxEvalLen
  98 {   my $test_num = 1;
  99     for(0,4) {
 100         my $txt = "Carp::cluck($test_num)";
 101         local $Carp::MaxEvalLen = $_;
 102         local $SIG{__WARN__} = sub {
 103             "@_"=~/'(.+?)(?:\n|')/s;
 104             is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
 105         };
 106         eval "$txt"; $test_num++;
 107     }
 108 }
 109
 110 # $Carp::MaxArgLen
 111 {
 112     for(0,4) {
 113         my $arg = 'testtest';
 114         local $Carp::MaxArgLen = $_;
 115         local $SIG{__WARN__} = sub {
 116             "@_"=~/'(.+?)'/;
 117             is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
 118         };
 119
 120         package Z;
 121         main::w($arg);
 122     }
 123 }
 124
 125 # $Carp::MaxArgNums
 126 {   my $i = 0;
 127     my $aref = [
 128         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+/,
 129         qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/,
 130     ];
 131
 132     for(@$aref) {
 133         local $Carp::MaxArgNums = $i++;
 134         local $SIG{__WARN__} = sub {
 135             like "@_", $_, 'MaxArgNums';
 136         };
 137
 138         package Z;
 139         main::w(1..4);
 140     }
 141 }
 142
 143 # $Carp::CarpLevel
 144 {   my $i = 0;
 145     my $aref = [
 146         qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
 147         qr/1 at \S*(?i:carp.t) line \d+$/,
 148     ];
 149
 150     for (@$aref) {
 151         local $Carp::CarpLevel = $i++;
 152         local $SIG{__WARN__} = sub {
 153             like "@_", $_, 'CarpLevel';
 154         };
 155
 156         package Z;
 157         main::w(1);
 158     }
 159 }
 160
 161
 162 {
 163     local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
 164
 165     # Check that croak() and confess() don't clobber $!
 166     runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
 167             stderr => 1);
 168
 169     is($?>>8, 42, 'croak() doesn\'t clobber $!');
 170
 171     runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
 172             stderr => 1);
 173
 174     is($?>>8, 42, 'confess() doesn\'t clobber $!');
 175 }