/usr/share/perl5/Devel/StackTrace/AsHTML.pm

package Devel::StackTrace::AsHTML;

use strict;
use 5.008_001;
our $VERSION = '0.15';

use Data::Dumper;
use Devel::StackTrace;
use Scalar::Util;

no warnings 'qw';
my %enc = qw( & &amp; > &gt; < &lt; " &quot; ' &#39; );

# NOTE: because we don't know which encoding $str is in, or even if
# $str is a wide character (decoded strings), we just leave the low
# bits, including latin-1 range and encode everything higher as HTML
# entities. I know this is NOT always correct, but should mostly work
# in case $str is encoded in utf-8 bytes or wide chars. This is a
# necessary workaround since we're rendering someone else's code which
# we can't enforce string encodings.

sub encode_html {
    my $str = shift;
    $str =~ s/([^\x00-\x21\x23-\x25\x28-\x3b\x3d\x3f-\xff])/$enc{$1} || '&#' . ord($1) . ';' /ge;
    utf8::downgrade($str);
    $str;
}

sub Devel::StackTrace::as_html {
    __PACKAGE__->render(@_);
}

sub render {
    my $class = shift;
    my $trace = shift;
    my %opt   = @_;

    my $msg = encode_html($trace->frame(0)->as_string(1));
    my $out = qq{<!doctype html><head><title>Error: ${msg}</title>};

    $opt{style} ||= \<<STYLE;
a.toggle { color: #444 }
body { margin: 0; padding: 0; background: #fff; color: #000; }
h1 { margin: 0 0 .5em; padding: .25em .5em .1em 1.5em; border-bottom: thick solid #002; background: #444; color: #eee; font-size: x-large; }
pre.message { margin: .5em 1em; }
li.frame { font-size: small; margin-top: 3em }
li.frame:nth-child(1) { margin-top: 0 }
pre.context { border: 1px solid #aaa; padding: 0.2em 0; background: #fff; color: #444; font-size: medium; }
pre .match { color: #000;background-color: #f99; font-weight: bold }
pre.vardump { margin:0 }
pre code strong { color: #000; background: #f88; }

table.lexicals, table.arguments { border-collapse: collapse }
table.lexicals td, table.arguments td { border: 1px solid #000; margin: 0; padding: .3em }
table.lexicals tr:nth-child(2n) { background: #DDDDFF }
table.arguments tr:nth-child(2n) { background: #DDFFDD }
.lexicals, .arguments { display: none }
.variable, .value { font-family: monospace; white-space: pre }
td.variable { vertical-align: top }
STYLE

    if (ref $opt{style}) {
        $out .= qq(<style type="text/css">${$opt{style}}</style>);
    } else {
        $out .= qq(<link rel="stylesheet" type="text/css" href=") . encode_html($opt{style}) . q(" />);
    }

    $out .= <<HEAD;
<script language="JavaScript" type="text/javascript">
function toggleThing(ref, type, hideMsg, showMsg) {
 var css = document.getElementById(type+'-'+ref).style;
 css.display = css.display == 'block' ? 'none' : 'block';

 var hyperlink = document.getElementById('toggle-'+ref);
 hyperlink.textContent = css.display == 'block' ? hideMsg : showMsg;
}

function toggleArguments(ref) {
 toggleThing(ref, 'arguments', 'Hide function arguments', 'Show function arguments');
}

function toggleLexicals(ref) {
 toggleThing(ref, 'lexicals', 'Hide lexical variables', 'Show lexical variables');
}
</script>
</head>
<body>
<h1>Error trace</h1><pre class="message">$msg</pre><ol>
HEAD

    my $i = 0;
    while (my $frame = $trace->next_frame) {
        $i++;
        my $next_frame = $trace->frame($i); # peek next
        $out .= join(
            '',
            '<li class="frame">',
            ($next_frame && $next_frame->subroutine) ? encode_html("in " . $next_frame->subroutine) : '',
            ' at ',
            $frame->filename ? encode_html($frame->filename) : '',
            ' line ',
            $frame->line,
            q(<pre class="context"><code>),
            _build_context($frame) || '',
            q(</code></pre>),
            _build_arguments($i, $next_frame),
            $frame->can('lexicals') ? _build_lexicals($i, $frame->lexicals) : '',
            q(</li>),
        );
    }
    $out .= qq{</ol>};
    $out .= "</body></html>";

    $out;
}

my $dumper = sub {
    my $value = shift;
    $value = $$value if ref $value eq 'SCALAR' or ref $value eq 'REF';
    my $d = Data::Dumper->new([ $value ]);
    $d->Indent(1)->Terse(1)->Deparse(1);
    chomp(my $dump = $d->Dump);
    $dump;
};

sub _build_arguments {
    my($id, $frame) = @_;
    my $ref = "arg-$id";

    return '' unless $frame && $frame->args;

    my @args = $frame->args;

    my $html = qq(<p><a class="toggle" id="toggle-$ref" href="javascript:toggleArguments('$ref')">Show function arguments</a></p><table class="arguments" id="arguments-$ref">);

    # Don't use while each since Dumper confuses that
    for my $idx (0 .. @args - 1) {
        my $value = $args[$idx];
        my $dump = $dumper->($value);
        $html .= qq{<tr>};
        $html .= qq{<td class="variable">\$_[$idx]</td>};
        $html .= qq{<td class="value">} . encode_html($dump) . qq{</td>};
        $html .= qq{</tr>};
    }
    $html .= qq(</table>);

    return $html;
}

sub _build_lexicals {
    my($id, $lexicals) = @_;
    my $ref = "lex-$id";

    return '' unless keys %$lexicals;

    my $html = qq(<p><a class="toggle" id="toggle-$ref" href="javascript:toggleLexicals('$ref')">Show lexical variables</a></p><table class="lexicals" id="lexicals-$ref">);

    # Don't use while each since Dumper confuses that
    for my $var (sort keys %$lexicals) {
        my $value = $lexicals->{$var};
        my $dump = $dumper->($value);
        $dump =~ s/^\{(.*)\}$/($1)/s if $var =~ /^\%/;
        $dump =~ s/^\[(.*)\]$/($1)/s if $var =~ /^\@/;
        $html .= qq{<tr>};
        $html .= qq{<td class="variable">} . encode_html($var)  . qq{</td>};
        $html .= qq{<td class="value">}    . encode_html($dump) . qq{</td>};
        $html .= qq{</tr>};
    }
    $html .= qq(</table>);

    return $html;
}

sub _build_context {
    my $frame = shift;
    my $file    = $frame->filename;
    my $linenum = $frame->line;
    my $code;
    if (-f $file) {
        my $start = $linenum - 3;
        my $end   = $linenum + 3;
        $start = $start < 1 ? 1 : $start;
        open my $fh, '<', $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{<strong class="match">}, '</strong>')
                    : ('', '');
            $code .= sprintf(
                '%s%5d: %s%s', $tag[0], $cur_line, encode_html($line),
                $tag[1],
            );
        }
        close $file;
    }
    return $code;
}

1;
__END__

=encoding utf-8

=for stopwords

=head1 NAME

Devel::StackTrace::AsHTML - Displays stack trace in HTML

=head1 SYNOPSIS

  use Devel::StackTrace::AsHTML;

  my $trace = Devel::StackTrace->new;
  my $html  = $trace->as_html;

=head1 DESCRIPTION

Devel::StackTrace::AsHTML adds C<as_html> method to L<Devel::StackTrace> which
displays the stack trace in beautiful HTML, with code snippet context and
function parameters. If you call it on an instance of
L<Devel::StackTrace::WithLexicals>, you even get to see the lexical variables
of each stack frame.

=head1 AUTHOR

Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>

Shawn M Moore

HTML generation code is ripped off from L<CGI::ExceptionManager> written by Tokuhiro Matsuno and Kazuho Oku.

=head1 COPYRIGHT

The following copyright notice applies to all the files provided in
this distribution, including binary files, unless explicitly noted
otherwise.

Copyright 2009-2013 Tatsuhiko Miyagawa

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<Devel::StackTrace> L<Devel::StackTrace::WithLexicals> L<CGI::ExceptionManager>

=cut
libdevel-stacktrace-ashtml-perl 0.15-1 / usr / share / perl5 / Devel / StackTrace / AsHTML.pm
