view release on metacpan or  search on metacpan

Eobj/PLerrsys.pm  view on Meta::CPAN

# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# A copy of the license can be found in a file named "licence.txt", at the
# root directory of this project.
#

package Eobj::PLerror;

$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
$DumpLevel = 0;

sub oneplace {
  my $i = 1;
  my $errcr;
  my ($package, $filename, $line);
  while (1) {
    ($package, $filename, $line) = caller($i++);
    last unless ($package);
    $errcr = ${"$package"."::errorcrawl"} || "";
    next if ($errcr eq 'skip');
    next if ($errcr eq 'system');
    last;
  }
  return "at $filename line $line" if ($package);
  return "";
}

sub stackdump {
    return @_ if ref $_[0];
    my $error = join '', @_;
    my $mess;
    my @messlist = ();
    my $i = 1 + $DumpLevel;
    my ($pack,$file,$line,$sub,$hargs,$junk,$eval,$require);
    my (@a);
    my (@b);
    my ($xsub, $xpack, $name, $errcr);
    #
    # crawl up the stack....
    #
  CRAWL: while (do { { package DB; @a = caller($i++) } } ) {
        $mess= ""; 
	# get copies of the variables returned from caller()
	($pack,$file,$line,$sub,$hargs,$junk,$eval,$require) = @a;
	$errcr = ${"$pack"."::errorcrawl"} || "";
        next CRAWL if ($errcr eq 'skip');
        last CRAWL if ($errcr eq 'halt');
	@a=();
	@a = @DB::args if $hargs;	# must get local copy of args

	#
	# 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 {...}';
	  } else {

	    # Now we attempt to handle autoloads gracefully. The idea is to
	    # steal the subroutine name from the function that the autoloader
	    # calls, hence one step shallower in the call stack ($i-2 because
	    # $i was incremented before).

	    if ($sub eq 'UNIVERSAL::AUTOLOAD') {
	      do { { package DB; @b = caller($i-2) } };
	      ($sub) = $b[3] =~ /.*::(.*)/;
	    }

	    # Now we try to substitute the classic Foo::Bar with something
	    # more useful. Hopefully, we'll resolve the object's name.

	    ($xpack, $xsub) = ($sub =~ /(.*)::(.*)/);
	    if ((defined $xpack) && (exists $packhash{$xpack})) {  # Is the package autoloaded?
	      if (($Eobj::classes{ref($a[0])}) # Paranoid check before...
		  && ($name = $a[0]->who)) { # calling a method
		$sub = $name."->".$xsub;
		shift @a; # Don't show ugly object references
	      } else {
		$sub = "(".$packhash{$xpack}.")->".$xsub;
	      }
	    }
	    if	((defined $xsub) && ($xsub eq '__ANON__')) {
	      $sub = "CALLBACK ";
	    }
	  }
	  # 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
	    # don't print any more than $MaxArgNums
	    if ($MaxArgNums and @a > $MaxArgNums) {