File Coverage

blib/lib/Plack/Middleware/StackTrace.pm
Criterion Covered Total %
statement 64 65 98.4
branch 15 18 83.3
condition 11 14 78.5
subroutine 15 15 100.0
pod 1 4 25.0
total 106 116 91.3


line stmt bran cond sub pod time code
1             package Plack::Middleware::StackTrace;
2 8     8   435841 use strict;
  8         102  
  8         248  
3 8     8   43 use warnings;
  8         23  
  8         262  
4 8     8   2884 use parent qw/Plack::Middleware/;
  8         1884  
  8         42  
5 8     8   3987 use Devel::StackTrace;
  8         24180  
  8         235  
6 8     8   3623 use Devel::StackTrace::AsHTML;
  8         64784  
  8         287  
7 8     8   67 use Scalar::Util qw( refaddr );
  8         18  
  8         380  
8 8     8   4288 use Try::Tiny;
  8         16690  
  8         485  
9 8     8   59 use Plack::Util::Accessor qw( force no_print_errors );
  8         15  
  8         57  
10              
11             our $StackTraceClass = "Devel::StackTrace";
12              
13             # Optional since it needs PadWalker
14             if (try { require Devel::StackTrace::WithLexicals; Devel::StackTrace::WithLexicals->VERSION(0.08); 1 }) {
15             $StackTraceClass = "Devel::StackTrace::WithLexicals";
16             }
17              
18             sub call {
19 10     10 1 27 my($self, $env) = @_;
20              
21 10         23 my ($trace, %string_traces, %ref_traces);
22             local $SIG{__DIE__} = sub {
23 14     14   656 $trace = $StackTraceClass->new(
24             indent => 1, message => munge_error($_[0], [ caller ]),
25             ignore_package => __PACKAGE__, no_refs => 1,
26             );
27 14 100       11336 if (ref $_[0]) {
28 4   66     29 $ref_traces{refaddr($_[0])} ||= $trace;
29             }
30             else {
31 10   66     86 $string_traces{$_[0]} ||= $trace;
32             }
33 14         22651 die @_;
34 10         110 };
35              
36 10         23 my $caught;
37             my $res = try {
38 10     10   496 $self->app->($env);
39             } catch {
40 7     7   144 $caught = $_;
41 7         31 [ 500, [ "Content-Type", "text/plain; charset=utf-8" ], [ no_trace_error(utf8_safe($caught)) ] ];
42 10         73 };
43              
44 10 100       182 if ($caught) {
45             # Try to find the correct trace for the caught exception
46 7         24 my $caught_trace;
47 7 100       20 if (ref $caught) {
48 2         7 $caught_trace = $ref_traces{refaddr($caught)};
49             }
50             else {
51             # This is not guaranteed to work if multiple exceptions with
52             # the same message are thrown.
53 5         14 $caught_trace = $string_traces{$caught};
54             }
55 7 50       26 $trace = $caught_trace if $caught_trace;
56             }
57              
58 10 50 100     9492 if ($trace && ($caught || ($self->force && ref $res eq 'ARRAY' && $res->[0] == 500)) ) {
      66        
59 8         9430 my $text = $trace->as_string;
60 8         5399 my $html = $trace->as_html;
61 8         67632 $env->{'plack.stacktrace.text'} = $text;
62 8         22 $env->{'plack.stacktrace.html'} = $html;
63 8 100       33 $env->{'psgi.errors'}->print($text) unless $self->no_print_errors;
64 8 100 100     78 if (($env->{HTTP_ACCEPT} || '*/*') =~ /html/) {
65 1         5 $res = [500, ['Content-Type' => 'text/html; charset=utf-8'], [ utf8_safe($html) ]];
66             } else {
67 7         40 $res = [500, ['Content-Type' => 'text/plain; charset=utf-8'], [ utf8_safe($text) ]];
68             }
69             }
70              
71             # break $trace here since $SIG{__DIE__} holds the ref to it, and
72             # $trace has refs to Standalone.pm's args ($conn etc.) and
73             # prevents garbage collection to be happening.
74 10         36 undef $trace;
75              
76 10         352 return $res;
77             }
78              
79             sub no_trace_error {
80 7     7 0 15 my $msg = shift;
81 7         24 chomp($msg);
82              
83 7         44 return <
84             The application raised the following error:
85              
86             $msg
87              
88             and the StackTrace middleware couldn't catch its stack trace, possibly because your application overrides \$SIG{__DIE__} by itself, preventing the middleware from working correctly. Remove the offending code or module that does it: known examples are CGI::Carp and Carp::Always.
89             EOF
90             }
91              
92             sub munge_error {
93 14     14 0 40 my($err, $caller) = @_;
94 14 100       65 return $err if ref $err;
95              
96             # Ugly hack to remove " at ... line ..." automatically appended by perl
97             # If there's a proper way to do this, please let me know.
98 10         240 $err =~ s/ at \Q$caller->[1]\E line $caller->[2]\.\n$//;
99              
100 10         86 return $err;
101             }
102              
103             sub utf8_safe {
104 15     15 0 31 my $str = shift;
105              
106             # NOTE: I know messing with utf8:: in the code is WRONG, but
107             # because we're running someone else's code that we can't
108             # guarantee which encoding an exception is encoded, there's no
109             # better way than doing this. The latest Devel::StackTrace::AsHTML
110             # (0.08 or later) encodes high-bit chars as HTML entities, so this
111             # path won't be executed.
112 15 50       60 if (utf8::is_utf8($str)) {
113 0         0 utf8::encode($str);
114             }
115              
116 15         53 $str;
117             }
118              
119             1;
120              
121             __END__