File Coverage

blib/lib/MVC/Neaf/Request/Apache2.pm
Criterion Covered Total %
statement 63 103 61.1
branch 8 20 40.0
condition 3 6 50.0
subroutine 18 27 66.6
pod 16 16 100.0
total 108 172 62.7


line stmt bran cond sub pod time code
1             package MVC::Neaf::Request::Apache2;
2              
3 2     2   660 use strict;
  2         5  
  2         61  
4 2     2   10 use warnings;
  2         4  
  2         87  
5              
6             our $VERSION = '0.2800_01';
7              
8             =head1 NAME
9              
10             MVC::Neaf::Request::Apache2 - Apache2 (mod_perl) driver for Not Even A Framework.
11              
12             =head1 WARNING
13              
14             B
15              
16             Use L instead.
17              
18             =head1 SYNOPSIS
19              
20             Apache2 request that will invoke MVC::Neaf core functions from under mod_perl.
21              
22             The following apache configuration should work with this module:
23              
24             LoadModule perl_module modules/mod_perl.so
25             PerlSwitches -I[% YOUR_LIB_DIRECTORY %]
26             LoadModule apreq_module [% modules %]/mod_apreq2.so
27              
28             # later...
29             PerlModule MVC::Neaf::Request::Apache2
30             PerlPostConfigRequire [% YOUR_APPLICATION %]
31            
32             SetHandler perl-script
33             PerlResponseHandler MVC::Neaf::Request::Apache2
34            
35              
36             =head1 METHODS
37              
38             =cut
39              
40 2     2   10 use Carp;
  2         4  
  2         133  
41 2     2   13 use URI::Escape;
  2         4  
  2         113  
42 2     2   13 use HTTP::Headers::Fast;
  2         4  
  2         48  
43 2     2   11 use Module::Load;
  2         4  
  2         15  
44              
45             my %fail_apache;
46             BEGIN {
47 2     2   439 foreach my $mod (qw(
48             Apache2::RequestRec
49             Apache2::RequestIO
50             Apache2::Connection
51             APR::SockAddr
52             Apache2::Request
53             Apache2::Upload
54             Apache2::Const
55             )) {
56 14 100       24 eval { load $mod; 1 } and next;
  14         42  
  7         595  
57             # warn "Failed to load $mod: $@";
58 7         2288 $fail_apache{$mod} = $@;
59             };
60              
61 2 50 66     16 if ($ENV{MOD_PERL} && %fail_apache) {
62             carp "$_ failed to load: $fail_apache{$_}"
63 0         0 for keys %fail_apache;
64 0         0 croak "Apache2 modules not loaded, refusing to run right away";
65             };
66              
67 2 100       65 if (!%fail_apache) {
68 1         66 Apache2::Const->import( -compile => 'OK' );
69             };
70             };
71              
72             # TODO 0.30 remove the whole module
73             carp __PACKAGE__." is DEPRECATED and will be REMOVED in 0.30. Use Plack::Handler::Apache2 instead."
74             if $ENV{MOD_PERL};
75              
76 2     2   563 use MVC::Neaf;
  2         6  
  2         153  
77 2     2   13 use parent qw(MVC::Neaf::Request);
  2         4  
  2         9  
78              
79             =head2 do_get_client_ip
80              
81             =cut
82              
83             my $client_ip_name;
84             sub do_get_client_ip {
85 0     0 1 0 my $self = shift;
86              
87 0         0 my $conn = $self->{driver_raw}->connection;
88 0 0       0 if (!$client_ip_name) {
89             # Apache 2.4 breaks API violently, so autodetect on first run,
90             # fall back to localhost
91 0         0 foreach (qw(remote_ip client_ip)) {
92 0 0       0 $conn->can($_) or next;
93 0         0 $client_ip_name = $_;
94 0         0 last;
95             };
96 0 0       0 if (!$client_ip_name) {
97 0         0 carp("WARNING: No client_ip found under Apache2, inform MVC::Neaf author");
98 0         0 return '127.0.0.1';
99             };
100             };
101              
102 0         0 return $conn->$client_ip_name;
103             };
104              
105             =head2 do_get_http_version
106              
107             =cut
108              
109             sub do_get_http_version {
110 0     0 1 0 my $self = shift;
111 0         0 my $proto = $self->{driver_raw}->proto_num;
112 0         0 $proto =~ /^\D*(\d+?)\D*(\d\d?\d?)$/;
113 0         0 return join ".", 0+$1, 0+$2;
114             };
115              
116             =head2 do_get_scheme
117              
118             =cut
119              
120             sub do_get_scheme {
121 1     1 1 3 my $self = shift;
122              
123             # Shamelessly stolen from Catalyst
124 1         8 my $https = $self->{driver_raw}->subprocess_env('HTTPS');
125 1 50 33     24 return( ($https && uc $https eq 'ON') ? "https" : "http" );
126             };
127              
128             =head2 do_get_hostname
129              
130             =cut
131              
132             sub do_get_hostname {
133 0     0 1 0 my $self = shift;
134 0         0 return $self->{driver_raw}->hostname;
135             };
136              
137             =head2 do_get_port()
138              
139             =cut
140              
141             sub do_get_port {
142 0     0 1 0 my $self = shift;
143              
144 0         0 my $conn = $self->{driver_raw}->connection;
145 0         0 return $conn->local_addr->port;
146             };
147              
148             =head2 do_get_method()
149              
150             =cut
151              
152             sub do_get_method {
153 1     1 1 9 my $self = shift;
154              
155 1         5 return $self->{driver_raw}->method;
156             };
157              
158             =head2 do_get_path()
159              
160             =cut
161              
162             sub do_get_path {
163 1     1 1 3 my $self = shift;
164              
165 1         12 return $self->{driver_raw}->uri;
166             };
167              
168             =head2 do_get_params()
169              
170             =cut
171              
172             sub do_get_params {
173 1     1 1 2 my $self = shift;
174              
175 1         2 my %hash;
176 1         3 my $r = $self->{driver};
177 1         7 $hash{$_} = $r->param($_) for $r->param;
178              
179 1         32 return \%hash;
180             };
181              
182             =head2 do_get_param_as_array
183              
184             =cut
185              
186             sub do_get_param_as_array {
187 0     0 1 0 my ($self, $name) = @_;
188              
189 0         0 return $self->{driver}->param( $name );
190             };
191              
192             =head2 do_get_header_in()
193              
194             =cut
195              
196             sub do_get_header_in {
197 1     1 1 3 my $self = shift;
198              
199 1         2 my %head;
200             $self->{driver_raw}->headers_in->do( sub {
201 0     0   0 my ($key, $val) = @_;
202 0         0 push @{ $head{$key} }, $val;
  0         0  
203 1         34 });
204              
205 1         43 return HTTP::Headers::Fast->new( %head );
206             };
207              
208             =head2 do_get_upload( "name" )
209              
210             Convert apache upload object into MCV::Neaf::Upload.
211              
212             =cut
213              
214             sub do_get_upload {
215 0     0 1 0 my ($self, $name) = @_;
216              
217 0         0 my $r = $self->{driver};
218 0         0 my $upload = $r->upload($name);
219              
220 0 0       0 return $upload ? {
221             handle => $upload->fh,
222             tempfile => $upload->tempname,
223             filename => $upload->filename,
224             } : ();
225             };
226              
227             =head2 do_get_body
228              
229             =cut
230              
231             sub do_get_body {
232 0     0 1 0 my $self = shift;
233              
234             # use Apache2::RequestIO
235             # read until there's EOF, then concatenate & return
236 0         0 my $r = $self->{driver_raw};
237              
238 0         0 my @buf = ('');
239 0         0 while ( $r->read( $buf[-1], 8192, 0 ) ) {
240 0         0 push @buf, '';
241             };
242              
243 0         0 return join '', @buf;
244             };
245              
246             =head2 do_reply( $status, $content )
247              
248             =cut
249              
250             sub do_reply {
251 1     1 1 106 my ($self, $status, $content) = @_;
252              
253 1         5 my $r = $self->{driver_raw};
254              
255 1         5 my ($type) = $self->header_out->remove_header("content_type");
256 1         34 $r->status( $status );
257 1         23 $r->content_type( $type );
258              
259 1         16 my $head_backend = $r->headers_out;
260             $self->header_out->scan( sub {
261 1     1   43 $head_backend->add( $_[0], $_[1] );
262 1         90 });
263              
264 1         32 return $r->print( $content );
265             };
266              
267             =head2 do_write( $data )
268              
269             Write to socket if async content serving is in use.
270              
271             =cut
272              
273             sub do_write {
274 0     0 1 0 my ($self, $data) = @_;
275 0         0 return $self->{driver_raw}->print( $data );
276             };
277              
278             =head2 handler( $apache_request )
279              
280             A valid Apache2/mod_perl handler.
281              
282             This invokes MCV::Neaf->handle_request when called.
283              
284             Unfortunately, libapreq (in addition to mod_perl) is required currently.
285              
286             =cut
287              
288             sub handler : method {
289 1     1 1 16 my ($class, $r) = @_;
290              
291 1         10 my $self = $class->new(
292             driver_raw => $r,
293             driver => Apache2::Request->new($r),
294             query_string => $r->args,
295             );
296 1 50       17 if (!$MVC::Neaf::Request::query_allowed{ $r->method }) {
297 0         0 $r->args('');
298             };
299 1         12 my $reply = MVC::Neaf::neaf()->handle_request( $self );
300              
301 1         20 return Apache2::Const::OK();
302             };
303              
304             =head2 failed_startup()
305              
306             If Apache modules failed to load on startup, report error here.
307              
308             This is done so because adding Apache2::* as dependencies would impose
309             a HUGE headache on PSGI users.
310              
311             Ideally, this module should be mover out of the repository altogether.
312              
313             =cut
314              
315             sub failed_startup {
316 1 50   1 1 636 return %fail_apache ? \%fail_apache : ();
317             };
318              
319             =head1 LICENSE AND COPYRIGHT
320              
321             This module is part of L suite.
322              
323             Copyright 2016-2023 Konstantin S. Uvarin C.
324              
325             This program is free software; you can redistribute it and/or modify it
326             under the terms of either: the GNU General Public License as published
327             by the Free Software Foundation; or the Artistic License.
328              
329             See L for more information.
330              
331             =cut
332              
333             1;