File Coverage

blib/lib/Plack/Middleware/HTTPExceptions.pm
Criterion Covered Total %
statement 53 58 91.3
branch 14 20 70.0
condition 9 14 64.2
subroutine 13 13 100.0
pod 2 3 66.6
total 91 108 84.2


line stmt bran cond sub pod time code
1             package Plack::Middleware::HTTPExceptions;
2 2     2   189643 use strict;
  2         6  
  2         67  
3 2     2   15 use parent qw(Plack::Middleware);
  2         4  
  2         17  
4 2     2   94 use Plack::Util::Accessor qw(rethrow);
  2         3  
  2         6  
5              
6 2     2   11 use Carp ();
  2         4  
  2         30  
7 2     2   1145 use Try::Tiny;
  2         4180  
  2         112  
8 2     2   16 use Scalar::Util 'blessed';
  2         3  
  2         76  
9 2     2   972 use HTTP::Status ();
  2         9707  
  2         955  
10              
11             sub prepare_app {
12 2     2 1 5 my $self = shift;
13 2 50 50     21 $self->rethrow(1) if ($ENV{PLACK_ENV} || '') eq 'development';
14             }
15              
16             sub call {
17 7     7 1 18 my($self, $env) = @_;
18              
19             my $res = try {
20 7     7   312 $self->app->($env);
21             } catch {
22 4     4   254 $self->transform_error($_, $env);
23 7         52 };
24              
25 7 100       135 return $res if ref $res eq 'ARRAY';
26              
27             return sub {
28 3     3   7 my $respond = shift;
29              
30 3         3 my $writer;
31             try {
32 3         142 $res->(sub { return $writer = $respond->(@_) });
  1         8  
33             } catch {
34 2 50       83 if ($writer) {
35 0         0 Carp::cluck $_;
36 0         0 $writer->close;
37             } else {
38 2         9 my $res = $self->transform_error($_, $env);
39 2         7 $respond->($res);
40             }
41 3         18 };
42 3         23 };
43             }
44              
45             sub transform_error {
46 6     6 0 18 my($self, $e, $env) = @_;
47              
48 6         12 my($code, $message);
49 6 50 66     73 if (blessed $e && $e->can('as_psgi')) {
50 0         0 return $e->as_psgi;
51             }
52 6 100 66     42 if (blessed $e && $e->can('code')) {
53 5         20 $code = $e->code;
54 5 50       55 $message =
    100          
55             $e->can('as_string') ? $e->as_string :
56             overload::Method($e, '""') ? "$e" : undef;
57             } else {
58 1 50       4 if ($self->rethrow) {
59 0         0 die $e;
60             }
61             else {
62 1         2 $code = 500;
63 1         18 $env->{'psgi.errors'}->print($e);
64             }
65             }
66              
67 6 50       265 if ($code !~ /^[3-5]\d\d$/) {
68 0         0 die $e; # rethrow
69             }
70              
71 6   66     38 $message ||= HTTP::Status::status_message($code);
72              
73 6         43 my @headers = (
74             'Content-Type' => 'text/plain',
75             'Content-Length' => length($message),
76             );
77              
78 6 100 66     21 if ($code =~ /^3/ && (my $loc = eval { $e->location })) {
  1         5  
79 1         7 push(@headers, Location => $loc);
80             }
81              
82 6         45 return [ $code, \@headers, [ $message ] ];
83             }
84              
85             1;
86              
87             __END__