X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FApache.pm;h=e3c523043b63ebe0418e35e551efbf4eb5dc527a;hp=5f8db714c06c914f5dc004873bdd9e2e3b0ead61;hb=bfde09a29c9b25cca920350488ddda743a606031;hpb=c9afa5fc4ed6c36afe6653d7d8fbb9909994c1a8 diff --git a/lib/Catalyst/Engine/Apache.pm b/lib/Catalyst/Engine/Apache.pm index 5f8db71..e3c5230 100644 --- a/lib/Catalyst/Engine/Apache.pm +++ b/lib/Catalyst/Engine/Apache.pm @@ -1,30 +1,12 @@ package Catalyst::Engine::Apache; use strict; -use mod_perl; -use constant MP2 => $mod_perl::VERSION >= 1.99; use base 'Catalyst::Engine'; -use URI; - -# mod_perl -if (MP2) { - require Apache2; - require Apache::Connection; - require Apache::RequestIO; - require Apache::RequestRec; - require Apache::SubRequest; - require Apache::RequestUtil; - require APR::URI; - require Apache::URI; -} -else { require Apache } -# libapreq -require Apache::Request; -require Apache::Cookie; -require Apache::Upload if MP2; +use URI; +use URI::http; -__PACKAGE__->mk_accessors(qw/apache_request original_request/); +__PACKAGE__->mk_accessors(qw/apache/); =head1 NAME @@ -36,20 +18,16 @@ See L. =head1 DESCRIPTION -This is the Catalyst engine specialized for Apache (i.e. for mod_perl). +This is a base class engine specialized for Apache (i.e. for mod_perl). =head1 METHODS =over 4 -=item $c->apache_request +=item $c->apache Returns an C object. -=item $c->original_request - -Returns the original Apache request object. - =back =head1 OVERLOADED METHODS @@ -58,65 +36,49 @@ This class overloads some methods from C. =over 4 -=item $c->finalize_headers +=item $c->finalize_body =cut -sub finalize_headers { +sub finalize_body { my $c = shift; - for my $name ( $c->response->headers->header_field_names ) { - next if $name =~ /Content-Type/i; - $c->original_request->headers_out->set( - $name => $c->response->headers->header($name) ); - } - while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) { - my %cookie = ( -name => $name, -value => $cookie->{value} ); - $cookie->{-expires} = $cookie->{expires} if $cookie->{expires}; - $cookie->{-domain} = $cookie->{domain} if $cookie->{domain}; - $cookie->{-path} = $cookie->{path} if $cookie->{path}; - $cookie->{-secure} = $cookie->{secure} if $cookie->{secure}; - my $cookie = Apache::Cookie->new( $c->original_request, %cookie ); - MP2 - ? $c->apache_request->err_headers_out->add( - 'Set-Cookie' => $cookie->as_string ) - : $cookie->bake; - } - $c->original_request->status( $c->response->status ); - $c->original_request->content_type( $c->response->headers->content_type - || 'text/plain' ); - MP2 || $c->apache_request->send_http_header; - return 0; + $c->apache->print( $c->response->body ); } -=item $c->finalize_output +=item $c->prepare_body =cut -sub finalize_output { +sub prepare_body { my $c = shift; - $c->original_request->print( $c->response->{output} ); -} -=item $c->prepare_connection + my $length = $c->request->content_length; + my ( $buffer, $content ); -=cut + while ($length) { -sub prepare_connection { - my $c = shift; - $c->req->hostname( $c->apache_request->connection->remote_host ); - $c->req->address( $c->apache_request->connection->remote_ip ); + $c->apache->read( $buffer, ( $length < 8192 ) ? $length : 8192 ); + + $length -= length($buffer); + $content .= $buffer; + } + + $c->request->body($content); } -=item $c->prepare_cookies +=item $c->prepare_connection =cut -sub prepare_cookies { +sub prepare_connection { my $c = shift; - MP2 - ? $c->req->cookies( { Apache::Cookie->fetch } ) - : $c->req->cookies( - { Apache::Cookie->new( $c->apache_request )->fetch } ); + $c->request->address( $c->apache->connection->remote_ip ); + $c->request->hostname( $c->apache->connection->remote_host ); + $c->request->protocol( $c->apache->protocol ); + + if ( $ENV{HTTPS} ) { + $c->request->secure(1); + } } =item $c->prepare_headers @@ -125,8 +87,8 @@ sub prepare_cookies { sub prepare_headers { my $c = shift; - $c->req->method( $c->apache_request->method ); - $c->req->headers->header( %{ $c->apache_request->headers_in } ); + $c->request->method( $c->apache->method ); + $c->request->header( %{ $c->apache->headers_in } ); } =item $c->prepare_parameters @@ -135,57 +97,37 @@ sub prepare_headers { sub prepare_parameters { my $c = shift; - my %args; - foreach my $key ( $c->apache_request->param ) { - my @values = $c->apache_request->param($key); - $args{$key} = @values == 1 ? $values[0] : \@values; - } - $c->req->parameters( \%args ); + + my @params; + + $c->apache->param->do( sub { + my ( $field, $value ) = @_; + push( @params, $field, $value ); + return 1; + }); + + $c->request->param(@params); } =item $c->prepare_path =cut +# XXX needs fixing, only work with directive, +# not directive sub prepare_path { my $c = shift; - $c->req->path( $c->apache_request->uri ); - my $loc = $c->apache_request->location; + $c->request->path( $c->apache->uri ); + my $loc = $c->apache->location; no warnings 'uninitialized'; $c->req->{path} =~ s/^($loc)?\///; my $base = URI->new; $base->scheme( $ENV{HTTPS} ? 'https' : 'http' ); - $base->host( $c->apache_request->hostname ); - $base->port( $c->apache_request->get_server_port ); - my $path = $c->apache_request->location; + $base->host( $c->apache->hostname ); + $base->port( $c->apache->get_server_port ); + my $path = $c->apache->location; $base->path( $path =~ /\/$/ ? $path : "$path/" ); - $c->req->base( $base->as_string ); -} - -=item $c->prepare_request($r) - -=cut - -sub prepare_request { - my ( $c, $r ) = @_; - $c->apache_request( Apache::Request->new($r) ); - $c->original_request($r); -} - -=item $c->prepare_uploads - -=cut - -sub prepare_uploads { - my $c = shift; - for my $upload ( $c->apache_request->upload ) { - $upload = $c->apache_request->upload($upload) if MP2; - $c->req->uploads->{ $upload->filename } = { - fh => $upload->fh, - size => $upload->size, - type => $upload->type - }; - } + $c->request->base( $base->as_string ); } =item $c->run @@ -203,6 +145,7 @@ L. =head1 AUTHOR Sebastian Riedel, C +Christian Hansen C =head1 COPYRIGHT