1package Carp; 2 3use strict; 4use warnings; 5 6our $VERSION = '1.20'; 7$VERSION = eval $VERSION; 8 9our $MaxEvalLen = 0; 10our $Verbose = 0; 11our $CarpLevel = 0; 12our $MaxArgLen = 64; # How much of each argument to print. 0 = all. 13our $MaxArgNums = 8; # How many arguments to print. 0 = all. 14 15require Exporter; 16our @ISA = ('Exporter'); 17our @EXPORT = qw(confess croak carp); 18our @EXPORT_OK = qw(cluck verbose longmess shortmess); 19our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode 20 21# The members of %Internal are packages that are internal to perl. 22# Carp will not report errors from within these packages if it 23# can. The members of %CarpInternal are internal to Perl's warning 24# system. Carp will not report errors from within these packages 25# either, and will not report calls *to* these packages for carp and 26# croak. They replace $CarpLevel, which is deprecated. The 27# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval 28# text and function arguments should be formatted when printed. 29 30our %CarpInternal; 31our %Internal; 32 33# disable these by default, so they can live w/o require Carp 34$CarpInternal{Carp}++; 35$CarpInternal{warnings}++; 36$Internal{Exporter}++; 37$Internal{'Exporter::Heavy'}++; 38 39# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") 40# then the following method will be called by the Exporter which knows 41# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word 42# 'verbose'. 43 44sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } 45 46sub _cgc { 47 no strict 'refs'; 48 return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; 49 return; 50} 51 52sub longmess { 53 # Icky backwards compatibility wrapper. :-( 54 # 55 # The story is that the original implementation hard-coded the 56 # number of call levels to go back, so calls to longmess were off 57 # by one. Other code began calling longmess and expecting this 58 # behaviour, so the replacement has to emulate that behaviour. 59 my $cgc = _cgc(); 60 my $call_pack = $cgc ? $cgc->() : caller(); 61 if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { 62 return longmess_heavy(@_); 63 } 64 else { 65 local $CarpLevel = $CarpLevel + 1; 66 return longmess_heavy(@_); 67 } 68} 69 70our @CARP_NOT; 71 72sub shortmess { 73 my $cgc = _cgc(); 74 75 # Icky backwards compatibility wrapper. :-( 76 local @CARP_NOT = $cgc ? $cgc->() : caller(); 77 shortmess_heavy(@_); 78} 79 80sub croak { die shortmess @_ } 81sub confess { die longmess @_ } 82sub carp { warn shortmess @_ } 83sub cluck { warn longmess @_ } 84 85sub caller_info { 86 my $i = shift(@_) + 1; 87 my %call_info; 88 my $cgc = _cgc(); 89 { 90 package DB; 91 @DB::args = \$i; # A sentinel, which no-one else has the address of 92 @call_info{ 93 qw(pack file line sub has_args wantarray evaltext is_require) } 94 = $cgc ? $cgc->($i) : caller($i); 95 } 96 97 unless ( defined $call_info{pack} ) { 98 return (); 99 } 100 101 my $sub_name = Carp::get_subname( \%call_info ); 102 if ( $call_info{has_args} ) { 103 my @args; 104 if ( @DB::args == 1 105 && ref $DB::args[0] eq ref \$i 106 && $DB::args[0] == \$i ) { 107 @DB::args = (); # Don't let anyone see the address of $i 108 local $@; 109 my $where = eval { 110 my $func = $cgc or return ''; 111 my $gv = B::svref_2object($func)->GV; 112 my $package = $gv->STASH->NAME; 113 my $subname = $gv->NAME; 114 return unless defined $package && defined $subname; 115 116 # returning CORE::GLOBAL::caller isn't useful for tracing the cause: 117 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; 118 " in &${package}::$subname"; 119 }; 120 $where = defined($where) ? $where : ''; 121 @args 122 = "** Incomplete caller override detected$where; \@DB::args were not set **"; 123 } 124 else { 125 ## @args = map { Carp::format_arg($_) } @DB::args; 126 for my $db_arg (@DB::args) { push @args, Carp::format_arg($db_arg) }; 127 } 128 if ( $MaxArgNums and @args > $MaxArgNums ) 129 { # More than we want to show? 130 $#args = $MaxArgNums; 131 push @args, '...'; 132 } 133 134 # Push the args onto the subroutine 135 $sub_name .= '(' . join( ', ', @args ) . ')'; 136 } 137 $call_info{sub_name} = $sub_name; 138 return wantarray() ? %call_info : \%call_info; 139} 140 141# Transform an argument to a function into a string. 142sub format_arg { 143 my $arg = shift; 144 if ( ref($arg) ) { 145 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; 146 } 147 if ( defined($arg) ) { 148 $arg =~ s/'/\\'/g; 149 $arg = str_len_trim( $arg, $MaxArgLen ); 150 151 # Quote it? 152 $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/; 153 } # 0-9, not \d, as \d will try to 154 else { # load Unicode tables 155 $arg = 'undef'; 156 } 157 158 # The following handling of "control chars" is direct from 159 # the original code - it is broken on Unicode though. 160 # Suggestions? 161 utf8::is_utf8($arg) 162 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; 163 return $arg; 164} 165 166# Takes an inheritance cache and a package and returns 167# an anon hash of known inheritances and anon array of 168# inheritances which consequences have not been figured 169# for. 170sub get_status { 171 my $cache = shift; 172 my $pkg = shift; 173 $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; 174 return @{ $cache->{$pkg} }; 175} 176 177# Takes the info from caller() and figures out the name of 178# the sub/require/eval 179sub get_subname { 180 my $info = shift; 181 if ( defined( $info->{evaltext} ) ) { 182 my $eval = $info->{evaltext}; 183 if ( $info->{is_require} ) { 184 return "require $eval"; 185 } 186 else { 187 $eval =~ s/([\\\'])/\\$1/g; 188 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; 189 } 190 } 191 192 return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; 193} 194 195# Figures out what call (from the point of view of the caller) 196# the long error backtrace should start at. 197sub long_error_loc { 198 my $i; 199 my $lvl = $CarpLevel; 200 { 201 ++$i; 202 my $cgc = _cgc(); 203 my $pkg = $cgc ? $cgc->($i) : caller($i); 204 unless ( defined($pkg) ) { 205 206 # This *shouldn't* happen. 207 if (%Internal) { 208 local %Internal; 209 $i = long_error_loc(); 210 last; 211 } 212 else { 213 214 # OK, now I am irritated. 215 return 2; 216 } 217 } 218 redo if $CarpInternal{$pkg}; 219 redo unless 0 > --$lvl; 220 redo if $Internal{$pkg}; 221 } 222 return $i - 1; 223} 224 225sub longmess_heavy { 226 return @_ if ref( $_[0] ); # don't break references as exceptions 227 my $i = long_error_loc(); 228 return ret_backtrace( $i, @_ ); 229} 230 231# Returns a full stack backtrace starting from where it is 232# told. 233sub ret_backtrace { 234 my ( $i, @error ) = @_; 235 my $mess; 236 my $err = join '', @error; 237 $i++; 238 239 my $tid_msg = ''; 240 if ( defined &threads::tid ) { 241 my $tid = threads->tid; 242 $tid_msg = " thread $tid" if $tid; 243 } 244 245 my %i = caller_info($i); 246 $mess = "$err at $i{file} line $i{line}$tid_msg\n"; 247 248 while ( my %i = caller_info( ++$i ) ) { 249 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; 250 } 251 252 return $mess; 253} 254 255sub ret_summary { 256 my ( $i, @error ) = @_; 257 my $err = join '', @error; 258 $i++; 259 260 my $tid_msg = ''; 261 if ( defined &threads::tid ) { 262 my $tid = threads->tid; 263 $tid_msg = " thread $tid" if $tid; 264 } 265 266 my %i = caller_info($i); 267 return "$err at $i{file} line $i{line}$tid_msg\n"; 268} 269 270sub short_error_loc { 271 # You have to create your (hash)ref out here, rather than defaulting it 272 # inside trusts *on a lexical*, as you want it to persist across calls. 273 # (You can default it on $_[2], but that gets messy) 274 my $cache = {}; 275 my $i = 1; 276 my $lvl = $CarpLevel; 277 { 278 my $cgc = _cgc(); 279 my $called = $cgc ? $cgc->($i) : caller($i); 280 $i++; 281 my $caller = $cgc ? $cgc->($i) : caller($i); 282 283 return 0 unless defined($caller); # What happened? 284 redo if $Internal{$caller}; 285 redo if $CarpInternal{$caller}; 286 redo if $CarpInternal{$called}; 287 redo if trusts( $called, $caller, $cache ); 288 redo if trusts( $caller, $called, $cache ); 289 redo unless 0 > --$lvl; 290 } 291 return $i - 1; 292} 293 294sub shortmess_heavy { 295 return longmess_heavy(@_) if $Verbose; 296 return @_ if ref( $_[0] ); # don't break references as exceptions 297 my $i = short_error_loc(); 298 if ($i) { 299 ret_summary( $i, @_ ); 300 } 301 else { 302 longmess_heavy(@_); 303 } 304} 305 306# If a string is too long, trims it with ... 307sub str_len_trim { 308 my $str = shift; 309 my $max = shift || 0; 310 if ( 2 < $max and $max < length($str) ) { 311 substr( $str, $max - 3 ) = '...'; 312 } 313 return $str; 314} 315 316# Takes two packages and an optional cache. Says whether the 317# first inherits from the second. 318# 319# Recursive versions of this have to work to avoid certain 320# possible endless loops, and when following long chains of 321# inheritance are less efficient. 322sub trusts { 323 my $child = shift; 324 my $parent = shift; 325 my $cache = shift; 326 my ( $known, $partial ) = get_status( $cache, $child ); 327 328 # Figure out consequences until we have an answer 329 while ( @$partial and not exists $known->{$parent} ) { 330 my $anc = shift @$partial; 331 next if exists $known->{$anc}; 332 $known->{$anc}++; 333 my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); 334 my @found = keys %$anc_knows; 335 @$known{@found} = (); 336 push @$partial, @$anc_partial; 337 } 338 return exists $known->{$parent}; 339} 340 341# Takes a package and gives a list of those trusted directly 342sub trusts_directly { 343 my $class = shift; 344 no strict 'refs'; 345 no warnings 'once'; 346 return @{"$class\::CARP_NOT"} 347 ? @{"$class\::CARP_NOT"} 348 : @{"$class\::ISA"}; 349} 350 3511; 352 353__END__ 354 355=head1 NAME 356 357Carp - alternative warn and die for modules 358 359=head1 SYNOPSIS 360 361 use Carp; 362 363 # warn user (from perspective of caller) 364 carp "string trimmed to 80 chars"; 365 366 # die of errors (from perspective of caller) 367 croak "We're outta here!"; 368 369 # die of errors with stack backtrace 370 confess "not implemented"; 371 372 # cluck not exported by default 373 use Carp qw(cluck); 374 cluck "This is how we got here!"; 375 376=head1 DESCRIPTION 377 378The Carp routines are useful in your own modules because 379they act like die() or warn(), but with a message which is more 380likely to be useful to a user of your module. In the case of 381cluck, confess, and longmess that context is a summary of every 382call in the call-stack. For a shorter message you can use C<carp> 383or C<croak> which report the error as being from where your module 384was called. There is no guarantee that that is where the error 385was, but it is a good educated guess. 386 387You can also alter the way the output and logic of C<Carp> works, by 388changing some global variables in the C<Carp> namespace. See the 389section on C<GLOBAL VARIABLES> below. 390 391Here is a more complete description of how C<carp> and C<croak> work. 392What they do is search the call-stack for a function call stack where 393they have not been told that there shouldn't be an error. If every 394call is marked safe, they give up and give a full stack backtrace 395instead. In other words they presume that the first likely looking 396potential suspect is guilty. Their rules for telling whether 397a call shouldn't generate errors work as follows: 398 399=over 4 400 401=item 1. 402 403Any call from a package to itself is safe. 404 405=item 2. 406 407Packages claim that there won't be errors on calls to or from 408packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or 409(if that array is empty) C<@ISA>. The ability to override what 410@ISA says is new in 5.8. 411 412=item 3. 413 414The trust in item 2 is transitive. If A trusts B, and B 415trusts C, then A trusts C. So if you do not override C<@ISA> 416with C<@CARP_NOT>, then this trust relationship is identical to, 417"inherits from". 418 419=item 4. 420 421Any call from an internal Perl module is safe. (Nothing keeps 422user modules from marking themselves as internal to Perl, but 423this practice is discouraged.) 424 425=item 5. 426 427Any call to Perl's warning system (eg Carp itself) is safe. 428(This rule is what keeps it from reporting the error at the 429point where you call C<carp> or C<croak>.) 430 431=item 6. 432 433C<$Carp::CarpLevel> can be set to skip a fixed number of additional 434call levels. Using this is not recommended because it is very 435difficult to get it to behave correctly. 436 437=back 438 439=head2 Forcing a Stack Trace 440 441As a debugging aid, you can force Carp to treat a croak as a confess 442and a carp as a cluck across I<all> modules. In other words, force a 443detailed stack trace to be given. This can be very helpful when trying 444to understand why, or from where, a warning or error is being generated. 445 446This feature is enabled by 'importing' the non-existent symbol 447'verbose'. You would typically enable it by saying 448 449 perl -MCarp=verbose script.pl 450 451or by including the string C<-MCarp=verbose> in the PERL5OPT 452environment variable. 453 454Alternately, you can set the global variable C<$Carp::Verbose> to true. 455See the C<GLOBAL VARIABLES> section below. 456 457=head1 GLOBAL VARIABLES 458 459=head2 $Carp::MaxEvalLen 460 461This variable determines how many characters of a string-eval are to 462be shown in the output. Use a value of C<0> to show all text. 463 464Defaults to C<0>. 465 466=head2 $Carp::MaxArgLen 467 468This variable determines how many characters of each argument to a 469function to print. Use a value of C<0> to show the full length of the 470argument. 471 472Defaults to C<64>. 473 474=head2 $Carp::MaxArgNums 475 476This variable determines how many arguments to each function to show. 477Use a value of C<0> to show all arguments to a function call. 478 479Defaults to C<8>. 480 481=head2 $Carp::Verbose 482 483This variable makes C<carp> and C<croak> generate stack backtraces 484just like C<cluck> and C<confess>. This is how C<use Carp 'verbose'> 485is implemented internally. 486 487Defaults to C<0>. 488 489=head2 @CARP_NOT 490 491This variable, I<in your package>, says which packages are I<not> to be 492considered as the location of an error. The C<carp()> and C<cluck()> 493functions will skip over callers when reporting where an error occurred. 494 495NB: This variable must be in the package's symbol table, thus: 496 497 # These work 498 our @CARP_NOT; # file scope 499 use vars qw(@CARP_NOT); # package scope 500 @My::Package::CARP_NOT = ... ; # explicit package variable 501 502 # These don't work 503 sub xyz { ... @CARP_NOT = ... } # w/o declarations above 504 my @CARP_NOT; # even at top-level 505 506Example of use: 507 508 package My::Carping::Package; 509 use Carp; 510 our @CARP_NOT; 511 sub bar { .... or _error('Wrong input') } 512 sub _error { 513 # temporary control of where'ness, __PACKAGE__ is implicit 514 local @CARP_NOT = qw(My::Friendly::Caller); 515 carp(@_) 516 } 517 518This would make C<Carp> report the error as coming from a caller not 519in C<My::Carping::Package>, nor from C<My::Friendly::Caller>. 520 521Also read the L</DESCRIPTION> section above, about how C<Carp> decides 522where the error is reported from. 523 524Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>. 525 526Overrides C<Carp>'s use of C<@ISA>. 527 528=head2 %Carp::Internal 529 530This says what packages are internal to Perl. C<Carp> will never 531report an error as being from a line in a package that is internal to 532Perl. For example: 533 534 $Carp::Internal{ (__PACKAGE__) }++; 535 # time passes... 536 sub foo { ... or confess("whatever") }; 537 538would give a full stack backtrace starting from the first caller 539outside of __PACKAGE__. (Unless that package was also internal to 540Perl.) 541 542=head2 %Carp::CarpInternal 543 544This says which packages are internal to Perl's warning system. For 545generating a full stack backtrace this is the same as being internal 546to Perl, the stack backtrace will not start inside packages that are 547listed in C<%Carp::CarpInternal>. But it is slightly different for 548the summary message generated by C<carp> or C<croak>. There errors 549will not be reported on any lines that are calling packages in 550C<%Carp::CarpInternal>. 551 552For example C<Carp> itself is listed in C<%Carp::CarpInternal>. 553Therefore the full stack backtrace from C<confess> will not start 554inside of C<Carp>, and the short message from calling C<croak> is 555not placed on the line where C<croak> was called. 556 557=head2 $Carp::CarpLevel 558 559This variable determines how many additional call frames are to be 560skipped that would not otherwise be when reporting where an error 561occurred on a call to one of C<Carp>'s functions. It is fairly easy 562to count these call frames on calls that generate a full stack 563backtrace. However it is much harder to do this accounting for calls 564that generate a short message. Usually people skip too many call 565frames. If they are lucky they skip enough that C<Carp> goes all of 566the way through the call stack, realizes that something is wrong, and 567then generates a full stack backtrace. If they are unlucky then the 568error is reported from somewhere misleading very high in the call 569stack. 570 571Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use 572C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>. 573 574Defaults to C<0>. 575 576=head1 BUGS 577 578The Carp routines don't handle exception objects currently. 579If called with a first argument that is a reference, they simply 580call die() or warn(), as appropriate. 581 582