view release on metacpan or  search on metacpan

plugins/error_xml  view on Meta::CPAN

sub init {
    $SIG{__DIE__} = sub { die AxKit2::StructuredError->new($_[0]) };
}

sub hook_error {
    my $self = shift;
    my $error = shift;
    
    $self->log(LOGDEBUG, "Turning error into XML");
    
    if ($self->config('StackTraceLog')) {
        $self->log(LOGERROR, $error->to_string(1));
    }
    my $with_trace = $self->config('StackTrace');
    my $xml = $error->to_xml($with_trace);
    
    my $stylesheet = $self->config('ErrorStylesheet');
    if (!$stylesheet) {
        $self->log(LOGERROR, "Need an ErrorStylesheet to transform the XML");
        $self->log(LOGERROR, $xml);
        return DECLINED;
    }
    
    my $input = AxKit2::Processor->new($self->client, $self->client->headers_in->filename);
    $input->dom($xml);
    
    my $out = $input->transform(XSLT($stylesheet));
    
    $out->output();
    
    return OK;
}

package AxKit2::StructuredError;

use AxKit2::Utils qw(xml_escape);

use overload
    '""'   => \&to_string,
    'bool' => sub { 1 };

sub new {
    my $class = shift;
    my $err = shift;
    return bless { error => $err, stacktrace => _stack_trace() }, $class;
}

sub to_string {
    my $self = shift;
    my $with_stack = shift;
    return $self->{error} unless $with_stack;
    return join("\n", $self->{error}, map { "    from $_->[1]:$_->[2]" } @{$self->{stacktrace}});
}

sub _stack_trace {
    my @stack;
    my $pos = 2;
    while (1) {
        # $package, $filename, $line, $subroutine, $hasargs,
        # $wantarray, $evaltext, $is_require, $hints, $bitmask
        my @caller = caller($pos++);
        last unless @caller;
        push @stack, \@caller;
    }
    return \@stack;
}

# <error>
# 	<file>filename</file>
# 	<msg>error message</msg>
# 	<stack_trace>
# 		<bt level="0">
# 			<file>filename</file>
# 			<line>line number</line>
# 		</bt>
# 		<bt level="2">
# 		<!--etc-->
# 		</bt>
# 	</stack_trace>
# </error>

sub to_xml {
    my $self = shift;
    my $with_stack = shift;
    
    my $stack = $self->{stacktrace};
    my $msg = $self->{error};
    my $xml = "<error>\n<file>" . xml_escape($stack->[0]->[1]) . "</file>\n";
    $xml   .= "<msg>" . xml_escape($msg) . "</msg>\n";
    
    if ($with_stack) {
        $xml .= "<stack_trace>\n";
        my $level = 0;
        for my $stack_data (@$stack) {
            $xml .= "<bt level='$level'>\n";
            $xml .= "  <package>" . xml_escape($stack_data->[0]) . "</package>\n";
            $xml .= "  <file>" . xml_escape($stack_data->[1]) . "</file>\n";
            $xml .= "  <line>" . xml_escape($stack_data->[2]) . "</line>\n";
            $xml .= "  <subroutine>" . xml_escape($stack_data->[3]) . "(...)</subroutine>\n";
            $xml .= "</bt>\n";
            $level++;
        }
        $xml .= "</stack_trace>\n";
    }
    
    $xml .= "</error>\n";
    return $xml;
}