File Coverage

blib/lib/Limper/Engine/PSGI.pm
Criterion Covered Total %
statement 37 38 97.3
branch 4 8 50.0
condition n/a
subroutine 5 5 100.0
pod 0 1 0.0
total 46 52 88.4


line stmt bran cond sub pod time code
1             package Limper::Engine::PSGI;
2             $Limper::Engine::PSGI::VERSION = '0.001';
3 2     2   16088 use base 'Limper';
  2         3  
  2         1021  
4 2     2   41063 use 5.10.0;
  2         4  
  2         57  
5 2     2   14 use strict;
  2         3  
  2         51  
6 2     2   8 use warnings;
  2         2  
  2         966  
7              
8             package Limper;
9             $Limper::VERSION = '0.001';
10             sub get_psgi {
11 3     3 0 4 my ($env) = @_;
12              
13 3         5 delete response->{$_} for keys %{&response};
  3         8  
14 3         27 response->{headers} = [];
15              
16 3         10 delete request->{$_} for keys %{&request};
  3         8  
17 3         46 request->{method} = $env->{REQUEST_METHOD};
18 3         13 request->{uri} = $env->{REQUEST_URI};
19 3         14 request->{version} = $env->{SERVER_PROTOCOL};
20 3         13 request->{remote_host} = $env->{REMOTE_HOST};
21 3         12 request->{headers} = [];
22 3         13 request->{hheaders} = {};
23              
24 3 50       18 push @{request->{headers}}, 'content-length', $env->{CONTENT_LENGTH} if exists $env->{CONTENT_LENGTH};
  3         6  
25 3 50       20 push @{request->{headers}}, 'content-type', $env->{CONTENT_TYPE} if exists $env->{CONTENT_TYPE};
  0         0  
26 3         16 for my $header (grep { /^HTTP_/ } keys %$env) {
  66         80  
27 3         8 my $name = lc $header;
28 3         8 $name =~ s/^http_//;
29 3         6 $name =~ s/_/-/g;
30 3         12 my @values = split /, /, $env->{$header};
31 3         5 push @{request->{headers}}, $name, $_ for @values;
  3         6  
32 3 50       22 request->{hheaders}{$name} = @values > 1 ? \@values : $values[0];
33             }
34             # this covers both requests with Content-Length: and Tranfer-Encoding: chunked
35 3 50       29 $env->{'psgi.input'}->read(request->{body}, $env->{CONTENT_LENGTH}) if exists $env->{CONTENT_LENGTH};
36             }
37              
38             hook request_handler => sub {
39             eval {
40             get_psgi @_;
41             $_ = handle_request;
42             };
43             return $_ unless $@;
44             warning $@;
45             status 500;
46             response->{body} = options->{debug} // 0 ? $@ : 'Internal Server Error';
47             send_response;
48             };
49              
50             hook response_handler => sub {
51             [
52             response->{status},
53             response->{headers},
54             defined response->{body} ? (ref response->{body} ? response->{body} : [response->{body}]) : [],
55             ];
56             };
57              
58             1;
59              
60             =for Pod::Coverage get_psgi
61              
62             =head1 NAME
63              
64             Limper::Engine::PSGI - PSGI engine for Limper
65              
66             =head1 VERSION
67              
68             version 0.001
69              
70             =head1 SYNOPSIS
71              
72             use Limper::Engine::PSGI; # all you need to do is add this line
73             use Limper; # this must come after all extensions
74              
75             # routes and whatnot
76              
77             limp;
78              
79             =head1 DESCRIPTION
80              
81             B extends L to use L instead of the built-in web
82             server.
83              
84             All you need to do in order to use L is add C
85             somewhere before C in your app.
86              
87             This package sets a B and B for
88             L, as well as defining a non-exportable sub that turns a PSGI
89             request into one that B understands.
90              
91             Note that unlike other hooks, only the first B and
92             B is used, so care should be taken to load this first and
93             not load something else that also expects to make use of these 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