########################################################################## ## 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. ## ########################################################################## =head1 NAME PApp::Exception - exception handling for PApp =head1 SYNOPSIS use PApp::Exception; =head1 DESCRIPTION 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. =over 4 =cut package PApp::Exception; use base Exporter; use overload (); use PApp::HTML; use utf8; $VERSION = 2.0; @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, ; =item local $SIG{__DIE__} = \&PApp::Exception::diehandler _diehandler is a function suitable to be put into C<$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; ... }; =cut 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]; } =item $errobj = new PApp::Exception param => value.. Create and return a new exception object. The object is overloaded, stringification will call C. 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). =cut 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; } } =item $errobj->throw Throw the exception. =cut sub throw($) { die $_[0]; } =item $errobj->as_string Return the full exception information as simple text string. =item $errobj->as_html Return the full exception information as a fully formatted html page. =cut 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}; <

$category
$error

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

$title

". $self->_as_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 = <
$category
$error

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 .= "

".__"Additional Info"."$desc:
$info

"; } } if ($self->{backtrace}) { my $backtrace = escape_html $self->{backtrace}; $err .= "

".__"Backtrace".":
$backtrace

"; } if ($body) { $body = wrap_text $body, 80; $err .= <
$body

EOF } $err; } =item fancydie $category, $error, [param => value...] Aborts the current page and displays a fancy error box, complete with backtrace. C<$error> should be a short error message, while C<$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 =item fancywarn Similar to C, but warns only. (not exported by default). =cut # 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 = "" if $f eq "-e"; $w = $w ? '@ = ' : '$ = '; if ($i > $start) { my @a = map { eval { if (tied $_) { "<>"; } elsif (ref) { if (overload::Overloaded $_) { "<>"; } 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], "", "", @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; } =item vals = try BLOCK error, args... C the given block (using a C<_diehandler>, C<@_> 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 C'ed). =item catch BLOCK args... Not yet implemented. If used as an argument to C, execute the block when an error occurs. Example: try { ... code } catch { ... code to be executed when an exception was raised }; =cut 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"; } =item $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. =item $exc->ep_save =item $html = $exc->ep_fullinfo =item $html = $exc->ep_shortinfo =item $html = $exc->ep_login =item $html = $exc->ep_wrap(...) Various parts of the error page that cna be generated independently of the others. =cut 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 => { 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 = "
"; $output .= sprintf __"saved as error report #%d", $id; $output .= "
".__"please enter a short description, this will help us fix the problem. thanks. "; $output .= "
"; $output .= "
"; $output .= "
".(__"[Login/View this error]").""; $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; " $title

$title

". (join "", map "

$_

", @_). "
"; } 1; =back =head1 SEE ALSO L. =head1 AUTHOR Marc Lehmann http://home.schmorp.de/ =cut