view release on metacpan or  search on metacpan

local/lib/perl5/Plack/Middleware/StackTrace.pm  view on Meta::CPAN

package Plack::Middleware::StackTrace;
use strict;
use warnings;
use parent qw/Plack::Middleware/;
use Devel::StackTrace;
use Devel::StackTrace::AsHTML;
use Scalar::Util qw( refaddr );
use Try::Tiny;
use Plack::Util::Accessor qw( force no_print_errors );

our $StackTraceClass = "Devel::StackTrace";

# Optional since it needs PadWalker
if (try { require Devel::StackTrace::WithLexicals; Devel::StackTrace::WithLexicals->VERSION(0.08); 1 }) {
    $StackTraceClass = "Devel::StackTrace::WithLexicals";
}

sub call {
    my($self, $env) = @_;

    my ($trace, %string_traces, %ref_traces);
    local $SIG{__DIE__} = sub {
        $trace = $StackTraceClass->new(
            indent => 1, message => munge_error($_[0], [ caller ]),
            ignore_package => __PACKAGE__, no_refs => 1,
        );
        if (ref $_[0]) {
            $ref_traces{refaddr($_[0])} ||= $trace;
        }
        else {
            $string_traces{$_[0]} ||= $trace;
        }
        die @_;
    };

    my $caught;
    my $res = try {
        $self->app->($env);
    } catch {
        $caught = $_;
        [ 500, [ "Content-Type", "text/plain; charset=utf-8" ], [ no_trace_error(utf8_safe($caught)) ] ];
    };

    if ($caught) {
        # Try to find the correct trace for the caught exception
        my $caught_trace;
        if (ref $caught) {
            $caught_trace = $ref_traces{refaddr($caught)};
        }
        else {
            # This is not guaranteed to work if multiple exceptions with
            # the same message are thrown.
            $caught_trace = $string_traces{$caught};
        }
        $trace = $caught_trace if $caught_trace;
    }

    if ($trace && ($caught || ($self->force && ref $res eq 'ARRAY' && $res->[0] == 500)) ) {
        my $text = $trace->as_string;
        my $html = $trace->as_html;
        $env->{'plack.stacktrace.text'} = $text;
        $env->{'plack.stacktrace.html'} = $html;
        $env->{'psgi.errors'}->print($text) unless $self->no_print_errors;
        if (($env->{HTTP_ACCEPT} || '*/*') =~ /html/) {
            $res = [500, ['Content-Type' => 'text/html; charset=utf-8'], [ utf8_safe($html) ]];
        } else {
            $res = [500, ['Content-Type' => 'text/plain; charset=utf-8'], [ utf8_safe($text) ]];
        }
    }

    # break $trace here since $SIG{__DIE__} holds the ref to it, and
    # $trace has refs to Standalone.pm's args ($conn etc.) and
    # prevents garbage collection to be happening.