1: package Carp;
2:
3: { use 5.006; }
4: use strict;
5: use warnings;
6: BEGIN {
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21: if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
22: ${^WARNING_BITS} = "";
23: } else {
24: "warnings"->unimport("utf8");
25: }
26: }
27:
28: sub _fetch_sub {
29: my($pack, $sub) = @_;
30: $pack .= '::';
31:
32: return unless exists($::{$pack});
33: for ($::{$pack}) {
34: return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
35: for ($$_{$sub}) {
36: return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37: }
38: }
39: }
40:
41:
42:
43:
44:
45:
46:
47:
48:
49: BEGIN {
50: if("$]" < 5.013011) {
51: *UTF8_REGEXP_PROBLEM = sub () { 1 };
52: } else {
53: *UTF8_REGEXP_PROBLEM = sub () { 0 };
54: }
55: }
56:
57:
58:
59:
60:
61: BEGIN {
62: if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
63: *is_utf8 = $sub;
64: } else {
65:
66: *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
67: }
68: }
69:
70:
71:
72:
73: BEGIN {
74: if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
75: *downgrade = \&{"utf8::downgrade"};
76: } else {
77: *downgrade = sub {
78: my $r = "";
79: my $l = length($_[0]);
80: for(my $i = 0; $i != $l; $i++) {
81: my $o = ord(substr($_[0], $i, 1));
82: return if $o > 255;
83: $r .= chr($o);
84: }
85: $_[0] = $r;
86: };
87: }
88: }
89:
90:
91:
92:
93:
94:
95: BEGIN {
96: *is_safe_printable_codepoint =
97: "$]" >= 5.007_003 ?
98: eval(q(sub ($) {
99: my $u = utf8::native_to_unicode($_[0]);
100: $u >= 0x20 && $u <= 0x7e;
101: }))
102: : ord("A") == 65 ?
103: sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e }
104: :
105: sub ($) {
106:
107:
108:
109:
110:
111:
112:
113: $_[0] >= ord(" ") && $_[0] <= 0xff &&
114: $_[0] != (ord ("^") == 106 ? 0x5f : 0xff);
115: }
116: ;
117: }
118:
119: sub _univ_mod_loaded {
120: return 0 unless exists($::{"UNIVERSAL::"});
121: for ($::{"UNIVERSAL::"}) {
122: return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"};
123: for ($$_{"$_[0]::"}) {
124: return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"};
125: for ($$_{"VERSION"}) {
126: return 0 unless ref \$_ eq "GLOB";
127: return ${*$_{SCALAR}};
128: }
129: }
130: }
131: }
132:
133:
134:
135:
136: my $isa;
137: BEGIN {
138: if (_univ_mod_loaded('isa')) {
139: *_maybe_isa = sub { 1 }
140: }
141: else {
142:
143:
144: *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa");
145: }
146: }
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169: BEGIN {
170: if (eval { require "overloading.pm" }) {
171: *_StrVal = eval 'sub { no overloading; "$_[0]" }'
172: }
173: else {
174:
175:
176:
177:
178: *_mycan = _univ_mod_loaded('can')
179: ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
180: : \&UNIVERSAL::can;
181:
182:
183:
184: *_blessed = $isa
185: ? sub { &$isa($_[0], "UNIVERSAL") }
186: : sub {
187: my $probe = "UNIVERSAL::Carp_probe_" . rand;
188: no strict 'refs';
189: local *$probe = sub { "unlikely string" };
190: local $@;
191: local $SIG{__DIE__} = sub{};
192: (eval { $_[0]->$probe } || '') eq 'unlikely string'
193: };
194:
195: *_StrVal = sub {
196: my $pack = ref $_[0];
197:
198:
199:
200:
201: return "$_[0]" unless _mycan($pack, "()");
202:
203:
204: return "$_[0]" if not _blessed($_[0]);
205: bless $_[0], "Carp";
206: my $str = "$_[0]";
207: bless $_[0], $pack;
208: $pack . substr $str, index $str, "=";
209: }
210: }
211: }
212:
213:
214: our $VERSION = '1.50';
215: $VERSION =~ tr/_//d;
216:
217: our $MaxEvalLen = 0;
218: our $Verbose = 0;
219: our $CarpLevel = 0;
220: our $MaxArgLen = 64;
221: our $MaxArgNums = 8;
222: our $RefArgFormatter = undef;
223:
224: require Exporter;
225: our @ISA = ('Exporter');
226: our @EXPORT = qw(confess croak carp);
227: our @EXPORT_OK = qw(cluck verbose longmess shortmess);
228: our @EXPORT_FAIL = qw(verbose);
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239: our %CarpInternal;
240: our %Internal;
241:
242:
243: $CarpInternal{Carp}++;
244: $CarpInternal{warnings}++;
245: $Internal{Exporter}++;
246: $Internal{'Exporter::Heavy'}++;
247:
248:
249:
250:
251:
252:
253: sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
254:
255: sub _cgc {
256: no strict 'refs';
257: return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
258: return;
259: }
260:
261: sub longmess {
262: local($!, $^E);
263:
264:
265:
266:
267:
268:
269: my $cgc = _cgc();
270: my $call_pack = $cgc ? $cgc->() : caller();
271: if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
272: return longmess_heavy(@_);
273: }
274: else {
275: local $CarpLevel = $CarpLevel + 1;
276: return longmess_heavy(@_);
277: }
278: }
279:
280: our @CARP_NOT;
281:
282: sub shortmess {
283: local($!, $^E);
284: my $cgc = _cgc();
285:
286:
287: local @CARP_NOT = $cgc ? $cgc->() : caller();
288: shortmess_heavy(@_);
289: }
290:
291: sub croak { die shortmess @_ }
292: sub confess { die longmess @_ }
293: sub carp { warn shortmess @_ }
294: sub cluck { warn longmess @_ }
295:
296: BEGIN {
297: if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
298: ("$]" >= 5.012005 && "$]" < 5.013)) {
299: *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
300: } else {
301: *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
302: }
303: }
304:
305: sub caller_info {
306: my $i = shift(@_) + 1;
307: my %call_info;
308: my $cgc = _cgc();
309: {
310:
311:
312:
313:
314:
315:
316:
317: @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
318: package DB;
319: @call_info{
320: qw(pack file line sub has_args wantarray evaltext is_require) }
321: = $cgc ? $cgc->($i) : caller($i);
322: }
323:
324: unless ( defined $call_info{file} ) {
325: return ();
326: }
327:
328: my $sub_name = Carp::get_subname( \%call_info );
329: if ( $call_info{has_args} ) {
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342: my @args = map {
343: my $arg;
344: local $@= $@;
345: eval {
346: $arg = $_;
347: 1;
348: } or do {
349: $arg = '** argument not available anymore **';
350: };
351: $arg;
352: } @DB::args;
353: if (CALLER_OVERRIDE_CHECK_OK && @args == 1
354: && ref $args[0] eq ref \$i
355: && $args[0] == \$i ) {
356: @args = ();
357: local $@;
358: my $where = eval {
359: my $func = $cgc or return '';
360: my $gv =
361: (_fetch_sub B => 'svref_2object' or return '')
362: ->($func)->GV;
363: my $package = $gv->STASH->NAME;
364: my $subname = $gv->NAME;
365: return unless defined $package && defined $subname;
366:
367:
368: return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
369: " in &${package}::$subname";
370: } || '';
371: @args
372: = "** Incomplete caller override detected$where; \@DB::args were not set **";
373: }
374: else {
375: my $overflow;
376: if ( $MaxArgNums and @args > $MaxArgNums )
377: {
378: $#args = $MaxArgNums - 1;
379: $overflow = 1;
380: }
381:
382: @args = map { Carp::format_arg($_) } @args;
383:
384: if ($overflow) {
385: push @args, '...';
386: }
387: }
388:
389:
390: $sub_name .= '(' . join( ', ', @args ) . ')';
391: }
392: $call_info{sub_name} = $sub_name;
393: return wantarray() ? %call_info : \%call_info;
394: }
395:
396:
397: our $in_recurse;
398: sub format_arg {
399: my $arg = shift;
400:
401: if ( my $pack= ref($arg) ) {
402:
403:
404: if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) &&
405: do {
406: local $@;
407: local $in_recurse = 1;
408: local $SIG{__DIE__} = sub{};
409: eval {$arg->can('CARP_TRACE') }
410: })
411: {
412: return $arg->CARP_TRACE();
413: }
414: elsif (!$in_recurse &&
415: defined($RefArgFormatter) &&
416: do {
417: local $@;
418: local $in_recurse = 1;
419: local $SIG{__DIE__} = sub{};
420: eval {$arg = $RefArgFormatter->($arg); 1}
421: })
422: {
423: return $arg;
424: }
425: else
426: {
427:
428:
429:
430:
431: return _StrVal $arg;
432: }
433: }
434: return "undef" if !defined($arg);
435: downgrade($arg, 1);
436: return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
437: $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
438: my $suffix = "";
439: if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
440: substr ( $arg, $MaxArgLen - 3 ) = "";
441: $suffix = "...";
442: }
443: if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
444: for(my $i = length($arg); $i--; ) {
445: my $c = substr($arg, $i, 1);
446: my $x = substr($arg, 0, 0);
447: if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
448: substr $arg, $i, 0, "\\";
449: next;
450: }
451: my $o = ord($c);
452: substr $arg, $i, 1, sprintf("\\x{%x}", $o)
453: unless is_safe_printable_codepoint($o);
454: }
455: } else {
456: $arg =~ s/([\"\\\$\@])/\\$1/g;
457:
458:
459:
460: $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
461: }
462: downgrade($arg, 1);
463: return "\"".$arg."\"".$suffix;
464: }
465:
466: sub Regexp::CARP_TRACE {
467: my $arg = "$_[0]";
468: downgrade($arg, 1);
469: if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
470: for(my $i = length($arg); $i--; ) {
471: my $o = ord(substr($arg, $i, 1));
472: my $x = substr($arg, 0, 0);
473: substr $arg, $i, 1, sprintf("\\x{%x}", $o)
474: unless is_safe_printable_codepoint($o);
475: }
476: } else {
477:
478: $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
479: }
480: downgrade($arg, 1);
481: my $suffix = "";
482: if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
483: ($suffix, $arg) = ($1, $2);
484: }
485: if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
486: substr ( $arg, $MaxArgLen - 3 ) = "";
487: $suffix = "...".$suffix;
488: }
489: return "qr($arg)$suffix";
490: }
491:
492:
493:
494:
495:
496: sub get_status {
497: my $cache = shift;
498: my $pkg = shift;
499: $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
500: return @{ $cache->{$pkg} };
501: }
502:
503:
504:
505: sub get_subname {
506: my $info = shift;
507: if ( defined( $info->{evaltext} ) ) {
508: my $eval = $info->{evaltext};
509: if ( $info->{is_require} ) {
510: return "require $eval";
511: }
512: else {
513: $eval =~ s/([\\\'])/\\$1/g;
514: return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
515: }
516: }
517:
518:
519:
520: if ( !defined( $info->{sub} ) ) {
521: return '__ANON__::__ANON__';
522: }
523:
524: return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
525: }
526:
527:
528:
529: sub long_error_loc {
530: my $i;
531: my $lvl = $CarpLevel;
532: {
533: ++$i;
534: my $cgc = _cgc();
535: my @caller = $cgc ? $cgc->($i) : caller($i);
536: my $pkg = $caller[0];
537: unless ( defined($pkg) ) {
538:
539:
540: if (%Internal) {
541: local %Internal;
542: $i = long_error_loc();
543: last;
544: }
545: elsif (defined $caller[2]) {
546:
547:
548:
549:
550:
551:
552: redo unless 0 > --$lvl;
553: last;
554: }
555: else {
556: return 2;
557: }
558: }
559: redo if $CarpInternal{$pkg};
560: redo unless 0 > --$lvl;
561: redo if $Internal{$pkg};
562: }
563: return $i - 1;
564: }
565:
566: sub longmess_heavy {
567: if ( ref( $_[0] ) ) {
568: return wantarray ? @_ : $_[0];
569: }
570: my $i = long_error_loc();
571: return ret_backtrace( $i, @_ );
572: }
573:
574: BEGIN {
575: if("$]" >= 5.017004) {
576:
577: $Carp::{LAST_FH} = \eval '\${^LAST_FH}';
578: } else {
579: eval '*LAST_FH = sub () { 0 }';
580: }
581: }
582:
583:
584:
585: sub ret_backtrace {
586: my ( $i, @error ) = @_;
587: my $mess;
588: my $err = join '', @error;
589: $i++;
590:
591: my $tid_msg = '';
592: if ( defined &threads::tid ) {
593: my $tid = threads->tid;
594: $tid_msg = " thread $tid" if $tid;
595: }
596:
597: my %i = caller_info($i);
598: $mess = "$err at $i{file} line $i{line}$tid_msg";
599: if( $. ) {
600:
601: if (LAST_FH) {
602: if (${+LAST_FH}) {
603: $mess .= sprintf ", <%s> %s %d",
604: *${+LAST_FH}{NAME},
605: ($/ eq "\n" ? "line" : "chunk"), $.
606: }
607: }
608: else {
609: local $@ = '';
610: local $SIG{__DIE__};
611: eval {
612: CORE::die;
613: };
614: if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
615: $mess .= $1;
616: }
617: }
618: }
619: $mess .= "\.\n";
620:
621: while ( my %i = caller_info( ++$i ) ) {
622: $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
623: }
624:
625: return $mess;
626: }
627:
628: sub ret_summary {
629: my ( $i, @error ) = @_;
630: my $err = join '', @error;
631: $i++;
632:
633: my $tid_msg = '';
634: if ( defined &threads::tid ) {
635: my $tid = threads->tid;
636: $tid_msg = " thread $tid" if $tid;
637: }
638:
639: my %i = caller_info($i);
640: return "$err at $i{file} line $i{line}$tid_msg\.\n";
641: }
642:
643: sub short_error_loc {
644:
645:
646:
647: my $cache = {};
648: my $i = 1;
649: my $lvl = $CarpLevel;
650: {
651: my $cgc = _cgc();
652: my $called = $cgc ? $cgc->($i) : caller($i);
653: $i++;
654: my $caller = $cgc ? $cgc->($i) : caller($i);
655:
656: if (!defined($caller)) {
657: my @caller = $cgc ? $cgc->($i) : caller($i);
658: if (@caller) {
659:
660:
661:
662: redo if defined($called) && $CarpInternal{$called};
663: redo unless 0 > --$lvl;
664: last;
665: }
666: else {
667: return 0;
668: }
669: }
670: redo if $Internal{$caller};
671: redo if $CarpInternal{$caller};
672: redo if $CarpInternal{$called};
673: redo if trusts( $called, $caller, $cache );
674: redo if trusts( $caller, $called, $cache );
675: redo unless 0 > --$lvl;
676: }
677: return $i - 1;
678: }
679:
680: sub shortmess_heavy {
681: return longmess_heavy(@_) if $Verbose;
682: return @_ if ref( $_[0] );
683: my $i = short_error_loc();
684: if ($i) {
685: ret_summary( $i, @_ );
686: }
687: else {
688: longmess_heavy(@_);
689: }
690: }
691:
692:
693: sub str_len_trim {
694: my $str = shift;
695: my $max = shift || 0;
696: if ( 2 < $max and $max < length($str) ) {
697: substr( $str, $max - 3 ) = '...';
698: }
699: return $str;
700: }
701:
702:
703:
704:
705:
706:
707:
708: sub trusts {
709: my $child = shift;
710: my $parent = shift;
711: my $cache = shift;
712: my ( $known, $partial ) = get_status( $cache, $child );
713:
714:
715: while ( @$partial and not exists $known->{$parent} ) {
716: my $anc = shift @$partial;
717: next if exists $known->{$anc};
718: $known->{$anc}++;
719: my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
720: my @found = keys %$anc_knows;
721: @$known{@found} = ();
722: push @$partial, @$anc_partial;
723: }
724: return exists $known->{$parent};
725: }
726:
727:
728: sub trusts_directly {
729: my $class = shift;
730: no strict 'refs';
731: my $stash = \%{"$class\::"};
732: for my $var (qw/ CARP_NOT ISA /) {
733:
734:
735: if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
736: && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
737: return @{$stash->{$var}}
738: }
739: }
740: return;
741: }
742:
743: if(!defined($warnings::VERSION) ||
744: do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
745:
746:
747:
748:
749:
750:
751: no strict "refs";
752: *{"warnings::$_"} = \&$_ foreach @EXPORT;
753: }
754:
755: 1;
756:
757: __END__
758:
759: =head1 NAME
760:
761: Carp - alternative warn and die for modules
762:
763: =head1 SYNOPSIS
764:
765: use Carp;
766:
767: # warn user (from perspective of caller)
768: carp "string trimmed to 80 chars";
769:
770: # die of errors (from perspective of caller)
771: croak "We're outta here!";
772:
773: # die of errors with stack backtrace
774: confess "not implemented";
775:
776: # cluck, longmess and shortmess not exported by default
777: use Carp qw(cluck longmess shortmess);
778: cluck "This is how we got here!"; # warn with stack backtrace
779: $long_message = longmess( "message from cluck() or confess()" );
780: $short_message = shortmess( "message from carp() or croak()" );
781:
782: =head1 DESCRIPTION
783:
784: The Carp routines are useful in your own modules because
785: they act like C<die()> or C<warn()>, but with a message which is more
786: likely to be useful to a user of your module. In the case of
787: C<cluck()> and C<confess()>, that context is a summary of every
788: call in the call-stack; C<longmess()> returns the contents of the error
789: message.
790:
791: For a shorter message you can use C<carp()> or C<croak()> which report the
792: error as being from where your module was called. C<shortmess()> returns the
793: contents of this error message. There is no guarantee that that is where the
794: error was, but it is a good educated guess.
795:
796: C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
797: in the course of assembling its error messages. This means that a
798: C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
799: information held in those variables, if it is required to augment the
800: error message, and if the code calling C<Carp> left useful values there.
801: Of course, C<Carp> can't guarantee the latter.
802:
803: You can also alter the way the output and logic of C<Carp> works, by
804: changing some global variables in the C<Carp> namespace. See the
805: section on C<GLOBAL VARIABLES> below.
806:
807: Here is a more complete description of how C<carp> and C<croak> work.
808: What they do is search the call-stack for a function call stack where
809: they have not been told that there shouldn't be an error. If every
810: call is marked safe, they give up and give a full stack backtrace
811: instead. In other words they presume that the first likely looking
812: potential suspect is guilty. Their rules for telling whether
813: a call shouldn't generate errors work as follows:
814:
815: =over 4
816:
817: =item 1.
818:
819: Any call from a package to itself is safe.
820:
821: =item 2.
822:
823: Packages claim that there won't be errors on calls to or from
824: packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
825: (if that array is empty) C<@ISA>. The ability to override what
826: @ISA says is new in 5.8.
827:
828: =item 3.
829:
830: The trust in item 2 is transitive. If A trusts B, and B
831: trusts C, then A trusts C. So if you do not override C<@ISA>
832: with C<@CARP_NOT>, then this trust relationship is identical to,
833: "inherits from".
834:
835: =item 4.
836:
837: Any call from an internal Perl module is safe. (Nothing keeps
838: user modules from marking themselves as internal to Perl, but
839: this practice is discouraged.)
840:
841: =item 5.
842:
843: Any call to Perl's warning system (eg Carp itself) is safe.
844: (This rule is what keeps it from reporting the error at the
845: point where you call C<carp> or C<croak>.)
846:
847: =item 6.
848:
849: C<$Carp::CarpLevel> can be set to skip a fixed number of additional
850: call levels. Using this is not recommended because it is very
851: difficult to get it to behave correctly.
852:
853: =back
854:
855: =head2 Forcing a Stack Trace
856:
857: As a debugging aid, you can force Carp to treat a croak as a confess
858: and a carp as a cluck across I<all> modules. In other words, force a
859: detailed stack trace to be given. This can be very helpful when trying
860: to understand why, or from where, a warning or error is being generated.
861:
862: This feature is enabled by 'importing' the non-existent symbol
863: 'verbose'. You would typically enable it by saying
864:
865: perl -MCarp=verbose script.pl
866:
867: or by including the string C<-MCarp=verbose> in the PERL5OPT
868: environment variable.
869:
870: Alternately, you can set the global variable C<$Carp::Verbose> to true.
871: See the C<GLOBAL VARIABLES> section below.
872:
873: =head2 Stack Trace formatting
874:
875: At each stack level, the subroutine's name is displayed along with
876: its parameters. For simple scalars, this is sufficient. For complex
877: data types, such as objects and other references, this can simply
878: display C<'HASH(0x1ab36d8)'>.
879:
880: Carp gives two ways to control this.
881:
882: =over 4
883:
884: =item 1.
885:
886: For objects, a method, C<CARP_TRACE>, will be called, if it exists. If
887: this method doesn't exist, or it recurses into C<Carp>, or it otherwise
888: throws an exception, this is skipped, and Carp moves on to the next option,
889: otherwise checking stops and the string returned is used. It is recommended
890: that the object's type is part of the string to make debugging easier.
891:
892: =item 2.
893:
894: For any type of reference, C<$Carp::RefArgFormatter> is checked (see below).
895: This variable is expected to be a code reference, and the current parameter
896: is passed in. If this function doesn't exist (the variable is undef), or
897: it recurses into C<Carp>, or it otherwise throws an exception, this is
898: skipped, and Carp moves on to the next option, otherwise checking stops
899: and the string returned is used.
900:
901: =item 3.
902:
903: Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
904: available, stringify the value ignoring any overloading.
905:
906: =back
907:
908: =head1 GLOBAL VARIABLES
909:
910: =head2 $Carp::MaxEvalLen
911:
912: This variable determines how many characters of a string-eval are to
913: be shown in the output. Use a value of C<0> to show all text.
914:
915: Defaults to C<0>.
916:
917: =head2 $Carp::MaxArgLen
918:
919: This variable determines how many characters of each argument to a
920: function to print. Use a value of C<0> to show the full length of the
921: argument.
922:
923: Defaults to C<64>.
924:
925: =head2 $Carp::MaxArgNums
926:
927: This variable determines how many arguments to each function to show.
928: Use a false value to show all arguments to a function call. To suppress all
929: arguments, use C<-1> or C<'0 but true'>.
930:
931: Defaults to C<8>.
932:
933: =head2 $Carp::Verbose
934:
935: This variable makes C<carp()> and C<croak()> generate stack backtraces
936: just like C<cluck()> and C<confess()>. This is how C<use Carp 'verbose'>
937: is implemented internally.
938:
939: Defaults to C<0>.
940:
941: =head2 $Carp::RefArgFormatter
942:
943: This variable sets a general argument formatter to display references.
944: Plain scalars and objects that implement C<CARP_TRACE> will not go through
945: this formatter. Calling C<Carp> from within this function is not supported.
946:
947: local $Carp::RefArgFormatter = sub {
948: require Data::Dumper;
949: Data::Dumper::Dump($_[0]); # not necessarily safe
950: };
951:
952: =head2 @CARP_NOT
953:
954: This variable, I<in your package>, says which packages are I<not> to be
955: considered as the location of an error. The C<carp()> and C<cluck()>
956: functions will skip over callers when reporting where an error occurred.
957:
958: NB: This variable must be in the package's symbol table, thus:
959:
960: # These work
961: our @CARP_NOT; # file scope
962: use vars qw(@CARP_NOT); # package scope
963: @My::Package::CARP_NOT = ... ; # explicit package variable
964:
965: # These don't work
966: sub xyz { ... @CARP_NOT = ... } # w/o declarations above
967: my @CARP_NOT; # even at top-level
968:
969: Example of use:
970:
971: package My::Carping::Package;
972: use Carp;
973: our @CARP_NOT;
974: sub bar { .... or _error('Wrong input') }
975: sub _error {
976: # temporary control of where'ness, __PACKAGE__ is implicit
977: local @CARP_NOT = qw(My::Friendly::Caller);
978: carp(@_)
979: }
980:
981: This would make C<Carp> report the error as coming from a caller not
982: in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
983:
984: Also read the L</DESCRIPTION> section above, about how C<Carp> decides
985: where the error is reported from.
986:
987: Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
988:
989: Overrides C<Carp>'s use of C<@ISA>.
990:
991: =head2 %Carp::Internal
992:
993: This says what packages are internal to Perl. C<Carp> will never
994: report an error as being from a line in a package that is internal to
995: Perl. For example:
996:
997: $Carp::Internal{ (__PACKAGE__) }++;
998: # time passes...
999: sub foo { ... or confess("whatever") };
1000:
1001: would give a full stack backtrace starting from the first caller
1002: outside of __PACKAGE__. (Unless that package was also internal to
1003: Perl.)
1004:
1005: =head2 %Carp::CarpInternal
1006:
1007: This says which packages are internal to Perl's warning system. For
1008: generating a full stack backtrace this is the same as being internal
1009: to Perl, the stack backtrace will not start inside packages that are
1010: listed in C<%Carp::CarpInternal>. But it is slightly different for
1011: the summary message generated by C<carp> or C<croak>. There errors
1012: will not be reported on any lines that are calling packages in
1013: C<%Carp::CarpInternal>.
1014:
1015: For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
1016: Therefore the full stack backtrace from C<confess> will not start
1017: inside of C<Carp>, and the short message from calling C<croak> is
1018: not placed on the line where C<croak> was called.
1019:
1020: =head2 $Carp::CarpLevel
1021:
1022: This variable determines how many additional call frames are to be
1023: skipped that would not otherwise be when reporting where an error
1024: occurred on a call to one of C<Carp>'s functions. It is fairly easy
1025: to count these call frames on calls that generate a full stack
1026: backtrace. However it is much harder to do this accounting for calls
1027: that generate a short message. Usually people skip too many call
1028: frames. If they are lucky they skip enough that C<Carp> goes all of
1029: the way through the call stack, realizes that something is wrong, and
1030: then generates a full stack backtrace. If they are unlucky then the
1031: error is reported from somewhere misleading very high in the call
1032: stack.
1033:
1034: Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
1035: C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
1036:
1037: Defaults to C<0>.
1038:
1039: =head1 BUGS
1040:
1041: The Carp routines don't handle exception objects currently.
1042: If called with a first argument that is a reference, they simply
1043: call die() or warn(), as appropriate.
1044:
1045: =head1 SEE ALSO
1046:
1047: L<Carp::Always>,
1048: L<Carp::Clan>
1049:
1050: =head1 CONTRIBUTING
1051:
1052: L<Carp> is maintained by the perl 5 porters as part of the core perl 5
1053: version control repository. Please see the L<perlhack> perldoc for how to
1054: submit patches and contribute to it.
1055:
1056: =head1 AUTHOR
1057:
1058: The Carp module first appeared in Larry Wall's perl 5.000 distribution.
1059: Since then it has been modified by several of the perl 5 porters.
1060: Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
1061: distribution.
1062:
1063: =head1 COPYRIGHT
1064:
1065: Copyright (C) 1994-2013 Larry Wall
1066:
1067: Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
1068:
1069: =head1 LICENSE
1070:
1071: This module is free software; you can redistribute it and/or modify it
1072: under the same terms as Perl itself.