Plack::Middleware::Debug::StackTrace

StackTrace.pm

package Plack::Middleware::Debug::StackTrace;
use strict;
use parent qw/Plack::Middleware::Debug::Base/;
use Devel::StackTrace;
use Data::Dump::Streamer;
our $VERSION = '0.01';

our $StackTraceClass = "Devel::StackTrace";
# Optional since it needs PadWalker
eval {
    require Devel::StackTrace::WithLexicals;
    Devel::StackTrace::WithLexicals->VERSION(0.08);
};
unless ($@) {
    $StackTraceClass = "Devel::StackTrace::WithLexicals";
}

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 run {
    my($self, $env, $panel) = @_;

    return sub {
        my $res = shift;

        my $trace = $StackTraceClass->new(
            indent  => 1,
            message => [ caller ],
            ignore_package => __PACKAGE__,
        );

        my $string = '';
        my $i = 0;
        while (my $frame = $trace->next_frame) {
            $i++;
            my $package    = $frame->package ? $frame->package : '';
            my $subroutine = $frame->subroutine ? ('in '.$frame->subroutine) : '';
            my $file       = $frame->filename ? $frame->filename : '';
            my $line_num   = $frame->line;
            my $context    = _build_context($frame);
            my $source     = _get_source($frame);
            $string .= <<"_TXT_";
$i. $package
$subroutine
$file line $line_num
# $context
$source
--------------------------------------------------
_TXT_
        }

        $panel->nav_subtitle('StackTrace');
        $panel->content(
            $self->render_lines($string)
        );
    };
}

sub _get_source {
    my $frame = shift;
    my $subroutine = $frame->subroutine || return;
    my $source = '';

    my $coderef = do {
        no strict 'refs';
        my ($package, $method) = $subroutine =~ /^(.+)::(.+?)$/o;
        $method ? $package->can($method) : undef;
    };
    if ($coderef) {
        my $_source .= Data::Dump::Streamer::Dumper($coderef);
            print STDERR $_source =~ s/ {2}/　/og; # readability on html
            print STDERR "\n";
        $source .= $_source;
    }

    return $source;
}

sub _build_context {
    my $frame = shift;

    my $file    = $frame->filename;
    my $linenum = $frame->line;
    my $code    = '';
    if (-f $file) {
        open my $fh, '<', $file
            or die "cannot open $file:$!";
        my $cur_line = 0;
        while (my $line = <$fh>) {
            ++$cur_line;
            if ($cur_line == $linenum) {
                $code = $line;
                last;
            }
        }
        close $file;
    }
    return $code;
}

1;

__END__

=head1 NAME

Plack::Middleware::Debug::StackTrace - put StackTrace on the debug panel for Plack


=head1 SYNOPSIS

    use Plack::Builder;
    builder {
      enable 'Debug::StackTrace';
      $app;
    };


=head1 DESCRIPTION

You can check StackTrace every request by this middleware.


=head1 REPOSITORY

Plack::Middleware::Debug::StackTrace is hosted on github
<http://github.com/bayashi/Plack-Middleware-Debug-StackTrace>


=head1 AUTHOR

Dai Okabayashi E<lt>[email protected]<gt>


=head1 SEE ALSO

L<Plack::Middleware::Debug>

This module's code was stolen from L<Devel::StackTrace> or L<Devel::StackTrace::AsHTML>


=head1 LICENSE

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.

=cut