PApp::Exception - exception handling for PApp

PApp documentation Contained in the PApp distribution.

Index

Code Index:

NAME

Top

PApp::Exception - exception handling for PApp

SYNOPSIS

Top

 use PApp::Exception;

DESCRIPTION

Top

This module implements a exception class that is able to carry backtrace information and other information useful for tracking own bugs.

It's the standard exception class used by PApp.

local $SIG{__DIE__} = \&PApp::Exception::diehandler

_diehandler is a function suitable to be put into $SIG{__DIE__} (e.g. inside an eval). The advantage in using this function is that you get a useful backtrace on an error (among some other information). It should be compatible with any use of eval but might slow down evals that make heavy use of exceptions (but these are slow anyway).

Example:

 eval {
    local $SIG{__DIE__} = \&PApp::Exception::diehandler;
    ...
 };
$errobj = new PApp::Exception param => value..

Create and return a new exception object. The object is overloaded, stringification will call as_string.

 title      exception page title (default "PApp:Exception")
 body       the exception page body
 category   the error category
 error      the error message or error object
 info       additional info (arrayref)
 backtrace  optional backtrace info
 compatible if set, stringification will only return this field
 abridged   if set, only the error text will be shown
 as_string  if set, a plaintext instead of html will be generated

When called on an existing object, a clone of that exception object is created and the information is extended (backtrace is being ignored, title, info and error are extended).

$errobj->throw

Throw the exception.

$errobj->as_string

Return the full exception information as simple text string.

$errobj->as_html

Return the full exception information as a fully formatted html page.

fancydie $category, $error, [param => value...]

Aborts the current page and displays a fancy error box, complete with backtrace. $error should be a short error message, while $additional_info can be a multi-line description of the problem.

The rest of the function call consists of named arguments that are transparently passed to the PApp::Exception::new constructor (see above), with the exception of:

 skipcallers  the number of caller levels to skip in the backtrace
fancywarn <same arguments as fancydie>

Similar to fancydie, but warns only. (not exported by default).

vals = try BLOCK error, args...

eval the given block (using a _diehandler, @_ will contain useless values and the context will always be array context). If no error occurs, return, otherwise execute fancydie with the error message and the rest of the arguments (unless they are catch'ed).

catch BLOCK args...

Not yet implemented. If used as an argument to try, execute the block when an error occurs. Example:

   try {
      ... code
   } catch {
      ... code to be executed when an exception was raised
   };
$exc->errorpage

This method is being called by the PApp runtime whenever there is no handler for it. It should (depending on the $PApp::onerr variable and others!) display an error page for the user. Better overwrite the following methods, not this one.

$exc->ep_save
$html = $exc->ep_fullinfo
$html = $exc->ep_shortinfo
$html = $exc->ep_login
$html = $exc->ep_wrap(...)

Various parts of the error page that cna be generated independently of the others.

SEE ALSO

Top

PApp.

AUTHOR

Top

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/
PApp documentation Contained in the PApp distribution. 
##########################################################################
## All portions of this code are copyright (c) 2003,2004 nethype GmbH   ##
##########################################################################
## Using, reading, modifying or copying this code requires a LICENSE    ##
## from nethype GmbH, Franz-Werfel-Str. 11, 74078 Heilbronn,            ##
## Germany. If you happen to have questions, feel free to contact us at ##
## license@nethype.de.                                                  ##
##########################################################################


package PApp::Exception;

use base Exporter;
use overload ();

use PApp::HTML;

use utf8;

$VERSION = 1.45;
@EXPORT = qw(fancydie try catch);

no warnings;

# let's try to be careful, but brutale ausnahmefehler just rock!
sub __($) {
   eval { &PApp::__ } || $_[0];
}

use overload 
   'bool'   => sub { 1 },
   '""'     => sub { $_[0]{compatible} || $_[0]->as_string },
   fallback => 1,
   ;


sub diehandler {
   unless (ref $_[0]) {
      # the next few lines are a major stability improvement, as well as a nice speedup
      return if $_[0] =~ m%in use at .*XML/Parser/Expat.pm line \d+\.$%;
      # better not touch utf8_heavy, since this is called at interesting times....
      return if $_[0] =~ m%.*at .*/utf8_heavy.pl line \d+\.$%;

      # wether compatible is a good idea here is questionable...
      fancydie(__"caught a die", $_[0], compatible => $_[0], skipcallers => 1);
   }
}

# internal utility function for Gimp::Fu and others
#      talking about code-reuse ^^^^^^^^ ;)
sub wrap_text {
   my $x;
   for (split /\n/, $_[0]) {
      s/\G(.{1,$_[1]})(?:\s+|$)/$1\n/gm;
      $x .= $_;
   }
   $x =~ s/[ \t\015]+$//g;
   $x;
}

# called by zero-argument "die"
sub PROPAGATE {
   push @{$_[0]{info}}, "propagated at $_[1] line $_[2]";
   $_[0];
}


sub new($$;$@) {
   my $class = shift;
   my %arg = @_;

   if (ref $class) {
      my %obj = %$class;

      $obj{backtrace} ||= delete $arg{backtrace};
      push @{$obj{info}}, @{delete $arg{info}};

      while (my ($k, $v) = each %arg) {
         $obj{$k} = $obj{$k} ? "$v\n$obj{$k}" : $v;
      }

      my ($i, $package, $filename, $line);
      do {
         $package, $filename, $line = caller $i++;
      } while ($package eq "PApp::Exception");

      push @{$obj{info}}, "propagated at $file line $line" if $package;

      bless \%obj, ref $class;
   } else {
      bless \%arg, $class;
   }
}


sub throw($) {
   die $_[0];
}


sub as_string {
   my $self = shift;
   local $@; # localize $@ as to not destroy it inadvertetly

   if ($self->{abridged}) {
      $self->{error};
   } else {
      my $err = "\n".($self->{title} || __"PApp::Exception caught")."\n\n$self->{category}\n";
      $err .= "\n$self->{error}\n" if $self->{error};
      if ($self->{info}) {
         for (@{$self->{info}}) {
            my $info = $_;
            my $desc;

            if (ref $info) {
               $desc = " ($info->[0])";
               $info = $info->[1];
            }

            $info = wrap_text $info, 80;
            $err .= "\n".__"Additional Info"."$desc:\n$info\n";
         }
      }
      $err .= "\n".__"Backtrace".":\n$self->{backtrace}\n";
      
      $err =~ s/^/! /gm;
      $err =~ s/\0/\\0/g;

      $err;
   }
}

sub title {
   $_[0]->{title} || __"PApp::Exception";
}

sub category {
   $_[0]->{category} || __"ERROR";
}

sub as_html {
   my $self = shift;

   if ($self->{abridged}) {
      my $category = escape_html $self->{category};
      my $error    = escape_html $self->{error};

      <<EOF;
<html>
<body>
<p><table bgcolor='#d0d0f0' cellspacing='0' cellpadding='10' border='0'>
<tr><td bgcolor='#b0b0d0'><font face='Arial, Helvetica' color='black'><b>$category</b></font></td></tr>
<tr><td><font color='#3333cc'>$error</font></td></tr>
</table></p>
</body>
</html>
EOF

   } else {
      my $title = sprintf __"%s (exception caught)", $self->title;

"<html>
<head>
<title>$title</title>
</head>
<body bgcolor=\"#d0d0d0\">
<blockquote>
<h1>$title</h1>".
      $self->_as_html(@_)."
</blockquote>
</body>
</html>";
   }
}

sub _as_html($;$) {
   my $self = shift;
   my %args = @_;
   my $title = $self->title;
   my $body  = $args{body}  || $self->{body}  || "";
   my $category = escape_html ($self->category);
   my $error = escape_html $self->{error};

   my $err = <<EOF;
<p><table bgcolor='#d0d0f0' cellspacing='0' cellpadding='10' border='0'>
<tr><td bgcolor='#b0b0d0'><font face='Arial, Helvetica'><b><pre>$category</pre></b></font></td></tr>
<tr><td><font color='#3333cc'>$error</font></td></tr>
</table></p>
EOF

   if ($self->{info}) {
      for (@{$self->{info}}) {
         my $info = $_;
         my $desc;

         if ("ARRAY" eq ref $info) {
            $desc = " ($info->[0])";
            $info = $info->[1];
         }

         $info = escape_html wrap_text $info, 80;
         $err .= "<p>
<table bgcolor='#e0e0e0' cellspacing='0' cellpadding='10' border='0'>
<tr><td bgcolor='#c0c0c0'><font face='Arial, Helvetica'><b>".__"Additional Info"."$desc:</b></font></td></tr>
<tr><td><pre>$info</pre></td></tr>
</table></p>
";
      }
   }

   if ($self->{backtrace}) {
      my $backtrace = escape_html $self->{backtrace};
      $err .= "<p>
<table bgcolor='#ffc0c0' cellspacing='0' cellpadding='10' border='0' width='94%'>
<tr><td bgcolor='#e09090'><font face='Arial, Helvetica'><b>".__"Backtrace".":</b></font></td></tr>
<tr><td><pre>$backtrace</pre></td></tr>
</table></p>
";
   }

   if ($body) {
      $body = wrap_text $body, 80;
      $err .= <<EOF;
<p><table bgcolor='#e0e0f0' cellspacing='0' cellpadding='10' border='0'>
<tr><td><pre>$body</pre></td></tr>
</table></p>
EOF
   }

   $err;
}


# almost directly copied from DB, since mod_perl + 5.6 + DB is just too fragile
# obviously, this is horrible code ;->
sub papp_backtrace {
  package DB;
  local $SIG{__DIE__};

  my $start = shift;
  my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
  $start = 1 unless $start;
  for ($i = $start; @DB::args = ("optimized away"), ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
    $f = "<commandline>" if $f eq "-e";
    $w = $w ? '@ = ' : '$ = ';
    if ($i > $start) {
       my @a = map {
          eval {
             if (tied $_) {
                "<<TIED ".(tied $_).">>";
             } elsif (ref) {
                if (overload::Overloaded $_) {
                   "<<OVERLOADED ".(overload::StrVal $_).">>";
                } else {
                   "$_";
                }
             } else {
                my $strval = "$_";
                $strval =~ s/'/\\'/g;
                $strval =~ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
                $strval =~ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
                $strval =~ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
                $strval;
             }
          } || do {
             $@ =~ s/ at \(.*$//s;
             $@;
          }
       } ($s eq "PApp::SQL::connect_cached"
          ? (@DB::args[0,1], "<user>", "<pass>", @DB::args[4,5]) # nur loeschwasser
          : @DB::args);
       $a = $h ? '(' . join(', ', @a) . ')' : '';
       $e =~ s/\n\s*\;\s*\Z// if $e;
       $e =~ s/[\\\']/\\$1/g if $e;
       if ($r) {
         $s = "require '$e'";
       } elsif (defined $r) {
         $s = "eval '$e'";
       } elsif ($s eq '(eval)') {
         $s = "eval {...}";
       }
    }
    push @ret, "$w$s$a\ncalled from $f line $l";
    last if $DB::signal;
  }
  return @ret;
}

sub _fancyerr {
   my $category = shift;
   my $error = shift;
   my $info = [];
   my $backtrace;
   my %arg;
   my $skipcallers = 2;

   my $class = PApp::Exception::;

   ($class, $error)    = ($error,     undef) if UNIVERSAL::isa $error,    PApp::Exception::;
   ($class, $category) = ($category,  undef) if UNIVERSAL::isa $category, PApp::Exception::;

   # fancydie is sometimes called with "foreign" exception objects (e.g. upcalls ;)
   die $error if ref $error;

   while (@_) {
      my $arg = shift;
      my $val = shift;
      if ($arg eq "skipcallers") {
         $skipcallers += $val;
      } elsif ($arg eq "info") {
         push @$info, $val;
      } else {
         $arg{$arg} = $val;
      }
   }

   unless (ref $class or $arg{abridged}) {
      for my $frame (papp_backtrace($skipcallers)) {
         $frame =~ s/  +/ /g;
         $frame = wrap_text $frame, 80;
         $frame =~ s/\n/\n    /g;
         $backtrace .= "$frame\n";
      }
   }

   s/\n+$//g for @$info;

   $class->new(
      ref $class ? () : (backtrace => $backtrace),
      category  => $category,
      error     => $error,
      info      => $info,
      %arg,
   );
}

sub fancydie {
   &_fancyerr->throw;
}

sub fancywarn {
   warn &_fancyerr;
}


sub try(&;$@) {
   my @r = eval {
      local $SIG{__DIE__} = \&diehandler;
      &{+shift};
   };
   if ($@) {
      die if UNIVERSAL::isa $@, PApp::Upcall::;
      my $err = shift;
      fancydie $err, $@, @_;
   }
   wantarray ? @r : $r[-1];
}

sub catch(&;%) {
   fancydie "catch not yet implemented";
}


sub _clone {
   eval {
      local $SIG{__DIE__};
      require PApp::Storable; # should use Clone some day
      local $Storable::forgive_me = 1;
      PApp::Storable::dclone($_[0]);
   } || "$_[1]: $@";
}

sub _clone_request {
   my $r = $PApp::request;
   local $SIG{__DIE__};
   +{
      eval {
         time        => time,
         method      => $r->method,
         protocol    => $r->protocol,
         hostname    => $r->hostname,
         uri         => $r->uri,
         filename    => $r->filename,
         path_info   => $r->path_info,
         args        => $r->query_string,
         headers_in  => { $r->headers_in },
         remote_logname => $r->get_remote_logname,
         remote_addr => $r->connection->remote_addr,
         local_addr  => $r->connection->local_addr,
         http_user   => $r->connection->user,
         http_auth   => $r->connection->auth_type,
      }
   }
}

sub errorpage {
   package PApp;

   my $self = shift;
   my $onerr = exists $papp->{onerr} ? $papp->{onerr} : $PApp::onerr;
   my @html;

   $self->{save} = {
      misc      => {
         NOW       => $NOW,
         onerr     => $onerr,
      },

      state     => {
         arguments   => PApp::Exception::_clone(\%arguments, "unable to clone arguments"),
         params      => PApp::Exception::_clone(\%P,         "unable to clone params"),
         state       => PApp::Exception::_clone(\%state,     "unable to clone state"),
         userid      => $userid,
         sessionid   => $sessionid,
         stateid     => $stateid,
         prevstateid => $prevstateid,
         alternative => $alternative,
      },

      app       => {
         curpath     => $curpath,
         curprfx     => $curprfx,
         module      => \%module,
         modules     => $modules,
         langs       => $langs,
      },

      output    => {
         content_type   => $content_type,
         output_charset => $output_charset,
         output_p       => $output_p,
         output         => $output,
         routput        => $$routput,
         doutput        => $doutput,
      },

      protocol => {
         location    => $location,
         pathinfo    => $pathinfo,
         request     => PApp::Exception::_clone_request,
      },
   };

   if ($self->{as_string}) {
      content_type("text/plain", "*");

      $PApp::output = $self->as_string;
   } else {
      content_type("text/html", "*");

      $onerr ||= "sha";

      push @html, $self->ep_save      if $onerr =~ /s/i;
      push @html, $self->ep_shortinfo if $onerr =~ /h/i;
      push @html, $self->ep_fullinfo  if $onerr =~ /v/i;
      push @html, $self->ep_login     if $onerr =~ /a/i;

      $PApp::output = $self->ep_wrap (@html);
   }
}

sub ep_save {
   my $self = shift;
   my $id;
   local $SIG{__DIE__};

   eval {
      require PApp::SQL;
      require PApp::Config;
      require Compress::LZF;

      $id = PApp::SQL::sql_insertid (
               PApp::SQL::sql_exec (
                  PApp::Config::DBH,
                  "insert into error values (NULL, NULL, ?, '')",
                  Compress::LZF::sfreeze_cr ($self)
               )
            );
   } || __"[unable to save error information: $@]";

   eval {
      require PApp::HTML;
      my $surl = $PApp::papp_main->surl("error", -set_comment => 1, -id => $id);

      my $output = "<form method='GET' action='$surl'>";
      $output .= sprintf __"saved as error report #%d", $id;

      $output .= "<br />".__"please enter a short description, this will help us fix the problem. thanks. ";
      $output .= "<br /><input type='text' name='comment' size='40' /> ";
      $output .= "</form>";
      $output .= "<hr /><a href='$surl'>".(__"[Login/View this error]")."</a>";

      $output;
   } || __"[unable to enter error browser: $@]";
}

sub ep_shortinfo {
   my $self = shift;
   $self->category;
}

sub ep_fullinfo {
   my $self = shift;
   $self->_as_html;
}

sub ep_login {
   my $self = shift;
   local $SIG{__DIE__};
   eval {
      $PApp::papp_main->slink(__"[Login/View this error]", "error", -exception => $self);
   } or __"[unable to enter error browser at this time]";
}

sub ep_wrap {
   my $self = shift;
   my $title = sprintf __"%s (exception caught)", $self->title;
   "<html>
        <head>
        <title>$title</title>
        </head>
        <body bgcolor=\"#d0d0d0\">
        <blockquote>
        <h1>$title</h1>".
   (join "", map "<p>$_</p>", @_).
   "</blockquote></body></html>";
}

1;