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

# $Id$

package HTTPEx::Adaptor::ModPerl;
use strict;
use warnings;
use base qw(Class::Accessor::Fast Class::Data::ConfigHash);
use File::Spec;
use HTTP::Engine;
use URI;
use URI::http;
use URI::https;

use constant MP2 => (
    exists $ENV{MOD_PERL_API_VERSION} and
           $ENV{MOD_PERL_API_VERSION} >= 2
);

our $VERSION = '0.00001';

__PACKAGE__->mk_accessors($_) for qw(apache return);
HTTP::Engine->load_plugins(qw/ Interface::Adaptor /);

sub handler : method
{
    my ($class, $r) = @_;

    my $self = $class->new({ apache => $r });
    HTTP::Engine->new(
        andle_request => $class->config->{handler},
        adaptee        => $self,
    );

    return ok_constant();
}

use Apache2::Const -compile => qw(OK);
sub ok_constant { Apache2::Const::OK() }

sub prepare_cookie { }
sub prepare_body { }
sub prepare_body_parameters { }
sub prepare_parameters { }
sub prepare_uploads { }
sub finalize_cookies { }
sub finalize_output_headers { }
sub finalize_output_body { }

sub prepare_request {
    my ( $self, $c ) = @_;
    $self->return( undef );
}

sub prepare_connection {
    my ( $self, $c ) = @_;

    $c->request->address( $self->apache->connection->remote_ip );

    PROXY_CHECK:
    {
        my $headers = $self->apache->headers_in;
        unless ( $c->config->{using_frontend_proxy} ) {
            last PROXY_CHECK if $c->request->address ne '127.0.0.1';
            last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
        }        
        last PROXY_CHECK unless $headers->{'X-Forwarded-For'};

        # If we are running as a backend server, the user will always appear
        # as 127.0.0.1. Select the most recent upstream IP (last in the list)
        my ($ip) = $headers->{'X-Forwarded-For'} =~ /([^,\s]+)$/;
        $c->request->address( $ip );
    }

    $c->request->hostname( $self->apache->connection->remote_host );
    $c->request->protocol( $self->apache->protocol );
    $c->request->user( $self->apache->user );

    # when config options are set, check them here first
    if ($INC{'Apache2/ModSSL.pm'}) {
        $c->request->secure(1) if $self->apache->connection->is_https;
    } else {
        my $https = $self->apache->subprocess_env('HTTPS'); 
        $c->request->secure(1) if defined $https and uc $https eq 'ON';
    }

}

sub prepare_query_parameters {
    my ( $self, $c ) = @_;
    
    if ( my $query_string = $self->apache->args ) {
# XXX - 後で
#        $self->SUPER::prepare_query_parameters( $c, $query_string );
    }
}

sub prepare_headers {
    my ( $self, $c ) = @_;

    $c->request->method( $self->apache->method );

    if ( my %headers = %{ $self->apache->headers_in } ) {
        $c->request->header( %headers );
    }
}

sub prepare_path {
    my ( $self, $c ) = @_;

    my $scheme = $c->request->secure ? 'https' : 'http';
    my $host   = $self->apache->hostname || 'localhost';
    my $port   = $self->apache->get_server_port;

    # If we are running as a backend proxy, get the true hostname
    PROXY_CHECK:
    {
        unless ( $c->config->{using_frontend_proxy} ) {
            last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
            last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
        }
        last PROXY_CHECK unless $c->request->header( 'X-Forwarded-Host' );
        
        $host = $c->request->header( 'X-Forwarded-Host' );

        if ( $host =~ /^(.+):(\d+)$/ ) {
            $host = $1;
            $port = $2;
        } else {
            # backend could be on any port, so
            # assume frontend is on the default port
            $port = $c->request->secure ? 443 : 80;
        }
    }

    my $base_path = '';

    # Are we running in a non-root Location block?
    my $location = $self->apache->location;
    if ( $location && $location ne '/' ) {
        $base_path = $location;
    }
    
    # Using URI directly is way too slow, so we construct the URLs manually
    my $uri_class = "URI::$scheme";
    
    if ( $port !~ /^(?:80|443)$/ && $host !~ /:/ ) {
        $host .= ":$port";
    }
    
    # We want the path before Apache escapes it.  Under mod_perl2 this is available
    # with the unparsed_uri method.  Under mod_perl 1 we must parse it out of the
    # request line.
    my ($path, $qs);
    
    if ( MP2 ) {
        ($path, $qs) = split /\?/, $self->apache->unparsed_uri, 2;
    }
    else {
        my (undef, $path_query) = split / /, $self->apache->the_request, 3;
        ($path, $qs)            = split /\?/, $path_query, 2;
    }
    
    # Don't check for LocationMatch blocks if requested
    # http://rt.cpan.org/Ticket/Display.html?id=26921
    if ( $self->apache->dir_config('CatalystDisableLocationMatch') ) {
        $base_path = '';
    }
        
    # Check if $base_path appears to be a regex (contains invalid characters),
    # meaning we're in a LocationMatch block
    elsif ( $base_path =~ m/[^$URI::uric]/o ) {
        # Find out what part of the URI path matches the LocationMatch regex,
        # that will become our base
        my $match = qr/($base_path)/;
        my ($base_match) = $path =~ $match;
        
        $base_path = $base_match || '';
    }

    # Strip leading slash
    $path =~ s{^/+}{};
    
    # base must end in a slash
    $base_path .= '/' unless $base_path =~ m{/$};

    # Are we an Apache::Registry script? Why anyone would ever want to run
    # this way is beyond me, but we'll support it!
    # XXX: This needs a test
    if ( defined $ENV{SCRIPT_NAME} && $self->apache->filename && -f $self->apache->filename && -x _ ) {
        $base_path .= $ENV{SCRIPT_NAME};
    }
    
    # If the path is contained within the base, we need to make the path
    # match base.  This handles the case where the app is running at /deep/path
    # but a request to /deep/path fails where /deep/path/ does not.
    if ( $base_path ne '/' && $base_path ne $path && $base_path =~ m{/$path} ) {
        $path = $base_path;
        $path =~ s{^/+}{};
    }
    
    my $query = $qs ? '?' . $qs : '';
    my $uri   = $scheme . '://' . $host . '/' . $path . $query;

    $c->request->uri( bless \$uri, $uri_class );
    
    my $base_uri = $scheme . '://' . $host . $base_path;

    $c->request->base( bless \$base_uri, $uri_class );
}

sub read_chunk {
    my $self = shift;
    my $c = shift;
    
    $self->apache->read( @_ );
}

sub finalize_body {
    my ( $self, $c ) = @_;
    
    # XXX - 後で
#    $self->SUPER::finalize_body($c);
    
    # Data sent using $self->apache->print is buffered, so we need
    # to flush it after we are done writing.
    $self->apache->rflush;
}

sub finalize_headers {
    my ( $self, $c ) = @_;

    for my $name ( $c->response->headers->header_field_names ) {
        next if $name =~ /^Content-(Length|Type)$/i;
        my @values = $c->response->header($name);
        # allow X headers to persist on error
        if ( $name =~ /^X-/i ) {
            $self->apache->err_headers_out->add( $name => $_ ) for @values;
        }
        else {
            $self->apache->headers_out->add( $name => $_ ) for @values;
        }
    }

    # persist cookies on error responses
    if ( $c->response->header('Set-Cookie') && $c->response->status >= 400 ) {
        for my $cookie ( $c->response->header('Set-Cookie') ) {
            $self->apache->err_headers_out->add( 'Set-Cookie' => $cookie );
        }
    }

    # The trick with Apache is to set the status code in $apache->status but
    # always return the OK constant back to Apache from the handler.
    $self->apache->status( $c->response->status );
    $c->response->status( $self->return || $self->ok_constant );

    my $type = $c->response->header('Content-Type') || 'text/html';
    $self->apache->content_type( $type );

    if ( my $length = $c->response->content_length ) {
        $self->apache->set_content_length( $length );
    }

    # This handles the case where Apache2 will remove the Content-Length
    # header on a HEAD request.
    # http://perl.apache.org/docs/2.0/user/handlers/http.html
    if ( $self->apache->header_only ) {
        $self->apache->rflush;
    }

    return 0;
}

sub write {
    my ( $self, $c, $buffer ) = @_;

    if ( ! $self->apache->connection->aborted && defined $buffer) {
        return $self->apache->print( $buffer );
    }
    return;
}

1;

__END__

=head1 NAME

HTTPEx::Adaptor::ModPerl - ModPerl Adaptor For HTTP::Engine

=head1 SYNOPSIS

  package MyApp;
  use strict;
  use base qw(HTTPEx::Adaptor::ModPerl);

  __PACKAGE__->config(
    handler => \&handler
  )

=cut