File Coverage

blib/lib/Limper/Engine/PSGI.pm
Criterion Covered Total %
statement 33 33 100.0
branch 4 8 50.0
condition n/a
subroutine 5 5 100.0
pod 0 1 0.0
total 42 47 89.3


line stmt bran cond sub pod time code
1             package Limper::Engine::PSGI;
2             $Limper::Engine::PSGI::VERSION = '0.002';
3 2     2   30206 use base 'Limper';
  2         5  
  2         1927  
4 2     2   78735 use 5.10.0;
  2         8  
  2         139  
5 2     2   31 use strict;
  2         4  
  2         113  
6 2     2   16 use warnings;
  2         2  
  2         1746  
7              
8             package # newline because Dist::Zilla::Plugin::PkgVersion and PAUSE indexer
9             Limper;
10              
11             sub get_psgi {
12 3     3 0 5 my ($env) = @_;
13              
14 3         2 delete response->{$_} for keys %{&response};
  3         10  
15 3         27 response->{headers} = {};
16              
17 3         10 delete request->{$_} for keys %{&request};
  3         4  
18 3         38 request->{method} = $env->{REQUEST_METHOD};
19 3         12 request->{uri} = $env->{REQUEST_URI};
20 3         9 request->{version} = $env->{SERVER_PROTOCOL};
21 3         10 request->{remote_host} = $env->{REMOTE_HOST};
22 3         10 request->{headers} = {};
23              
24 3 50       15 request->{headers}{'content-length'} = $env->{CONTENT_LENGTH} if exists $env->{CONTENT_LENGTH};
25 3 50       12 request->{headers}{'content-type'} = $env->{CONTENT_TYPE} if exists $env->{CONTENT_TYPE};
26 3         13 for my $header (grep { /^HTTP_/ } keys %$env) {
  66         56  
27 3         4 my $name = lc $header;
28 3         9 $name =~ s/^http_//;
29 3         4 $name =~ s/_/-/g;
30 3         11 my @values = split /, /, $env->{$header};
31 3 50       11 request->{headers}{$name} = @values > 1 ? \@values : $values[0];
32             }
33             # this covers both requests with Content-Length: and Tranfer-Encoding: chunked
34 3 50       25 $env->{'psgi.input'}->read(request->{body}, $env->{CONTENT_LENGTH}) if exists $env->{CONTENT_LENGTH};
35             }
36              
37             hook request_handler => sub {
38             eval {
39             get_psgi @_;
40             $_ = handle_request;
41             };
42             return $_ unless $@;
43             warning $@;
44             status 500;
45             response->{body} = options->{debug} // 0 ? $@ : 'Internal Server Error';
46             send_response;
47             };
48              
49             hook response_handler => sub {
50             [
51             response->{status},
52             [ headers ],
53             defined response->{body} ? (ref response->{body} ? response->{body} : [response->{body}]) : [],
54             ];
55             };
56              
57             1;
58              
59             =for Pod::Coverage get_psgi
60              
61             =head1 NAME
62              
63             Limper::Engine::PSGI - PSGI engine for Limper
64              
65             =head1 VERSION
66              
67             version 0.002
68              
69             =head1 SYNOPSIS
70              
71             use Limper::Engine::PSGI; # all you need to do is add this line
72             use Limper; # this must come after all extensions
73              
74             # routes and whatnot
75              
76             limp;
77              
78             =head1 DESCRIPTION
79              
80             B extends L to use L instead of the built-in web
81             server.
82              
83             All you need to do in order to use L is add C
84             somewhere before C in your app.
85              
86             This package sets a B and B for
87             L, as well as defining a non-exportable sub that turns a PSGI
88             request into one that B understands.
89              
90             Note that unlike other hooks, only the first B and
91             B is used, so care should be taken to load this first and
92             not load another B that also expects to make use of these
93             hooks.
94              
95             =head1 EXPORTS
96              
97             Nothing additional is exported.
98              
99             =head1 COPYRIGHT AND LICENSE
100              
101             Copyright (C) 2014 by Ashley Willis Eashley+perl@gitable.orgE
102              
103             This library is free software; you can redistribute it and/or modify
104             it under the same terms as Perl itself, either Perl version 5.12.4 or,
105             at your option, any later version of Perl 5 you may have available.
106              
107             =head1 SEE ALSO
108              
109             L
110              
111             L
112              
113             L
114              
115             L
116              
117             L
118              
119             L
120              
121             L
122              
123             =cut