File Coverage

blib/lib/CGI/ExceptionManager/StackTrace.pm

Criterion	Covered	Total	%
statement	58	58	100.0
branch	19	24	79.1
condition	4	8	50.0
subroutine	8	8	100.0
pod	0	3	0.0
total	89	101	88.1

package CGI::ExceptionManager::StackTrace;
use strict;
use warnings;

# from MENTA and NanoA

sub _escape_html {
    my $str = shift;
    $str =~ s/&/&/g;
    $str =~ s/>/>/g;
    $str =~ s/
    $str =~ s/"/"/g;
    $str =~ s/'/'/g;
    return $str;
}

sub new {
    my ($klass, $message) = @_;
    my @trace;

    for (my $i = 1; my ($package, $file, $line) = caller($i); $i++) {
        push @trace, {
            file => $file,
            line => $line,
            func => undef,
        };
        if (my @c = caller($i + 1)) {
            $trace[-1]->{func} = $c[3]
                if $c[3];
        }
    }
    if ($message =~ / at ([^ ]+) line (\d+)/
            && ($1 ne $trace[0]->{file} || $2 != $trace[0]->{line})) {
        unshift @trace, {
            file => $1,
            line => $2,
        };
    }

    bless {
        message => $message,
        trace   => \@trace,
    }, $klass;
}

sub _build_context {
    my ($file, $linenum) = @_;
    my $code;
    if (-f $file) {
        my $start = $linenum - 3;
        my $end   = $linenum + 3;
        $start = $start < 1 ? 1 : $start;
        open my $fh, '<:encoding(utf8)', $file
            or die "cannot open $file:$!";
        my $cur_line = 0;
        while (my $line = <$fh>) {
            ++$cur_line;
            last if $cur_line > $end;
            next if $cur_line < $start;
            $line =~ s|\t|        |g;
            my @tag = $cur_line == $linenum
                ? (q{}, '')
                    : ('', '');
            $code .= sprintf(
                '%s%5d: %s%s', $tag[0], $cur_line, _escape_html($line),
                $tag[1],
            );
        }
        close $file;
    }
    return $code;
}

sub as_html {
    my ($err, %args) = @_;
    my $msg = _escape_html($err->{message});
    my $out = qq{500 Internal Server Errorbody { margin: 0; padding: 0; background: rgb(230, 230, 230); color: rgb(44, 44, 44); } h1 { margin: 0 0 .5em; padding: .25em .5em .1em 1.5em; border-bottom: thick solid rgb(0, 0, 15); background: rgb(63, 63, 63); color: rgb(239, 239, 239); font-size: x-large; } p { margin: .5em 1em; } li { font-size: small; } pre { background: rgb(255, 239, 239); color: rgb(47, 47, 47); font-size: medium; } pre code strong { color: rgb(0, 0, 0); background: rgb(255, 143, 143); } p.f { text-align: right; font-size: xx-small; } p.f span { font-size: medium; }500 Internal Server Error${msg}};
    for my $stack (@{$err->{trace}}) {
        $out .= join(
            '',
            '',
            $stack->{func} ? _escape_html("in $stack->{func}") : '',
            ' at ',
            $stack->{file} ? _escape_html($stack->{file}) : '',
            ' line ',
            $stack->{line},
            q(),
            _build_context($stack->{file}, $stack->{line}) || '',
            q(),
        );
    }
    $out .= qq{Powered by $args{powered_by}};
    $out;
}

sub output {
    my ($err, %args) = @_;

    warn $err->{message};

    print "Status: 500\r\n";
    print "Content-type: text/html; charset=utf-8\r\n";
    print "\r\n";

    my $body = $args{renderer} ? $args{renderer}->($err, %args) : $err->as_html(%args);
    utf8::encode($body);
    print $body;
}

1;