File Coverage

blib/lib/MVC/Neaf/Request/PSGI.pm
Criterion Covered Total %
statement 87 88 98.8
branch 15 20 75.0
condition 6 12 50.0
subroutine 26 26 100.0
pod 16 16 100.0
total 150 162 92.5


line stmt bran cond sub pod time code
1             package MVC::Neaf::Request::PSGI;
2              
3 84     84   227542 use strict;
  84         198  
  84         2624  
4 84     84   457 use warnings;
  84         277  
  84         9348  
5             our $VERSION = '0.29';
6              
7             =head1 NAME
8              
9             MVC::Neaf::Request::PSGI - Not Even A Framework: PSGI driver.
10              
11             =head1 METHODS
12              
13             =cut
14              
15             BEGIN {
16             # NOTE HACK prevent 'Can't locate object method seek via package IO::Handle'
17             # try preloading it by hand (errors ignored)
18 84 50   84   700 eval { require FileHandle }
  0         0  
19             if $] < 5.014;
20             # NOTE HACK - prevent load-time warnings from Cookie::Baker
21             # which we aren't even using
22 84         210 eval {
23 84         731 local $SIG{__WARN__} = sub {};
24 84         39293 require Cookie::Baker;
25             };
26             };
27              
28 84     84   134495 use URI::Escape qw(uri_unescape);
  84         215  
  84         3626  
29 84     84   2151 use Encode;
  84         46811  
  84         5627  
30 84     84   42767 use Plack::Request;
  84         4666684  
  84         3797  
31 84     84   818 use HTTP::Headers::Fast; # we want 0.21, but will tolerate older ones
  84         220  
  84         2347  
32              
33 84     84   516 use parent qw(MVC::Neaf::Request);
  84         219  
  84         579  
34              
35             if (!HTTP::Headers::Fast->can( "psgi_flatten_without_sort" ) || HTTP::XSHeaders->can("new")) {
36             # NOTE HACK Versions below 0.21 don't support the method we call
37             # in do_reply() so fall back to failsafe emulation
38             # NOTE XSHeaders doesn't (yet) provide this method, so fallback as well
39             # See https://rt.cpan.org/Ticket/Display.html?id=123850
40 84     84   6344 no warnings 'once', 'redefine'; ## no critic
  84         199  
  84         93689  
41             *HTTP::Headers::Fast::psgi_flatten_without_sort = sub {
42             my $self = shift;
43             my @all;
44             $self->scan( sub { push @all, $_[0]=>$_[1] } );
45             return \@all;
46             };
47             };
48              
49              
50             =head2 new( env => $psgi_input )
51              
52             Constructor. C MUST follow L requirements.
53              
54             =cut
55              
56             my %default_env = (
57             REQUEST_METHOD => 'GET',
58             );
59              
60             # TODO 0.30 rewrite env copying for good.
61             # Maybe separate ::GET and ::POST to avoid if's
62             sub new {
63 160     160 1 2563 my $class = shift;
64              
65 160         1509 my $self = $class->SUPER::new( @_ );
66              
67             # Don't modify env!
68             # Remove query string if not GET|HEAD
69             # so that GET params are not available inside POST by default
70 160   50     805 my $env = $self->{env} || \%default_env;
71 160         462 $self->{query_string} = $env->{QUERY_STRING};
72              
73             $self->{driver} ||= Plack::Request->new({
74             REQUEST_METHOD => 'GET',
75             %$env,
76 160 100 100     2924 ($MVC::Neaf::Request::query_allowed{ $env->{REQUEST_METHOD} || 'GET' }
      33        
77             ? () : (QUERY_STRING => '')),
78             });
79              
80 160         2487 return $self;
81             };
82              
83             =head2 do_get_client_ip
84              
85             =cut
86              
87             sub do_get_client_ip {
88 1     1 1 3 my $self = shift;
89              
90 1         3 return $self->{driver}->address;
91             };
92              
93             =head2 do_get_http_version()
94              
95             =cut
96              
97             sub do_get_http_version {
98 1     1 1 5 my $self = shift;
99              
100 1   50     6 my $proto = $self->{driver}->protocol || '1.0';
101 1         11 $proto =~ s#^HTTP/##;
102              
103 1         3 return $proto;
104             };
105              
106             =head2 do_get_scheme()
107              
108             =cut
109              
110             sub do_get_scheme {
111 6     6 1 13 my $self = shift;
112 6         24 return $self->{driver}->scheme;
113             };
114              
115             =head2 do_get_hostname()
116              
117             =cut
118              
119             sub do_get_hostname {
120 3     3 1 6 my $self = shift;
121 3         9 my $base = $self->{driver}->base;
122              
123 3 50       697 return $base =~ m#//([^:?/]+)# ? $1 : "localhost";
124             };
125              
126             =head2 do_get_port()
127              
128             =cut
129              
130             sub do_get_port {
131 3     3 1 5 my $self = shift;
132 3         9 my $base = $self->{driver}->base;
133              
134 3 100       8401 return $base =~ m#//([^:?/]+):(\d+)# ? $2 : "80";
135             };
136              
137             =head2 do_get_method()
138              
139             Return GET/POST.
140              
141             =cut
142              
143             sub do_get_method {
144 158     158 1 317 my $self = shift;
145 158         663 return $self->{driver}->method;
146             };
147              
148             =head2 do_get_path()
149              
150             Returns the path part of URI.
151              
152             =cut
153              
154             sub do_get_path {
155 156     156 1 308 my $self = shift;
156              
157 156         400 my $path = $self->{env}{REQUEST_URI};
158 156 100       491 $path = '' unless defined $path;
159              
160 156         623 $path =~ s#\?.*$##;
161 156         754 $path =~ s#^/*#/#;
162              
163 156         1186 return $path;
164             };
165              
166             =head2 do_get_params()
167              
168             Returns GET/POST parameters as a hash.
169              
170             B Plack::Request's multivalue hash params are ignored for now.
171              
172             =cut
173              
174             sub do_get_params {
175 35     35 1 67 my $self = shift;
176              
177 35         65 my %hash;
178 35         170 foreach ( $self->{driver}->param ) {
179 38         9397 $hash{$_} = $self->{driver}->param( $_ );
180             };
181              
182 35         2082 return \%hash;
183             };
184              
185             =head2 do_get_param_as_array
186              
187             =cut
188              
189             sub do_get_param_as_array {
190 7     7 1 29 my ($self, $name) = @_;
191              
192 7         23 return $self->{driver}->param( $name );
193             };
194              
195             =head2 do_get_upload( "name" )
196              
197             B This garbles Hash::Multivalue.
198              
199             =cut
200              
201             sub do_get_upload {
202 1     1 1 3 my ($self, $id) = @_;
203              
204 1   33     6 $self->{driver_upload} ||= $self->{driver}->uploads;
205 1         14 my $up = $self->{driver_upload}{$id}; # TODO 0.90 don't garble multivalues
206              
207 1 50       4 return $up ? { tempfile => $up->path, filename => $up->filename } : ();
208             };
209              
210             =head2 do_get_header_in
211              
212             =cut
213              
214             sub do_get_header_in {
215 28     28 1 70 my $self = shift;
216              
217 28         106 return $self->{driver}->headers;
218             };
219              
220             =head2 do_get_body
221              
222             =cut
223              
224             sub do_get_body {
225 6     6 1 15 my $self = shift;
226              
227 6         22 return $self->{driver}->content;
228             };
229              
230             =head2 do_reply( $status_line, \%headers, $content )
231              
232             Send reply to client. Not to be used directly.
233              
234             B This function just returns its input and has no side effect,
235             rather relying on PSGI calling conventions.
236              
237             =cut
238              
239             sub do_reply {
240 156     156 1 484 my ($self, $status, $content) = @_;
241              
242 156         529 my $header_array = $self->header_out->psgi_flatten_without_sort;
243              
244             # HACK - we're being returned by handler in MVC::Neaf itself in case of
245             # PSGI being used.
246              
247 156 100       8363 if ($self->{response}{postponed}) {
248             # Even hackier HACK. If we have a postponed action,
249             # we must use PSGI functional interface to ensure
250             # reply is sent to client BEFORE
251             # postponed calls get executed.
252              
253             return sub {
254 5     5   10 my $responder = shift;
255              
256             # TODO 0.90 should handle responder's failure somehow
257 5         20 $self->{writer} = $responder->( [ $status, $header_array ] );
258 5 100       27 $self->{writer}->write( $content ) if defined $content;
259              
260             # Now we may need to output more stuff
261             # So save writer inside self for callbacks to write to
262 5         47 $self->execute_postponed;
263             # close was not called by 1 of callbacks
264 5 50       25 $self->do_close if $self->{continue};
265 5         54 };
266             };
267              
268             # Otherwise just return plain data.
269 151         845 return [ $status, $header_array, [ $content ]];
270             };
271              
272             =head2 do_write( $data )
273              
274             Write to socket in async content mode.
275              
276             =cut
277              
278             sub do_write {
279 46     46 1 72 my ($self, $data) = @_;
280              
281 46 50       77 return unless defined $data;
282              
283             # NOTE "can't call method write on undefined value" here
284             # probably means that PSGI responder failed unexpectedly in do_reply()
285             # and we didn't handle it properly and got empty {writer}
286             # and the request is being destroyed.
287 46         115 $self->{writer}->write( $data );
288 46         72 return 1;
289             };
290              
291             =head2 do_close()
292              
293             Close client connection in async content mode.
294              
295             =cut
296              
297             sub do_close {
298 7     7 1 12 my $self = shift;
299              
300 7         18 $self->{writer}->close;
301             };
302              
303             =head1 LICENSE AND COPYRIGHT
304              
305             This module is part of L suite.
306              
307             Copyright 2016-2023 Konstantin S. Uvarin C.
308              
309             This program is free software; you can redistribute it and/or modify it
310             under the terms of either: the GNU General Public License as published
311             by the Free Software Foundation; or the Artistic License.
312              
313             See L for more information.
314              
315             =cut
316              
317             1;