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