CGI-ExceptionManager
1 match

 view release on metacpan or  search on metacpan

lib/CGI/ExceptionManager/StackTrace.pm  view on Meta::CPAN 

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/</&lt;/g;
    $str =~ s/"/&quot;/g;
    $str =~ s/'/&#39;/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{<b style="color: #000;background-color: #f99;">}, '</b>')
                    : ('', '');
            $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{<!doctype html><head><title>500 Internal Server Error</title><style type="text/css">body { 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...
    for my $stack (@{$err->{trace}}) {
        $out .= join(
            '',
            '<li>',
            $stack->{func} ? _escape_html("in $stack->{func}") : '',
            ' at ',
            $stack->{file} ? _escape_html($stack->{file}) : '',
            ' line ',
            $stack->{line},
            q(<pre><code>),



( run in 0.854 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )