From 3132b1504bf3879ca430816411425569340202e8 Mon Sep 17 00:00:00 2001 From: Ilya Zakharevich Date: Mon, 26 Jul 1999 00:05:27 -0400 Subject: [PATCH] Streamline Carp.pm. To: perl5-porters@perl.org (Mailing list Perl5) Subject: [PATCH 5.005_57] Lean Carp.pm with Carp/Heavy.pm Message-Id: <199907260805.EAA26888@monk.mps.ohio-state.edu> The patch was based on 5_57 so had to re-apply lib/Carp.pm parts of changes #3498, #3696, and #3702 for the new lib/Carp/Heavy.pm. p4raw-link: @3498 on //depot/cfgperl: 697943021785eb8447e25eb51a6f27fd78921863 p4raw-id: //depot/cfgperl@3764 --- MANIFEST | 1 + lib/Carp.pm | 180 ++--------------------------------------------- lib/Carp/Heavy.pm | 204 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 209 insertions(+), 176 deletions(-) create mode 100644 lib/Carp/Heavy.pm diff --git a/MANIFEST b/MANIFEST index 89e480e..00e6e20 100644 --- a/MANIFEST +++ b/MANIFEST @@ -539,6 +539,7 @@ lib/CPAN.pm Interface to Comprehensive Perl Archive Network lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/Carp.pm Error message base class +lib/Carp/Heavy.pm Error message workhorse lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) lib/DB.pm Debugger API (draft) diff --git a/lib/Carp.pm b/lib/Carp.pm index 3644424..eaa4d53 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -94,103 +94,8 @@ sub export_fail { # 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-' or '^' - 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; + require Carp::Heavy; + goto &longmess_heavy; } @@ -201,85 +106,8 @@ sub longmess { # 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; + require Carp::Heavy; + goto &shortmess_heavy; } diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm new file mode 100644 index 0000000..0672efe --- /dev/null +++ b/lib/Carp/Heavy.pm @@ -0,0 +1,204 @@ +package Carp; +# This package is heavily used. Be small. Be fast. Be good. + +# Comments added by Andy Wardley 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-' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + # print remaining control chars as ^ + 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; -- 2.7.4