This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Streamline Carp.pm.
authorIlya Zakharevich <ilya@math.berkeley.edu>
Mon, 26 Jul 1999 04:05:27 +0000 (00:05 -0400)
committerJarkko Hietaniemi <jhi@iki.fi>
Mon, 26 Jul 1999 09:17:26 +0000 (09:17 +0000)
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
lib/Carp.pm
lib/Carp/Heavy.pm [new file with mode: 0644]

index 89e480e..00e6e20 100644 (file)
--- 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)
index 3644424..eaa4d53 100644 (file)
@@ -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-<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;
+    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 (file)
index 0000000..0672efe
--- /dev/null
@@ -0,0 +1,204 @@
+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;