root/lang/perl/HTTPEx-Adaptor-ModPerl/trunk/lib/HTTPEx/Adaptor/ModPerl.pm @ 10369

Revision 10369, 8.3 kB (checked in by daisuke, 6 years ago)

use Apache::Test

  • Property svn:keywords set to Id
Line 
1# $Id$
2
3package HTTPEx::Adaptor::ModPerl;
4use strict;
5use warnings;
6use base qw(Class::Accessor::Fast Class::Data::ConfigHash);
7use File::Spec;
8use HTTP::Engine;
9use URI;
10use URI::http;
11use URI::https;
12
13use constant MP2 => (
14    exists $ENV{MOD_PERL_API_VERSION} and
15           $ENV{MOD_PERL_API_VERSION} >= 2
16);
17
18our $VERSION = '0.00001';
19
20__PACKAGE__->mk_accessors($_) for qw(apache return);
21HTTP::Engine->load_plugins(qw/ Interface::Adaptor /);
22
23sub handler : method
24{
25    my ($class, $r) = @_;
26
27    my $self = $class->new({ apache => $r });
28    HTTP::Engine->new(
29        andle_request => $class->config->{handler},
30        adaptee        => $self,
31    );
32
33    return ok_constant();
34}
35
36use Apache2::Const -compile => qw(OK);
37sub ok_constant { Apache2::Const::OK() }
38
39sub prepare_cookie { }
40sub prepare_body { }
41sub prepare_body_parameters { }
42sub prepare_parameters { }
43sub prepare_uploads { }
44sub finalize_cookies { }
45sub finalize_output_headers { }
46sub finalize_output_body { }
47
48sub prepare_request {
49    my ( $self, $c ) = @_;
50    $self->return( undef );
51}
52
53sub prepare_connection {
54    my ( $self, $c ) = @_;
55
56    $c->request->address( $self->apache->connection->remote_ip );
57
58    PROXY_CHECK:
59    {
60        my $headers = $self->apache->headers_in;
61        unless ( $c->config->{using_frontend_proxy} ) {
62            last PROXY_CHECK if $c->request->address ne '127.0.0.1';
63            last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
64        }       
65        last PROXY_CHECK unless $headers->{'X-Forwarded-For'};
66
67        # If we are running as a backend server, the user will always appear
68        # as 127.0.0.1. Select the most recent upstream IP (last in the list)
69        my ($ip) = $headers->{'X-Forwarded-For'} =~ /([^,\s]+)$/;
70        $c->request->address( $ip );
71    }
72
73    $c->request->hostname( $self->apache->connection->remote_host );
74    $c->request->protocol( $self->apache->protocol );
75    $c->request->user( $self->apache->user );
76
77    # when config options are set, check them here first
78    if ($INC{'Apache2/ModSSL.pm'}) {
79        $c->request->secure(1) if $self->apache->connection->is_https;
80    } else {
81        my $https = $self->apache->subprocess_env('HTTPS');
82        $c->request->secure(1) if defined $https and uc $https eq 'ON';
83    }
84
85}
86
87sub prepare_query_parameters {
88    my ( $self, $c ) = @_;
89   
90    if ( my $query_string = $self->apache->args ) {
91# XXX - 後で
92#        $self->SUPER::prepare_query_parameters( $c, $query_string );
93    }
94}
95
96sub prepare_headers {
97    my ( $self, $c ) = @_;
98
99    $c->request->method( $self->apache->method );
100
101    if ( my %headers = %{ $self->apache->headers_in } ) {
102        $c->request->header( %headers );
103    }
104}
105
106sub prepare_path {
107    my ( $self, $c ) = @_;
108
109    my $scheme = $c->request->secure ? 'https' : 'http';
110    my $host   = $self->apache->hostname || 'localhost';
111    my $port   = $self->apache->get_server_port;
112
113    # If we are running as a backend proxy, get the true hostname
114    PROXY_CHECK:
115    {
116        unless ( $c->config->{using_frontend_proxy} ) {
117            last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
118            last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
119        }
120        last PROXY_CHECK unless $c->request->header( 'X-Forwarded-Host' );
121       
122        $host = $c->request->header( 'X-Forwarded-Host' );
123
124        if ( $host =~ /^(.+):(\d+)$/ ) {
125            $host = $1;
126            $port = $2;
127        } else {
128            # backend could be on any port, so
129            # assume frontend is on the default port
130            $port = $c->request->secure ? 443 : 80;
131        }
132    }
133
134    my $base_path = '';
135
136    # Are we running in a non-root Location block?
137    my $location = $self->apache->location;
138    if ( $location && $location ne '/' ) {
139        $base_path = $location;
140    }
141   
142    # Using URI directly is way too slow, so we construct the URLs manually
143    my $uri_class = "URI::$scheme";
144   
145    if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
146        $host .= ":$port";
147    }
148   
149    # We want the path before Apache escapes it.  Under mod_perl2 this is available
150    # with the unparsed_uri method.  Under mod_perl 1 we must parse it out of the
151    # request line.
152    my ($path, $qs);
153   
154    if ( MP2 ) {
155        ($path, $qs) = split /\?/, $self->apache->unparsed_uri, 2;
156    }
157    else {
158        my (undef, $path_query) = split / /, $self->apache->the_request, 3;
159        ($path, $qs)            = split /\?/, $path_query, 2;
160    }
161   
162    # Don't check for LocationMatch blocks if requested
163    # http://rt.cpan.org/Ticket/Display.html?id=26921
164    if ( $self->apache->dir_config('CatalystDisableLocationMatch') ) {
165        $base_path = '';
166    }
167       
168    # Check if $base_path appears to be a regex (contains invalid characters),
169    # meaning we're in a LocationMatch block
170    elsif ( $base_path =~ m/[^$URI::uric]/o ) {
171        # Find out what part of the URI path matches the LocationMatch regex,
172        # that will become our base
173        my $match = qr/($base_path)/;
174        my ($base_match) = $path =~ $match;
175       
176        $base_path = $base_match || '';
177    }
178
179    # Strip leading slash
180    $path =~ s{^/+}{};
181   
182    # base must end in a slash
183    $base_path .= '/' unless $base_path =~ m{/$};
184
185    # Are we an Apache::Registry script? Why anyone would ever want to run
186    # this way is beyond me, but we'll support it!
187    # XXX: This needs a test
188    if ( defined $ENV{SCRIPT_NAME} && $self->apache->filename && -f $self->apache->filename && -x _ ) {
189        $base_path .= $ENV{SCRIPT_NAME};
190    }
191   
192    # If the path is contained within the base, we need to make the path
193    # match base.  This handles the case where the app is running at /deep/path
194    # but a request to /deep/path fails where /deep/path/ does not.
195    if ( $base_path ne '/' && $base_path ne $path && $base_path =~ m{/$path} ) {
196        $path = $base_path;
197        $path =~ s{^/+}{};
198    }
199   
200    my $query = $qs ? '?' . $qs : '';
201    my $uri   = $scheme . '://' . $host . '/' . $path . $query;
202
203    $c->request->uri( bless \$uri, $uri_class );
204   
205    my $base_uri = $scheme . '://' . $host . $base_path;
206
207    $c->request->base( bless \$base_uri, $uri_class );
208}
209
210sub read_chunk {
211    my $self = shift;
212    my $c = shift;
213   
214    $self->apache->read( @_ );
215}
216
217sub finalize_body {
218    my ( $self, $c ) = @_;
219   
220    # XXX - 後で
221#    $self->SUPER::finalize_body($c);
222   
223    # Data sent using $self->apache->print is buffered, so we need
224    # to flush it after we are done writing.
225    $self->apache->rflush;
226}
227
228sub finalize_headers {
229    my ( $self, $c ) = @_;
230
231    for my $name ( $c->response->headers->header_field_names ) {
232        next if $name =~ /^Content-(Length|Type)$/i;
233        my @values = $c->response->header($name);
234        # allow X headers to persist on error
235        if ( $name =~ /^X-/i ) {
236            $self->apache->err_headers_out->add( $name => $_ ) for @values;
237        }
238        else {
239            $self->apache->headers_out->add( $name => $_ ) for @values;
240        }
241    }
242
243    # persist cookies on error responses
244    if ( $c->response->header('Set-Cookie') && $c->response->status >= 400 ) {
245        for my $cookie ( $c->response->header('Set-Cookie') ) {
246            $self->apache->err_headers_out->add( 'Set-Cookie' => $cookie );
247        }
248    }
249
250    # The trick with Apache is to set the status code in $apache->status but
251    # always return the OK constant back to Apache from the handler.
252    $self->apache->status( $c->response->status );
253    $c->response->status( $self->return || $self->ok_constant );
254
255    my $type = $c->response->header('Content-Type') || 'text/html';
256    $self->apache->content_type( $type );
257
258    if ( my $length = $c->response->content_length ) {
259        $self->apache->set_content_length( $length );
260    }
261
262    # This handles the case where Apache2 will remove the Content-Length
263    # header on a HEAD request.
264    # http://perl.apache.org/docs/2.0/user/handlers/http.html
265    if ( $self->apache->header_only ) {
266        $self->apache->rflush;
267    }
268
269    return 0;
270}
271
272sub write {
273    my ( $self, $c, $buffer ) = @_;
274
275    if ( ! $self->apache->connection->aborted && defined $buffer) {
276        return $self->apache->print( $buffer );
277    }
278    return;
279}
280
2811;
282
283__END__
284
285=head1 NAME
286
287HTTPEx::Adaptor::ModPerl - ModPerl Adaptor For HTTP::Engine
288
289=head1 SYNOPSIS
290
291  package MyApp;
292  use strict;
293  use base qw(HTTPEx::Adaptor::ModPerl);
294
295  __PACKAGE__->config(
296    handler => \&handler
297  )
298
299=cut
Note: See TracBrowser for help on using the browser.