$caller->log->debug('Debug messages enabled');
}
- # Options
- my $engine =
- $ENV{MOD_PERL}
- ? 'Catalyst::Engine::Apache'
- : 'Catalyst::Engine::CGI';
+ my $engine ='Catalyst::Engine::CGI';
+
+ if ( $ENV{MOD_PERL} ) {
+
+ require mod_perl;
+
+ if ( $mod_perl::VERSION >= 1.99 ) {
+ $engine ='Catalyst::Engine::Apache::MP2';
+ }
+ else {
+ $engine ='Catalyst::Engine::Apache::MP1';
+ }
+ }
my @plugins;
foreach (@options) {
use strict;
use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
use UNIVERSAL::require;
+use CGI::Cookie;
use Data::Dumper;
use HTML::Entities;
use HTTP::Headers;
return $c->{error};
}
+=item $c->execute($class, $coderef)
+
+Execute a coderef in given class and catch exceptions.
+Errors are available via $c->error.
+
+=cut
+
+sub execute {
+ my ( $c, $class, $code ) = @_;
+ $class = $c->comp($class) || $class;
+ $c->state(0);
+ eval {
+ if ( $c->debug )
+ {
+ my $action = $c->actions->{reverse}->{"$code"};
+ $action = "/$action" unless $action =~ /\-\>/;
+ my ( $elapsed, @state ) =
+ $c->benchmark( $code, $class, $c, @{ $c->req->args } );
+ push @{ $c->{stats} },
+ _prettify( $action, sprintf( '%fs', $elapsed ), '' );
+ $c->state(@state);
+ }
+ else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
+ };
+ if ( my $error = $@ ) {
+ chomp $error;
+ $error = qq/Caught exception "$error"/;
+ $c->log->error($error);
+ $c->error($error) if $c->debug;
+ $c->state(0);
+ }
+ return $c->state;
+}
+
=item $c->finalize
Finalize request.
sub finalize {
my $c = shift;
+ $c->finalize_cookies;
+
if ( my $location = $c->res->redirect ) {
$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
- $c->res->headers->header( Location => $location );
- $c->res->headers->remove_content_headers;
- $c->res->status(302);
+ $c->response->header( Location => $location );
+ $c->response->status(302);
+ }
+
+ if ( $c->res->status =~ /^(1\d\d|[23]04)$/ ) {
+ $c->response->headers->remove_content_headers;
return $c->finalize_headers;
}
return $status;
}
+=item $c->finalize_cookies
+
+Finalize cookies.
+
+=cut
+
+sub finalize_cookies {
+ my $c = shift;
+
+ while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
+ my $cookie = CGI::Cookie->new(
+ -name => $name,
+ -value => $cookie->{value},
+ -expires => $cookie->{expires},
+ -domain => $cookie->{domain},
+ -path => $cookie->{path},
+ -secure => $cookie->{secure} || 0
+ );
+
+ $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
+ }
+}
+
=item $c->finalize_headers
Finalize headers.
=cut
-sub handler ($$) {
- my ( $class, $r ) = @_;
+sub handler {
+ my ( $class, $engine ) = @_;
# Always expect worst case!
my $status = -1;
eval {
my @stats = ();
my $handler = sub {
- my $c = $class->prepare($r);
+ my $c = $class->prepare($engine);
$c->{stats} = \@stats;
my $action = $c->req->action;
my $namespace = '';
=cut
-sub prepare_cookies { }
+sub prepare_cookies {
+ my $c = shift;
+
+ if ( my $header = $c->request->header('Cookie') ) {
+ $c->req->cookies( { CGI::Cookie->parse($header) } );
+ }
+}
=item $c->prepare_headers
sub prepare_uploads { }
-=item $c->execute($class, $coderef)
-
-Execute a coderef in given class and catch exceptions.
-Errors are available via $c->error.
-
-=cut
-
-sub execute {
- my ( $c, $class, $code ) = @_;
- $class = $c->comp($class) || $class;
- $c->state(0);
- eval {
- if ( $c->debug )
- {
- my $action = $c->actions->{reverse}->{"$code"};
- $action = "/$action" unless $action =~ /\-\>/;
- my ( $elapsed, @state ) =
- $c->benchmark( $code, $class, $c, @{ $c->req->args } );
- push @{ $c->{stats} },
- _prettify( $action, sprintf( '%fs', $elapsed ), '' );
- $c->state(@state);
- }
- else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
- };
- if ( my $error = $@ ) {
- chomp $error;
- $error = qq/Caught exception "$error"/;
- $c->log->error($error);
- $c->error($error) if $c->debug;
- $c->state(0);
- }
- return $c->state;
-}
-
=item $c->run
Starts the engine.
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;
-
-__PACKAGE__->mk_accessors(qw/apache_request original_request/);
+__PACKAGE__->mk_accessors(qw/apache/);
=head1 NAME
=over 4
-=item $c->apache_request
+=item $c->apache
Returns an C<Apache::Request> object.
-=item $c->original_request
-
-Returns the original Apache request object.
-
=back
=head1 OVERLOADED METHODS
sub finalize_headers {
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) );
+ my @values = $c->response->header($name);
+ $c->apache->headers_out->add( $name => $_ ) for @values;
}
- while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
- my %crunchy = ( -name => $name, -value => $cookie->{value} );
- $crunchy{-expires} = $cookie->{expires} if $cookie->{expires};
- $crunchy{-domain} = $cookie->{domain} if $cookie->{domain};
- $crunchy{-path} = $cookie->{path} if $cookie->{path};
- $crunchy{-secure} = $cookie->{secure} if $cookie->{secure};
- my $cookie = Apache::Cookie->new( $c->original_request, %crunchy );
- MP2
- ? $c->apache_request->err_headers_out->add(
- 'Set-Cookie' => $cookie->as_string )
- : $cookie->bake;
+
+ if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
+ my @values = $c->response->header('Set-Cookie');
+ $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
}
- $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;
+
+ $c->apache->status( $c->response->status );
+ $c->apache->content_type( $c->response->header('Content-Type') );
+
+ unless ( MP2 ) {
+ $c->apache->send_http_header;
+ }
+
return 0;
}
sub finalize_output {
my $c = shift;
- $c->original_request->print( $c->response->{output} );
+ $c->apache->print( $c->response->{output} );
}
=item $c->prepare_connection
sub prepare_connection {
my $c = shift;
- $c->req->hostname( $c->apache_request->connection->remote_host );
- $c->req->address( $c->apache_request->connection->remote_ip );
-}
-
-=item $c->prepare_cookies
-
-=cut
-
-sub prepare_cookies {
- my $c = shift;
- MP2
- ? $c->req->cookies( { Apache::Cookie->fetch } )
- : $c->req->cookies(
- { Apache::Cookie->new( $c->apache_request )->fetch } );
+ $c->request->hostname( $c->apache->connection->remote_host );
+ $c->request->address( $c->apache->connection->remote_ip );
}
=item $c->prepare_headers
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
sub prepare_parameters {
my $c = shift;
my %args;
- foreach my $key ( $c->apache_request->param ) {
- my @values = $c->apache_request->param($key);
+ foreach my $key ( $c->apache->param ) {
+ my @values = $c->apache->param($key);
$args{$key} = @values == 1 ? $values[0] : \@values;
}
- $c->req->parameters( \%args );
+ $c->request->parameters( \%args );
}
=item $c->prepare_path
=cut
+# XXX needs fixing, only work with <Location> directive,
+# not <Directory> 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 );
+ $c->request->base( $base->as_string );
}
=item $c->prepare_request($r)
sub prepare_request {
my ( $c, $r ) = @_;
- $c->apache_request( Apache::Request->new($r) );
- $c->original_request($r);
+ $c->apache( Apache::Request->new($r) );
}
=item $c->prepare_uploads
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 } = {
+ for my $upload ( $c->apache->upload ) {
+ $upload = $c->apache->upload($upload) if MP2;
+ $c->request->uploads->{ $upload->filename } = {
fh => $upload->fh,
size => $upload->size,
type => $upload->type
use URI;
require CGI::Simple;
-require CGI::Cookie;
$CGI::Simple::POST_MAX = 1048576;
$CGI::Simple::DISABLE_UPLOADS = 0;
use Catalyst qw(-Engine=CGI);
-Catalyst::Engine::CGI generates a full set of HTTP headers, which means that
-applications using the engine must be be configured as "Non-parsed Headers"
-scripts (at least when running under Apache). To configure this under Apache
-name the starting with C<nph->.
-
The performance of this way of using Catalyst is not expected to be
useful in production applications, but it may be helpful for development.
sub finalize_headers {
my $c = shift;
my %headers;
+
$headers{-status} = $c->response->status if $c->response->status;
+
for my $name ( $c->response->headers->header_field_names ) {
- $headers{"-$name"} = $c->response->headers->header($name);
+ $headers{"-$name"} = $c->response->header($name);
}
- my @cookies;
- while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
- push @cookies, $c->cgi->cookie(
- -name => $name,
- -value => $cookie->{value},
- -expires => $cookie->{expires},
- -domain => $cookie->{domain},
- -path => $cookie->{path},
- -secure => $cookie->{secure} || 0
- );
- }
- $headers{-cookie} = \@cookies if @cookies;
+
print $c->cgi->header(%headers);
}
$c->req->address( $c->cgi->remote_addr );
}
-=item $c->prepare_cookies
-
-Sets up cookies.
-
-=cut
-
-sub prepare_cookies { shift->req->cookies( { CGI::Cookie->fetch } ) }
-
=item $c->prepare_headers
=cut
}
my $path = $ENV{PATH_INFO} || '/';
+ $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
$path =~ s/^\///;
$c->req->base($base);
$request->uri->host( $request->header('Host') || $base->host );
$request->uri->port( $base->port );
- my $lwp = Catalyst::Engine::Test::LWP->new(
+ my $http = Catalyst::Engine::Test::HTTP->new(
address => $connection->peerhost,
hostname => gethostbyaddr( $connection->peeraddr, AF_INET ),
request => $request,
response => HTTP::Response->new
);
- $class->handler($lwp);
- $connection->send_response( $lwp->response );
+ $class->handler($http);
+ $connection->send_response( $http->response );
}
use strict;
use base 'Catalyst::Engine';
-use CGI::Cookie;
use Class::Struct ();
use HTTP::Headers::Util 'split_header_words';
use HTTP::Request;
use IO::File;
use URI;
-__PACKAGE__->mk_accessors(qw/lwp/);
+__PACKAGE__->mk_accessors(qw/http/);
-Class::Struct::struct 'Catalyst::Engine::Test::LWP' => {
+Class::Struct::struct 'Catalyst::Engine::Test::HTTP' => {
request => 'HTTP::Request',
response => 'HTTP::Response',
hostname => '$',
sub finalize_headers {
my $c = shift;
- $c->lwp->response->code( $c->response->status || 200 );
+ $c->http->response->code( $c->response->status );
for my $name ( $c->response->headers->header_field_names ) {
- $c->lwp->response->push_header( $name => [ $c->response->header($name) ] );
- }
-
- while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
- my $cookie = CGI::Cookie->new(
- -name => $name,
- -value => $cookie->{value},
- -expires => $cookie->{expires},
- -domain => $cookie->{domain},
- -path => $cookie->{path},
- -secure => $cookie->{secure} || 0
- );
-
- $c->lwp->response->headers->push_header( 'Set-Cookie' => $cookie->as_string );
+ $c->http->response->push_header( $name => [ $c->response->header($name) ] );
}
}
sub finalize_output {
my $c = shift;
- $c->lwp->response->content_ref( \$c->response->{output} );
+ $c->http->response->content_ref( \$c->response->{output} );
}
=item $c->prepare_connection
sub prepare_connection {
my $c = shift;
- $c->req->hostname( $c->lwp->hostname );
- $c->req->address( $c->lwp->address );
-}
-
-=item $c->prepare_cookies
-
-=cut
-
-sub prepare_cookies {
- my $c = shift;
-
- if ( my $header = $c->request->header('Cookie') ) {
- $c->req->cookies( { CGI::Cookie->parse($header) } );
- }
+ $c->req->hostname( $c->http->hostname );
+ $c->req->address( $c->http->address );
}
=item $c->prepare_headers
sub prepare_headers {
my $c = shift;
- $c->req->method( $c->lwp->request->method );
- $c->req->headers( $c->lwp->request->headers );
+ $c->req->method( $c->http->request->method );
+ $c->req->headers( $c->http->request->headers );
}
=item $c->prepare_parameters
my $c = shift;
my @params = ();
- my $request = $c->lwp->request;
+ my $request = $c->http->request;
push( @params, $request->uri->query_form );
my $base;
{
- my $scheme = $c->lwp->request->uri->scheme;
- my $host = $c->lwp->request->uri->host;
- my $port = $c->lwp->request->uri->port;
+ my $scheme = $c->http->request->uri->scheme;
+ my $host = $c->http->request->uri->host;
+ my $port = $c->http->request->uri->port;
$base = URI->new;
$base->scheme($scheme);
$base = $base->canonical->as_string;
}
- my $path = $c->lwp->request->uri->path || '/';
+ my $path = $c->http->request->uri->path || '/';
$path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
$path =~ s/^\///;
=cut
sub prepare_request {
- my ( $c, $lwp ) = @_;
- $c->lwp($lwp);
+ my ( $c, $http ) = @_;
+ $c->http($http);
}
=item $c->prepare_uploads
my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
$request->header( 'Host' => $host );
- my $lwp = Catalyst::Engine::Test::LWP->new(
+ my $http = Catalyst::Engine::Test::HTTP->new(
address => '127.0.0.1',
hostname => 'localhost',
request => $request,
response => HTTP::Response->new
);
- $lwp->response->date(time);
+ $http->response->date(time);
- $class->handler($lwp);
+ $class->handler($http);
- return $lwp->response;
+ return $http->response;
}
=back
projects / catagits/Catalyst-Runtime.git / commitdiff