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

package Carp;
# 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.

# 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_heavy {
    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>'
		    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
		    # print remaining control chars as ^<char>
		    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_heavy {	# Short-circuit &longmess if called via multiple packages
    goto &longmess_heavy 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_heavy;
}

1;
Commit	Line	Data
3b5ca523	1	package Carp;
	2	# This package is heavily used. Be small. Be fast. Be good.
	3
	4	# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
	5	# _almost_ complete understanding of the package. Corrections and
	6	# comments are welcome.
	7
	8	# longmess() crawls all the way up the stack reporting on all the function
	9	# calls made. The error string, $error, is originally constructed from the
	10	# arguments passed into longmess() via confess(), cluck() or shortmess().
	11	# This gets appended with the stack trace messages which are generated for
	12	# each function call on the stack.
	13
	14	sub longmess_heavy {
	15	return @_ if ref $_[0];
	16	my $error = join '', @_;
	17	my $mess = "";
	18	my $i = 1 + $CarpLevel;
	19	my ($pack,$file,$line,$sub,$hargs,$eval,$require);
	20	my (@a);
	21	#
	22	# crawl up the stack....
	23	#
	24	while (do { { package DB; @a = caller($i++) } } ) {
	25	# get copies of the variables returned from caller()
	26	($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
	27	#
	28	# if the $error error string is newline terminated then it
	29	# is copied into $mess. Otherwise, $mess gets set (at the end of
	30	# the 'else {' section below) to one of two things. The first time
	31	# through, it is set to the "$error at $file line $line" message.
	32	# $error is then set to 'called' which triggers subsequent loop
	33	# iterations to append $sub to $mess before appending the "$error
	34	# at $file line $line" which now actually reads "called at $file line
	35	# $line". Thus, the stack trace message is constructed:
	36	#
	37	# first time: $mess = $error at $file line $line
	38	# subsequent times: $mess .= $sub $error at $file line $line
	39	# ^^^^^^
	40	# "called"
	41	if ($error =~ m/\n$/) {
	42	$mess .= $error;
	43	} else {
	44	# Build a string, $sub, which names the sub-routine called.
	45	# This may also be "require ...", "eval '...' or "eval {...}"
	46	if (defined $eval) {
	47	if ($require) {
	48	$sub = "require $eval";
	49	} else {
	50	$eval =~ s/([\\\'])/\\$1/g;
	51	if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
	52	substr($eval,$MaxEvalLen) = '...';
	53	}
	54	$sub = "eval '$eval'";
	55	}
	56	} elsif ($sub eq '(eval)') {
	57	$sub = 'eval {...}';
	58	}
	59	# if there are any arguments in the sub-routine call, format
	60	# them according to the format variables defined earlier in
	61	# this file and join them onto the $sub sub-routine string
	62	if ($hargs) {
	63	# we may trash some of the args so we take a copy
	64	@a = @DB::args; # must get local copy of args
65	# don't print any more than $MaxArgNums
66	if ($MaxArgNums and @a > $MaxArgNums) {
67	# cap the length of $#a and set the last element to '...'
68	$#a = $MaxArgNums;
69	$a[$#a] = "...";
70	}
71	for (@a) {
72	# set args to the string "undef" if undefined
73	$_ = "undef", next unless defined $_;
74	if (ref $_) {
75	# dunno what this is for...
76	$_ .= '';
77	s/'/\\'/g;
78	}
79	else {
80	s/'/\\'/g;
81	# terminate the string early with '...' if too long
82	substr($_,$MaxArgLen) = '...'
83	if $MaxArgLen and $MaxArgLen < length;
84	}
85	# 'quote' arg unless it looks like a number
86	$_ = "'$_'" unless /^-?[\d.]+$/;
87	# print high-end chars as 'M-<char>'
88	s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
89	# print remaining control chars as ^<char>
90	s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
91	}
92	# append ('all', 'the', 'arguments') to the $sub string
93	$sub .= '(' . join(', ', @a) . ')';
94	}
95	# here's where the error message, $mess, gets constructed
96	$mess .= "\t$sub " if $error eq "called";
97	$mess .= "$error at $file line $line";
98	if (exists $main::{'Thread::'}) {
99	my $tid = Thread->self->tid;
100	$mess .= " thread $tid" if $tid;
101	}
102	$mess .= "\n";
103	}
104	# we don't need to print the actual error message again so we can
105	# change this to "called" so that the string "$error at $file line
106	# $line" makes sense as "called at $file line $line".
107	$error = "called";
108	}
109	# this kludge circumvents die's incorrect handling of NUL
110	my $msg = \($mess \|\| $error);
111	$$msg =~ tr/\0//d;
112	$$msg;
113	}
114
115
116	# shortmess() is called by carp() and croak() to skip all the way up to
117	# the top-level caller's package and report the error from there. confess()
118	# and cluck() generate a full stack trace so they call longmess() to
119	# generate that. In verbose mode shortmess() calls longmess() so
120	# you always get a stack trace
121
122	sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages
123	goto &longmess_heavy if $Verbose;
124	return @_ if ref $_[0];
125	my $error = join '', @_;
126	my ($prevpack) = caller(1);
127	my $extra = $CarpLevel;
128	my $i = 2;
129	my ($pack,$file,$line);
130	# when reporting an error, we want to report it from the context of the
131	# calling package. So what is the calling package? Within a module,
132	# there may be many calls between methods and perhaps between sub-classes
133	# and super-classes, but the user isn't interested in what happens
134	# inside the package. We start by building a hash array which keeps
135	# track of all the packages to which the calling package belongs. We
136	# do this by examining its @ISA variable. Any call from a base class
137	# method (one of our caller's @ISA packages) can be ignored
138	my %isa = ($prevpack,1);
139
140	# merge all the caller's @ISA packages into %isa.
141	@isa{@{"${prevpack}::ISA"}} = ()
142	if(@{"${prevpack}::ISA"});
143
144	# now we crawl up the calling stack and look at all the packages in
145	# there. For each package, we look to see if it has an @ISA and then
146	# we see if our caller features in that list. That would imply that
147	# our caller is a derived class of that package and its calls can also
148	# be ignored
149	while (($pack,$file,$line) = caller($i++)) {
150	if(@{$pack . "::ISA"}) {
151	my @i = @{$pack . "::ISA"};
152	my %i;
153	@i{@i} = ();
154	# merge any relevant packages into %isa
155	@isa{@i,$pack} = ()
156	if(exists $i{$prevpack} \|\| exists $isa{$pack});
157	}
158
159	# and here's where we do the ignoring... if the package in
160	# question is one of our caller's base or derived packages then
161	# we can ignore it (skip it) and go onto the next (but note that
162	# the continue { } block below gets called every time)
163	next
164	if(exists $isa{$pack});
165
166	# Hey! We've found a package that isn't one of our caller's
167	# clan....but wait, $extra refers to the number of 'extra' levels
168	# we should skip up. If $extra > 0 then this is a false alarm.
169	# We must merge the package into the %isa hash (so we can ignore it
170	# if it pops up again), decrement $extra, and continue.
171	if ($extra-- > 0) {
172	%isa = ($pack,1);
173	@isa{@{$pack . "::ISA"}} = ()
174	if(@{$pack . "::ISA"});
175	}
176	else {
177	# OK! We've got a candidate package. Time to construct the
178	# relevant error message and return it. die() doesn't like
179	# to be given NUL characters (which $msg may contain) so we
180	# remove them first.
181	my $msg;
182	$msg = "$error at $file line $line";
183	if (exists $main::{'Thread::'}) {
184	my $tid = Thread->self->tid;
185	$mess .= " thread $tid" if $tid;
186	}
187	$msg .= "\n";
188	$msg =~ tr/\0//d;
189	return $msg;
190	}
191	}
192	continue {
193	$prevpack = $pack;
194	}
195
196	# uh-oh! It looks like we crawled all the way up the stack and
197	# never found a candidate package. Oh well, let's call longmess
198	# to generate a full stack trace. We use the magical form of 'goto'
199	# so that this shortmess() function doesn't appear on the stack
200	# to further confuse longmess() about it's calling package.
201	goto &longmess_heavy;
202	}
203
204	1;