[p5sagit/p5-mst-13.2.git] / lib / Carp.pm

package Carp;

=head1 NAME

carp    - warn of errors (from perspective of caller)

cluck   - warn of errors with stack backtrace
          (not exported by default)

croak   - die of errors (from perspective of caller)

confess - die of errors with stack backtrace

=head1 SYNOPSIS

    use Carp;
    croak "We're outta here!";

    use Carp qw(cluck);
    cluck "This is how we got here!";

=head1 DESCRIPTION

The Carp routines are useful in your own modules because
they act like die() or warn(), but report where the error
was in the code they were called from.  Thus if you have a 
routine Foo() that has a carp() in it, then the carp() 
will report the error as occurring where Foo() was called, 
not where carp() was called.

=head2 Forcing a Stack Trace

As a debugging aid, you can force Carp to treat a croak as a confess
and a carp as a cluck across I<all> modules. In other words, force a
detailed stack trace to be given.  This can be very helpful when trying
to understand why, or from where, a warning or error is being generated.

This feature is enabled by 'importing' the non-existent symbol
'verbose'. You would typically enable it by saying

    perl -MCarp=verbose script.pl

or by including the string C<MCarp=verbose> in the L<PERL5OPT>
environment variable.

=head1 BUGS

The Carp routines don't handle exception objects currently.
If called with a first argument that is a reference, they simply
call die() or warn(), as appropriate.

=cut

# This package is heavily used. Be small. Be fast. Be good.

# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
# _almost_ complete understanding of the package.  Corrections and
# comments are welcome.

# The $CarpLevel variable can be set to "strip off" extra caller levels for
# those times when Carp calls are buried inside other functions.  The
# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
# text and function arguments should be formatted when printed.

$CarpLevel = 0;		# How many extra package levels to skip on carp.
$MaxEvalLen = 0;	# How much eval '...text...' to show. 0 = all.
$MaxArgLen = 64;        # How much of each argument to print. 0 = all.
$MaxArgNums = 8;        # How many arguments to print. 0 = all.
$Verbose = 0;		# If true then make shortmess call longmess instead

require Exporter;
@ISA = ('Exporter');
@EXPORT = qw(confess croak carp);
@EXPORT_OK = qw(cluck verbose);
@EXPORT_FAIL = qw(verbose);	# hook to enable verbose mode


# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
# then the following method will be called by the Exporter which knows
# to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
# 'verbose'.

sub export_fail {
    shift;
    $Verbose = shift if $_[0] eq 'verbose';
    return @_;
}


# longmess() crawls all the way up the stack reporting on all the function
# calls made.  The error string, $error, is originally constructed from the
# arguments passed into longmess() via confess(), cluck() or shortmess().
# This gets appended with the stack trace messages which are generated for
# each function call on the stack.

sub longmess {
    return @_ if ref $_[0];
    my $error = join '', @_;
    my $mess = "";
    my $i = 1 + $CarpLevel;
    my ($pack,$file,$line,$sub,$hargs,$eval,$require);
    my (@a);
    #
    # crawl up the stack....
    #
    while (do { { package DB; @a = caller($i++) } } ) {
	# get copies of the variables returned from caller()
	($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
	#
	# if the $error error string is newline terminated then it
	# is copied into $mess.  Otherwise, $mess gets set (at the end of
	# the 'else {' section below) to one of two things.  The first time
	# through, it is set to the "$error at $file line $line" message.
	# $error is then set to 'called' which triggers subsequent loop
	# iterations to append $sub to $mess before appending the "$error
	# at $file line $line" which now actually reads "called at $file line
	# $line".  Thus, the stack trace message is constructed:
	#
	#        first time: $mess  = $error at $file line $line
	#  subsequent times: $mess .= $sub $error at $file line $line
	#                                  ^^^^^^
	#                                 "called"
	if ($error =~ m/\n$/) {
	    $mess .= $error;
	} else {
	    # Build a string, $sub, which names the sub-routine called.
	    # This may also be "require ...", "eval '...' or "eval {...}"
	    if (defined $eval) {
		if ($require) {
		    $sub = "require $eval";
		} else {
		    $eval =~ s/([\\\'])/\\$1/g;
		    if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
			substr($eval,$MaxEvalLen) = '...';
		    }
		    $sub = "eval '$eval'";
		}
	    } elsif ($sub eq '(eval)') {
		$sub = 'eval {...}';
	    }
	    # if there are any arguments in the sub-routine call, format
	    # them according to the format variables defined earlier in
	    # this file and join them onto the $sub sub-routine string
	    if ($hargs) {
		# we may trash some of the args so we take a copy
		@a = @DB::args;	# must get local copy of args
		# don't print any more than $MaxArgNums
		if ($MaxArgNums and @a > $MaxArgNums) {
		    # cap the length of $#a and set the last element to '...'
		    $#a = $MaxArgNums;
		    $a[$#a] = "...";
		}
		for (@a) {
		    # set args to the string "undef" if undefined
		    $_ = "undef", next unless defined $_;
		    if (ref $_) {
			# dunno what this is for...
			$_ .= '';
			s/'/\\'/g;
		    }
		    else {
			s/'/\\'/g;
			# terminate the string early with '...' if too long
			substr($_,$MaxArgLen) = '...'
			    if $MaxArgLen and $MaxArgLen < length;
		    }
		    # 'quote' arg unless it looks like a number
		    $_ = "'$_'" unless /^-?[\d.]+$/;
		    # print high-end chars as 'M-<char>' or '^<char>'
		    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
		    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
		}
		# append ('all', 'the', 'arguments') to the $sub string
		$sub .= '(' . join(', ', @a) . ')';
	    }
	    # here's where the error message, $mess, gets constructed
	    $mess .= "\t$sub " if $error eq "called";
	    $mess .= "$error at $file line $line";
	    if (exists $main::{'Thread::'}) {
		my $tid = Thread->self->tid;
		$mess .= " thread $tid" if $tid;
	    }
	    $mess .= "\n";
	}
	# we don't need to print the actual error message again so we can
	# change this to "called" so that the string "$error at $file line
	# $line" makes sense as "called at $file line $line".
	$error = "called";
    }
    # this kludge circumvents die's incorrect handling of NUL
    my $msg = \($mess || $error);
    $$msg =~ tr/\0//d;
    $$msg;
}


# shortmess() is called by carp() and croak() to skip all the way up to
# the top-level caller's package and report the error from there.  confess()
# and cluck() generate a full stack trace so they call longmess() to
# generate that.  In verbose mode shortmess() calls longmess() so
# you always get a stack trace

sub shortmess {	# Short-circuit &longmess if called via multiple packages
    goto &longmess if $Verbose;
    return @_ if ref $_[0];
    my $error = join '', @_;
    my ($prevpack) = caller(1);
    my $extra = $CarpLevel;
    my $i = 2;
    my ($pack,$file,$line);
    # when reporting an error, we want to report it from the context of the
    # calling package.  So what is the calling package?  Within a module,
    # there may be many calls between methods and perhaps between sub-classes
    # and super-classes, but the user isn't interested in what happens
    # inside the package.  We start by building a hash array which keeps
    # track of all the packages to which the calling package belongs.  We
    # do this by examining its @ISA variable.  Any call from a base class
    # method (one of our caller's @ISA packages) can be ignored
    my %isa = ($prevpack,1);

    # merge all the caller's @ISA packages into %isa.
    @isa{@{"${prevpack}::ISA"}} = ()
	if(@{"${prevpack}::ISA"});

    # now we crawl up the calling stack and look at all the packages in
    # there.  For each package, we look to see if it has an @ISA and then
    # we see if our caller features in that list.  That would imply that
    # our caller is a derived class of that package and its calls can also
    # be ignored
    while (($pack,$file,$line) = caller($i++)) {
	if(@{$pack . "::ISA"}) {
	    my @i = @{$pack . "::ISA"};
	    my %i;
	    @i{@i} = ();
	    # merge any relevant packages into %isa
	    @isa{@i,$pack} = ()
		if(exists $i{$prevpack} || exists $isa{$pack});
	}

	# and here's where we do the ignoring... if the package in
	# question is one of our caller's base or derived packages then
	# we can ignore it (skip it) and go onto the next (but note that
	# the continue { } block below gets called every time)
	next
	    if(exists $isa{$pack});

	# Hey!  We've found a package that isn't one of our caller's
	# clan....but wait, $extra refers to the number of 'extra' levels
	# we should skip up.  If $extra > 0 then this is a false alarm.
	# We must merge the package into the %isa hash (so we can ignore it
	# if it pops up again), decrement $extra, and continue.
	if ($extra-- > 0) {
	    %isa = ($pack,1);
	    @isa{@{$pack . "::ISA"}} = ()
		if(@{$pack . "::ISA"});
	}
	else {
	    # OK!  We've got a candidate package.  Time to construct the
	    # relevant error message and return it.   die() doesn't like
	    # to be given NUL characters (which $msg may contain) so we
	    # remove them first.
	    my $msg;
	    $msg = "$error at $file line $line";
	    if (exists $main::{'Thread::'}) {
		my $tid = Thread->self->tid;
		$mess .= " thread $tid" if $tid;
	    }
	    $msg .= "\n";
	    $msg =~ tr/\0//d;
	    return $msg;
	}
    }
    continue {
	$prevpack = $pack;
    }

    # uh-oh!  It looks like we crawled all the way up the stack and
    # never found a candidate package.  Oh well, let's call longmess
    # to generate a full stack trace.  We use the magical form of 'goto'
    # so that this shortmess() function doesn't appear on the stack
    # to further confuse longmess() about it's calling package.
    goto &longmess;
}


# the following four functions call longmess() or shortmess() depending on
# whether they should generate a full stack trace (confess() and cluck())
# or simply report the caller's package (croak() and carp()), respectively.
# confess() and croak() die, carp() and cluck() warn.

sub croak   { die  shortmess @_ }
sub confess { die  longmess  @_ }
sub carp    { warn shortmess @_ }
sub cluck   { warn longmess  @_ }

1;
Commit	Line	Data
a0d0e21e	1	package Carp;
a0d0e21e	2
f06db76b	3	=head1 NAME
f06db76b	4
4d935a29	5	carp - warn of errors (from perspective of caller)
f06db76b	6
4d935a29	7	cluck - warn of errors with stack backtrace
	8	(not exported by default)
	9
	10	croak - die of errors (from perspective of caller)
f06db76b	11
	12	confess - die of errors with stack backtrace
	13
	14	=head1 SYNOPSIS
	15
	16	use Carp;
	17	croak "We're outta here!";
	18
4d935a29	19	use Carp qw(cluck);
	20	cluck "This is how we got here!";
	21
f06db76b	22	=head1 DESCRIPTION
	23
	24	The Carp routines are useful in your own modules because
	25	they act like die() or warn(), but report where the error
	26	was in the code they were called from. Thus if you have a
	27	routine Foo() that has a carp() in it, then the carp()
	28	will report the error as occurring where Foo() was called,
	29	not where carp() was called.
	30
4d935a29	31	=head2 Forcing a Stack Trace
	32
	33	As a debugging aid, you can force Carp to treat a croak as a confess
	34	and a carp as a cluck across I<all> modules. In other words, force a
	35	detailed stack trace to be given. This can be very helpful when trying
	36	to understand why, or from where, a warning or error is being generated.
	37
f610777f	38	This feature is enabled by 'importing' the non-existent symbol
4d935a29	39	'verbose'. You would typically enable it by saying
	40
	41	perl -MCarp=verbose script.pl
	42
	43	or by including the string C<MCarp=verbose> in the L<PERL5OPT>
	44	environment variable.
	45
d2fe67be	46	=head1 BUGS
	47
	48	The Carp routines don't handle exception objects currently.
	49	If called with a first argument that is a reference, they simply
	50	call die() or warn(), as appropriate.
	51
f06db76b	52	=cut
f06db76b	53
4d935a29	54	# This package is heavily used. Be small. Be fast. Be good.
a0d0e21e	55
7b8d334a	56	# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
	57	# _almost_ complete understanding of the package. Corrections and
	58	# comments are welcome.
	59
	60	# The $CarpLevel variable can be set to "strip off" extra caller levels for
	61	# those times when Carp calls are buried inside other functions. The
	62	# $Max(EvalLen\|(Arg(Len\|Nums)) variables are used to specify how the eval
	63	# text and function arguments should be formatted when printed.
	64
748a9306	65	$CarpLevel = 0; # How many extra package levels to skip on carp.
c07a80fd	66	$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
55497cff	67	$MaxArgLen = 64; # How much of each argument to print. 0 = all.
55497cff	68	$MaxArgNums = 8; # How many arguments to print. 0 = all.
6ff81951	69	$Verbose = 0; # If true then make shortmess call longmess instead
748a9306	70
a0d0e21e	71	require Exporter;
fb73857a	72	@ISA = ('Exporter');
a0d0e21e	73	@EXPORT = qw(confess croak carp);
4d935a29	74	@EXPORT_OK = qw(cluck verbose);
	75	@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
	76
7b8d334a	77
	78	# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
	79	# then the following method will be called by the Exporter which knows
	80	# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
	81	# 'verbose'.
	82
4d935a29	83	sub export_fail {
4d935a29	84	shift;
6ff81951	85	$Verbose = shift if $_[0] eq 'verbose';
4d935a29	86	return @_;
	87	}
	88
a0d0e21e	89
7b8d334a	90	# longmess() crawls all the way up the stack reporting on all the function
	91	# calls made. The error string, $error, is originally constructed from the
	92	# arguments passed into longmess() via confess(), cluck() or shortmess().
	93	# This gets appended with the stack trace messages which are generated for
	94	# each function call on the stack.
	95
a0d0e21e	96	sub longmess {
d2fe67be	97	return @_ if ref $_[0];
d43563dd	98	my $error = join '', @_;
a0d0e21e	99	my $mess = "";
748a9306	100	my $i = 1 + $CarpLevel;
55497cff	101	my ($pack,$file,$line,$sub,$hargs,$eval,$require);
55497cff	102	my (@a);
7b8d334a	103	#
	104	# crawl up the stack....
	105	#
55497cff	106	while (do { { package DB; @a = caller($i++) } } ) {
7b8d334a	107	# get copies of the variables returned from caller()
	108	($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
	109	#
	110	# if the $error error string is newline terminated then it
	111	# is copied into $mess. Otherwise, $mess gets set (at the end of
	112	# the 'else {' section below) to one of two things. The first time
	113	# through, it is set to the "$error at $file line $line" message.
	114	# $error is then set to 'called' which triggers subsequent loop
	115	# iterations to append $sub to $mess before appending the "$error
	116	# at $file line $line" which now actually reads "called at $file line
	117	# $line". Thus, the stack trace message is constructed:
	118	#
	119	# first time: $mess = $error at $file line $line
	120	# subsequent times: $mess .= $sub $error at $file line $line
	121	# ^^^^^^
	122	# "called"
c1bce5d7	123	if ($error =~ m/\n$/) {
	124	$mess .= $error;
	125	} else {
7b8d334a	126	# Build a string, $sub, which names the sub-routine called.
7b8d334a	127	# This may also be "require ...", "eval '...' or "eval {...}"
c07a80fd	128	if (defined $eval) {
7b8d334a	129	if ($require) {
c07a80fd	130	$sub = "require $eval";
c07a80fd	131	} else {
9c7d8621	132	$eval =~ s/([\\\'])/\\$1/g;
c07a80fd	133	if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
	134	substr($eval,$MaxEvalLen) = '...';
	135	}
	136	$sub = "eval '$eval'";
	137	}
	138	} elsif ($sub eq '(eval)') {
	139	$sub = 'eval {...}';
	140	}
7b8d334a	141	# if there are any arguments in the sub-routine call, format
	142	# them according to the format variables defined earlier in
	143	# this file and join them onto the $sub sub-routine string
55497cff	144	if ($hargs) {
7b8d334a	145	# we may trash some of the args so we take a copy
	146	@a = @DB::args; # must get local copy of args
	147	# don't print any more than $MaxArgNums
	148	if ($MaxArgNums and @a > $MaxArgNums) {
	149	# cap the length of $#a and set the last element to '...'
	150	$#a = $MaxArgNums;
	151	$a[$#a] = "...";
68dc0745	152	}
7b8d334a	153	for (@a) {
	154	# set args to the string "undef" if undefined
	155	$_ = "undef", next unless defined $_;
	156	if (ref $_) {
	157	# dunno what this is for...
	158	$_ .= '';
	159	s/'/\\'/g;
	160	}
	161	else {
	162	s/'/\\'/g;
	163	# terminate the string early with '...' if too long
	164	substr($_,$MaxArgLen) = '...'
	165	if $MaxArgLen and $MaxArgLen < length;
	166	}
	167	# 'quote' arg unless it looks like a number
	168	$_ = "'$_'" unless /^-?[\d.]+$/;
	169	# print high-end chars as 'M-<char>' or '^<char>'
	170	s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
	171	s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
68dc0745	172	}
7b8d334a	173	# append ('all', 'the', 'arguments') to the $sub string
7b8d334a	174	$sub .= '(' . join(', ', @a) . ')';
55497cff	175	}
7b8d334a	176	# here's where the error message, $mess, gets constructed
c1bce5d7	177	$mess .= "\t$sub " if $error eq "called";
9efbc0eb	178	$mess .= "$error at $file line $line";
e8e6f333	179	if (exists $main::{'Thread::'}) {
	180	my $tid = Thread->self->tid;
	181	$mess .= " thread $tid" if $tid;
	182	}
9efbc0eb	183	$mess .= "\n";
c1bce5d7	184	}
7b8d334a	185	# we don't need to print the actual error message again so we can
	186	# change this to "called" so that the string "$error at $file line
	187	# $line" makes sense as "called at $file line $line".
a0d0e21e	188	$error = "called";
a0d0e21e	189	}
68dc0745	190	# this kludge circumvents die's incorrect handling of NUL
	191	my $msg = \($mess \|\| $error);
	192	$$msg =~ tr/\0//d;
	193	$$msg;
a0d0e21e	194	}
a0d0e21e	195
7b8d334a	196
	197	# shortmess() is called by carp() and croak() to skip all the way up to
	198	# the top-level caller's package and report the error from there. confess()
	199	# and cluck() generate a full stack trace so they call longmess() to
6ff81951	200	# generate that. In verbose mode shortmess() calls longmess() so
7b8d334a	201	# you always get a stack trace
7b8d334a	202
748a9306	203	sub shortmess { # Short-circuit &longmess if called via multiple packages
6ff81951	204	goto &longmess if $Verbose;
d2fe67be	205	return @_ if ref $_[0];
d43563dd	206	my $error = join '', @_;
9c7d8621	207	my ($prevpack) = caller(1);
748a9306	208	my $extra = $CarpLevel;
a0d0e21e	209	my $i = 2;
c07a80fd	210	my ($pack,$file,$line);
7b8d334a	211	# when reporting an error, we want to report it from the context of the
	212	# calling package. So what is the calling package? Within a module,
	213	# there may be many calls between methods and perhaps between sub-classes
	214	# and super-classes, but the user isn't interested in what happens
	215	# inside the package. We start by building a hash array which keeps
	216	# track of all the packages to which the calling package belongs. We
	217	# do this by examining its @ISA variable. Any call from a base class
	218	# method (one of our caller's @ISA packages) can be ignored
9c7d8621	219	my %isa = ($prevpack,1);
9c7d8621	220
7b8d334a	221	# merge all the caller's @ISA packages into %isa.
9c7d8621	222	@isa{@{"${prevpack}::ISA"}} = ()
69794302	223	if(@{"${prevpack}::ISA"});
9c7d8621	224
7b8d334a	225	# now we crawl up the calling stack and look at all the packages in
	226	# there. For each package, we look to see if it has an @ISA and then
	227	# we see if our caller features in that list. That would imply that
	228	# our caller is a derived class of that package and its calls can also
	229	# be ignored
c07a80fd	230	while (($pack,$file,$line) = caller($i++)) {
69794302	231	if(@{$pack . "::ISA"}) {
9c7d8621	232	my @i = @{$pack . "::ISA"};
	233	my %i;
	234	@i{@i} = ();
7b8d334a	235	# merge any relevant packages into %isa
9c7d8621	236	@isa{@i,$pack} = ()
	237	if(exists $i{$prevpack} \|\| exists $isa{$pack});
	238	}
	239
7b8d334a	240	# and here's where we do the ignoring... if the package in
	241	# question is one of our caller's base or derived packages then
	242	# we can ignore it (skip it) and go onto the next (but note that
	243	# the continue { } block below gets called every time)
9c7d8621	244	next
	245	if(exists $isa{$pack});
	246
7b8d334a	247	# Hey! We've found a package that isn't one of our caller's
	248	# clan....but wait, $extra refers to the number of 'extra' levels
	249	# we should skip up. If $extra > 0 then this is a false alarm.
	250	# We must merge the package into the %isa hash (so we can ignore it
	251	# if it pops up again), decrement $extra, and continue.
9c7d8621	252	if ($extra-- > 0) {
	253	%isa = ($pack,1);
	254	@isa{@{$pack . "::ISA"}} = ()
69794302	255	if(@{$pack . "::ISA"});
9c7d8621	256	}
9c7d8621	257	else {
7b8d334a	258	# OK! We've got a candidate package. Time to construct the
	259	# relevant error message and return it. die() doesn't like
	260	# to be given NUL characters (which $msg may contain) so we
	261	# remove them first.
9efbc0eb	262	my $msg;
9efbc0eb	263	$msg = "$error at $file line $line";
e8e6f333	264	if (exists $main::{'Thread::'}) {
	265	my $tid = Thread->self->tid;
	266	$mess .= " thread $tid" if $tid;
	267	}
9efbc0eb	268	$msg .= "\n";
9efbc0eb	269	$msg =~ tr/\0//d;
68dc0745	270	return $msg;
748a9306	271	}
a0d0e21e	272	}
9c7d8621	273	continue {
	274	$prevpack = $pack;
	275	}
	276
7b8d334a	277	# uh-oh! It looks like we crawled all the way up the stack and
	278	# never found a candidate package. Oh well, let's call longmess
	279	# to generate a full stack trace. We use the magical form of 'goto'
	280	# so that this shortmess() function doesn't appear on the stack
	281	# to further confuse longmess() about it's calling package.
748a9306	282	goto &longmess;
a0d0e21e	283	}
a0d0e21e	284
7b8d334a	285
	286	# the following four functions call longmess() or shortmess() depending on
	287	# whether they should generate a full stack trace (confess() and cluck())
	288	# or simply report the caller's package (croak() and carp()), respectively.
	289	# confess() and croak() die, carp() and cluck() warn.
	290
	291	sub croak { die shortmess @_ }
	292	sub confess { die longmess @_ }
	293	sub carp { warn shortmess @_ }
	294	sub cluck { warn longmess @_ }
a0d0e21e	295
748a9306	296	1;