File Coverage

blib/lib/Carp/Clan.pm
Criterion Covered Total %
statement 99 127 78.0
branch 33 64 51.6
condition 7 18 38.9
subroutine 15 15 100.0
pod 0 4 0.0
total 154 228 67.5


line stmt bran cond sub pod time code
1              
2             ##
3             ## Based on Carp.pm from Perl 5.005_03.
4             ## Last modified 12-Jun-2001 by Steffen Beyer.
5             ## Should be reasonably backwards compatible.
6             ##
7             ## This module is free software and can
8             ## be used, modified and redistributed
9             ## under the same terms as Perl itself.
10             ##
11              
12             @DB::args = (); # Avoid warning "used only once" in Perl 5.003
13              
14             package Carp::Clan;
15              
16 2     2   54 use strict;
  2         20  
  2         34  
17 2     2   63 use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
  2         19  
  2         31  
18 2     2   60 use overload ();
  2         20  
  2         18  
19              
20             # Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
21              
22             # The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
23             # the eval text and function arguments should be formatted when printed.
24              
25             $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
26             $MaxArgLen  = 64; # How much of each argument to print. 0 = all.
27             $MaxArgNums = 8; # How many arguments to print. 0 = all.
28              
29             $Verbose = 0; # If true then make _shortmsg call _longmsg instead.
30              
31             $VERSION = '5.8';
32              
33             # _longmsg() crawls all the way up the stack reporting on all the function
34             # calls made. The error string, $error, is originally constructed from the
35             # arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
36             # This gets appended with the stack trace messages which are generated for
37             # each function call on the stack.
38              
39             sub _longmsg {
40 26 50   26   374     return (@_) if ( ref $_[0] );
41 26         214     local $_; # Protect surrounding program - just in case...
42 26         221     my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
43 26         277     my $error = join( '', @_ );
44 26         211     my $msg = '';
45 26         207     my $i = 0;
46 26         209     while (
47                     do {
48                         {
49              
50 236         1952                 package DB;
51 236         4582                 ( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
52                                 = caller( $i++ )
53                         }
54                     }
55                     )
56                 {
57 210 100       2308         next if ( $pack eq 'Carp::Clan' );
58 184 100       1854         if ( $error eq '' ) {
59 158 50       1536             if ( defined $eval ) {
    100          
60 0 0       0                 $eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
61                             $eval
62 0         0                     =~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  0         0  
63 0 0 0     0                 substr( $eval, $MaxEvalLen ) = '...'
64                                 if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
65 0 0       0                 if ($require) { $sub = "require $eval"; }
  0         0  
66 0         0                 else { $sub = "eval '$eval'"; }
67                         }
68 26         213             elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
69                         else {
70 132         3883                 @parms = ();
71 132 50       1406                 if ($hargs) {
72 132         1067                     $push = 0;
73 132         1252                     @parms = @DB::args
74                                     ; # We may trash some of the args so we take a copy
75 132 50 33     4760                     if ( $MaxArgNums and @parms > $MaxArgNums ) {
76 0         0                         $#parms = $MaxArgNums;
77 0         0                         pop(@parms);
78 0         0                         $push = 1;
79                                 }
80 132         3614                     for (@parms) {
81 264 50       5195                         if ( defined $_ ) {
82 264 50       2797                             if ( ref $_ ) {
83 0         0                                 $_ = overload::StrVal($_);
84                                         }
85                                         else {
86 264 50       2935                                 unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
87                                                 ) # Looks numeric
88                                             {
89 264         3670                                     s/([\\\'])/\\$1/g; # Escape \ and '
90 264         2594                                     s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  0         0  
91 264 50 33     3306                                     substr( $_, $MaxArgLen ) = '...'
92                                                     if ( $MaxArgLen
93                                                     and length($_) > $MaxArgLen );
94 264         3361                                     $_ = "'$_'";
95                                             }
96                                         }
97                                     }
98 0         0                         else { $_ = 'undef'; }
99                                 }
100 132 50       1429                     push( @parms, '...' ) if ($push);
101                             }
102 132         1986                 $sub .= '(' . join( ', ', @parms ) . ')';
103                         }
104 158 50       1601             if ( $msg eq '' ) { $msg = "$sub called"; }
  0         0  
105 158         1454             else { $msg .= "\t$sub called"; }
106                     }
107                     else {
108 26 50       278             if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
  26         274  
109 0         0             else { $msg = "$sub: $error"; }
110                     }
111 184 50       2895         $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
112 184         1707         $error = '';
113                 }
114 26   33     240     $msg ||= $error;
115 26         334     $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
116 26         302     $msg;
117             }
118              
119             # _shortmsg() is called by carp() and croak() to skip all the way up to
120             # the top-level caller's package and report the error from there. confess()
121             # and cluck() generate a full stack trace so they call _longmsg() to
122             # generate that. In verbose mode _shortmsg() calls _longmsg() so you
123             # always get a stack trace.
124              
125             sub _shortmsg {
126 22     22   197     my $pattern = shift;
127 22         184     my $verbose = shift;
128 22 50       213     return (@_) if ( ref $_[0] );
129 22 50 33     286     goto &_longmsg if ( $Verbose or $verbose );
130 22         289     my ( $pack, $file, $line, $sub );
131 22         225     my $error = join( '', @_ );
132 22         180     my $msg = '';
133 22         204     my $i = 0;
134 22         636     while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
135 116 100 100     5153         next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
136 18 50       230         if ( $error eq '' ) { $msg = "$sub() called"; }
  0 50       0  
137 18         181         elsif ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
138 0         0         else { $msg = "$sub: $error"; }
139 18 50       205         $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
140 18         211         $msg =~ tr/\0//d
141                         ; # Circumvent die's incorrect handling of NUL characters
142 18         178         return $msg;
143                 }
144 4         54     goto &_longmsg;
145             }
146              
147             # The following four functions call _longmsg() or _shortmsg() depending on
148             # whether they should generate a full stack trace (confess() and cluck())
149             # or simply report the caller's package (croak() and carp()), respectively.
150             # confess() and croak() die, carp() and cluck() warn.
151              
152             # Following code kept for calls with fully qualified subroutine names:
153             # (For backward compatibility with the original Carp.pm)
154              
155             sub croak {
156 1     1 0 35     my $callpkg = caller(0);
157 1 50       12     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
158 1         11     die _shortmsg( $pattern, 0, @_ );
159             }
160 1     1 0 28 sub confess { die _longmsg(@_); }
161              
162             sub carp {
163 1     1 0 39     my $callpkg = caller(0);
164 1 50       12     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
165 1         11     warn _shortmsg( $pattern, 0, @_ );
166             }
167 1     1 0 37 sub cluck { warn _longmsg(@_); }
168              
169             # The following method imports a different closure for every caller.
170             # I.e., different modules can use this module at the same time
171             # and in parallel and still use different patterns.
172              
173             sub import {
174 11     11   973     my $pkg = shift;
175 11         113     my $callpkg = caller(0);
176 11 100       130     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
177 11         96     my $verbose = 0;
178 11         86     my $item;
179 11         89     my $file;
180              
181 11         106     for $item (@_) {
182 9 50       112         if ( $item =~ /^\d/ ) {
    50          
183 0 0       0             if ( $VERSION < $item ) {
184 0         0                 $file = "$pkg.pm";
185 0         0                 $file =~ s!::!/!g;
186 0         0                 $file = $INC{$file};
187 0         0                 die _shortmsg( '^:::', 0,
188                                 "$pkg $item required--this is only version $VERSION ($file)"
189                             );
190                         }
191                     }
192 0         0         elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
193 9         95         else { $pattern = $item; }
194                 }
195              
196             # Speed up pattern matching in Perl versions >= 5.005:
197             # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
198 11 50       119     if ( $] >= 5.005 ) {
199 11         790         eval '$pattern = qr/$pattern/;';
200                 }
201                 else {
202 0         0         eval { $pkg =~ /$pattern/; };
  0         0  
203                 }
204 11 50       176     if ($@) {
205 0         0         $@ =~ s/\s+$//;
206 0         0         $@ =~ s/\s+at\s.+$//;
207 0         0         die _shortmsg( '^:::', 0, $@ );
208                 }
209                 {
210 11         96         local ($^W) = 0;
  11         197  
211 2     2   52         no strict "refs";
  2         54  
  2         63  
212 11         207         *{"${callpkg}::croak"}
213 11     10   162             = sub { die _shortmsg( $pattern, $verbose, @_ ); };
  10         370  
214 11     10   103         *{"${callpkg}::confess"} = sub { die _longmsg(@_); };
  11         119  
  10         575  
215 11         251         *{"${callpkg}::carp"}
216 11     10   211             = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
  10         958  
217 11     10   141         *{"${callpkg}::cluck"} = sub { warn _longmsg(@_); };
  11         204  
  10         2613  
218                 }
219             }
220              
221             1;
222              
223