use Catalyst::Response;
use Catalyst::Utils;
use Catalyst::Controller;
+ use Data::OptList;
use Devel::InnerPackage ();
use File::stat;
use Module::Pluggable::Object ();
use attributes;
use utf8;
use Carp qw/croak carp shortmess/;
+use Try::Tiny;
BEGIN { require 5.008004; }
__PACKAGE__->mk_classdata($_)
for qw/components arguments dispatcher engine log dispatcher_class
engine_class context_class request_class response_class stats_class
- setup_finished/;
+ setup_finished psgi_app/;
__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
-__PACKAGE__->engine_class('Catalyst::Engine::CGI');
+__PACKAGE__->engine_class('Catalyst::Engine');
__PACKAGE__->request_class('Catalyst::Request');
__PACKAGE__->response_class('Catalyst::Response');
__PACKAGE__->stats_class('Catalyst::Stats');
# Remember to update this in Catalyst::Runtime as well!
- our $VERSION = '5.80018';
- $VERSION = eval $VERSION;
+ our $VERSION = '5.80024';
sub import {
my ( $class, @arguments ) = @_;
settings override the application, with <MYAPP>_DEBUG having the highest
priority.
+ This sets the log level to 'debug' and enables full debug output on the
+ error screen. If you only want the latter, see L<< $c->debug >>.
+
=head2 -Engine
Forces Catalyst to use a specific engine. Omit the
the name will be replaced with underscores, e.g. MyApp::Web should use
MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
+ If none of these are set, Catalyst will attempt to automatically detect the
+ home directory. If you are working in a development envirnoment, Catalyst
+ will try and find the directory containing either Makefile.PL, Build.PL or
+ dist.ini. If the application has been installed into the system (i.e.
+ you have done C<make install>), then Catalyst will use the path to your
+ application module, without the .pm extension (ie, /foo/MyApp if your
+ application was installed at /foo/MyApp.pm)
+
=head2 -Log
use Catalyst '-Log=warn,fatal,error';
=head2 -Stats
- Enables statistics collection and reporting. You can also force this setting
- from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
- environment settings override the application, with <MYAPP>_STATS having the
- highest priority.
+ Enables statistics collection and reporting.
+
+ use Catalyst qw/-Stats=1/;
- e.g.
+ You can also force this setting from the system environment with CATALYST_STATS
+ or <MYAPP>_STATS. The environment settings override the application, with
+ <MYAPP>_STATS having the highest priority.
- use Catalyst qw/-Stats=1/
+ Stats are also enabled if L<< debugging |/"-Debug" >> is enabled.
=head1 METHODS
need to do something like:
$c->forward('foo');
- die $c->error if $c->error;
+ die join "\n", @{ $c->error } if @{ $c->error };
Or make sure to always return true values from your actions and write
your code like this:
sub controller {
my ( $c, $name, @args ) = @_;
+ my $appclass = ref($c) || $c;
if( $name ) {
+ unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
+ my $comps = $c->components;
+ my $check = $appclass."::Controller::".$name;
+ return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
+ }
my @result = $c->_comp_search_prefixes( $name, qw/Controller C/ );
return map { $c->_filter_component( $_, @args ) } @result if ref $name;
return $c->_filter_component( $result[ 0 ], @args );
my ( $c, $name, @args ) = @_;
my $appclass = ref($c) || $c;
if( $name ) {
+ unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
+ my $comps = $c->components;
+ my $check = $appclass."::Model::".$name;
+ return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
+ }
my @result = $c->_comp_search_prefixes( $name, qw/Model M/ );
return map { $c->_filter_component( $_, @args ) } @result if ref $name;
return $c->_filter_component( $result[ 0 ], @args );
my $appclass = ref($c) || $c;
if( $name ) {
+ unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
+ my $comps = $c->components;
+ my $check = $appclass."::View::".$name;
+ return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
+ }
my @result = $c->_comp_search_prefixes( $name, qw/View V/ );
return map { $c->_filter_component( $_, @args ) } @result if ref $name;
return $c->_filter_component( $result[ 0 ], @args );
=back
+ The first three also set the log level to 'debug'.
+
Calling C<< $c->debug(1) >> has no effect.
=cut
return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE.
}
-
=head2 $app->setup_finalize
- A hook to attach modifiers to.
- Using C<< after setup => sub{}; >> doesn't work, because of quirky things done for plugin setup.
- Also better than C< setup_finished(); >, as that is a getter method.
-
- sub setup_finalize {
+ A hook to attach modifiers to. This method does not do anything except set the
+ C<setup_finished> accessor.
- my $app = shift;
-
- ## do stuff, i.e., determine a primary key column for sessions stored in a DB
+ Applying method modifiers to the C<setup> method doesn't work, because of quirky thingsdone for plugin setup.
- $app->next::method(@_);
+ Example:
+ after setup_finalize => sub {
+ my $app = shift;
- }
+ ## do stuff here..
+ };
=cut
$path .= '/';
}
+ undef($path) if (defined $path && $path eq '');
+
+ my $params =
+ ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
+
+ carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
+ foreach my $arg (@args) {
+ utf8::encode($arg) if utf8::is_utf8($arg);
+ $arg =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
+ }
+
if ( blessed($path) ) { # action object
- my $captures = [ map { s|/|%2F|; $_; }
+ s|/|%2F|g for @args;
+ my $captures = [ map { s|/|%2F|g; $_; }
( scalar @args && ref $args[0] eq 'ARRAY'
? @{ shift(@args) }
: ()) ];
+
+ foreach my $capture (@$captures) {
+ utf8::encode($capture) if utf8::is_utf8($capture);
+ $capture =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
+ }
+
my $action = $path;
$path = $c->dispatcher->uri_for_action($action, $captures);
if (not defined $path) {
$path = '/' if $path eq '';
}
- undef($path) if (defined $path && $path eq '');
-
- my $params =
- ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
-
- carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
- s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
- s|/|%2F| for @args;
-
unshift(@args, $path);
unless (defined $path && $path =~ s!^/!!) { # in-place strip
<a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
<a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
they can save you a lot of work.</p>
- <pre><code>script/${prefix}_create.pl -help</code></pre>
+ <pre><code>script/${prefix}_create.pl --help</code></pre>
<p>Also, be sure to check out the vast and growing
collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
you are likely to find what you need there.
$c->finalize_body;
}
+ $c->log_response;
+
if ($c->use_stats) {
my $elapsed = sprintf '%f', $c->stats->elapsed;
my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
- =head2 $c->handle_request( $class, @arguments )
+ =head2 $app->handle_request( @arguments )
Called to handle each HTTP request.
# Always expect worst case!
my $status = -1;
- eval {
+ try {
if ($class->debug) {
my $secs = time - $START || 1;
my $av = sprintf '%.3f', $COUNT / $secs;
my $c = $class->prepare(@arguments);
$c->dispatch;
$status = $c->finalize;
- };
-
- if ( my $error = $@ ) {
- chomp $error;
- $class->log->error(qq/Caught exception in engine "$error"/);
}
+ catch {
+ chomp(my $error = $_);
+ $class->log->error(qq/Caught exception in engine "$error"/);
+ };
$COUNT++;
#surely this is not the most efficient way to do things...
$c->stats($class->stats_class->new)->enable($c->use_stats);
- if ( $c->debug ) {
+ if ( $c->debug || $c->config->{enable_catalyst_header} ) {
$c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
}
- #XXX reuse coderef from can
- # Allow engine to direct the prepare flow (for POE)
- if ( $c->engine->can('prepare') ) {
- $c->engine->prepare( $c, @arguments );
- }
- else {
- $c->prepare_request(@arguments);
- $c->prepare_connection;
- $c->prepare_query_parameters;
- $c->prepare_headers;
- $c->prepare_cookies;
- $c->prepare_path;
-
- # Prepare the body for reading, either by prepare_body
- # or the user, if they are using $c->read
- $c->prepare_read;
-
- # Parse the body unless the user wants it on-demand
- unless ( ref($c)->config->{parse_on_demand} ) {
- $c->prepare_body;
+ try {
+ # Allow engine to direct the prepare flow (for POE)
+ if ( my $prepare = $c->engine->can('prepare') ) {
+ $c->engine->$prepare( $c, @arguments );
+ }
+ else {
+ $c->prepare_request(@arguments);
+ $c->prepare_connection;
+ $c->prepare_query_parameters;
+ $c->prepare_headers;
+ $c->prepare_cookies;
+ $c->prepare_path;
+
+ # Prepare the body for reading, either by prepare_body
+ # or the user, if they are using $c->read
+ $c->prepare_read;
+
+ # Parse the body unless the user wants it on-demand
+ unless ( ref($c)->config->{parse_on_demand} ) {
+ $c->prepare_body;
+ }
}
}
+ # VERY ugly and probably shouldn't rely on ->finalize actually working
+ catch {
+ # failed prepare is always due to an invalid request, right?
+ $c->response->status(400);
+ $c->response->content_type('text/plain');
+ $c->response->body('Bad Request');
+ $c->finalize;
+ die $_;
+ };
my $method = $c->req->method || '';
my $path = $c->req->path;
$path = '/' unless length $path;
my $address = $c->req->address || '';
- $c->log->debug(qq/"$method" request for "$path" from "$address"/)
- if $c->debug;
+ $c->log_request;
$c->prepare_action;
$c->engine->prepare_body( $c, @_ );
$c->prepare_parameters;
$c->prepare_uploads;
-
- if ( $c->debug && keys %{ $c->req->body_parameters } ) {
- my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
- for my $key ( sort keys %{ $c->req->body_parameters } ) {
- my $param = $c->req->body_parameters->{$key};
- my $value = defined($param) ? $param : '';
- $t->row( $key,
- ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
- }
- $c->log->debug( "Body Parameters are:\n" . $t->draw );
- }
}
=head2 $c->prepare_body_chunk( $chunk )
my $c = shift;
$c->engine->prepare_query_parameters( $c, @_ );
+ }
- if ( $c->debug && keys %{ $c->request->query_parameters } ) {
- my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
- for my $key ( sort keys %{ $c->req->query_parameters } ) {
- my $param = $c->req->query_parameters->{$key};
- my $value = defined($param) ? $param : '';
- $t->row( $key,
- ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
- }
- $c->log->debug( "Query Parameters are:\n" . $t->draw );
+ =head2 $c->log_request
+
+ Writes information about the request to the debug logs. This includes:
+
+ =over 4
+
+ =item * Request method, path, and remote IP address
+
+ =item * Query keywords (see L<Catalyst::Request/query_keywords>)
+
+ =item * Request parameters
+
+ =item * File uploads
+
+ =back
+
+ =cut
+
+ sub log_request {
+ my $c = shift;
+
+ return unless $c->debug;
+
+ my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these;
+ my $request = $dump->[1];
+
+ my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
+ $method ||= '';
+ $path = '/' unless length $path;
+ $address ||= '';
+ $c->log->debug(qq/"$method" request for "$path" from "$address"/);
+
+ $c->log_request_headers($request->headers);
+
+ if ( my $keywords = $request->query_keywords ) {
+ $c->log->debug("Query keywords are: $keywords");
}
+
+ $c->log_request_parameters( query => $request->query_parameters, body => $request->body_parameters );
+
+ $c->log_request_uploads($request);
}
- =head2 $c->prepare_read
+ =head2 $c->log_response
- Prepares the input for reading.
+ Writes information about the response to the debug logs by calling
+ C<< $c->log_response_status_line >> and C<< $c->log_response_headers >>.
=cut
- sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
+ sub log_response {
+ my $c = shift;
- =head2 $c->prepare_request
+ return unless $c->debug;
- Prepares the engine request.
+ my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these;
+ my $response = $dump->[1];
+
+ $c->log_response_status_line($response);
+ $c->log_response_headers($response->headers);
+ }
+
+ =head2 $c->log_response_status_line($response)
+
+ Writes one line of information about the response to the debug logs. This includes:
+
+ =over 4
+
+ =item * Response status code
+
+ =item * Content-Type header (if present)
+
+ =item * Content-Length header (if present)
+
+ =back
=cut
- sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
+ sub log_response_status_line {
+ my ($c, $response) = @_;
- =head2 $c->prepare_uploads
+ $c->log->debug(
+ sprintf(
+ 'Response Code: %s; Content-Type: %s; Content-Length: %s',
+ $response->status || 'unknown',
+ $response->headers->header('Content-Type') || 'unknown',
+ $response->headers->header('Content-Length') || 'unknown'
+ )
+ );
+ }
- Prepares uploads.
+ =head2 $c->log_response_headers($headers);
+
+ Hook method which can be wrapped by plugins to log the responseheaders.
+ No-op in the default implementation.
=cut
- sub prepare_uploads {
- my $c = shift;
+ sub log_response_headers {}
- $c->engine->prepare_uploads( $c, @_ );
+ =head2 $c->log_request_parameters( query => {}, body => {} )
+
+ Logs request parameters to debug logs
+
+ =cut
+
+ sub log_request_parameters {
+ my $c = shift;
+ my %all_params = @_;
+
+ return unless $c->debug;
+
+ my $column_width = Catalyst::Utils::term_width() - 44;
+ foreach my $type (qw(query body)) {
+ my $params = $all_params{$type};
+ next if ! keys %$params;
+ my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
+ for my $key ( sort keys %$params ) {
+ my $param = $params->{$key};
+ my $value = defined($param) ? $param : '';
+ $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+ }
+ $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
+ }
+ }
+
+ =head2 $c->log_request_uploads
+
+ Logs file uploads included in the request to the debug logs.
+ The parameter name, filename, file type, and file size are all included in
+ the debug logs.
+
+ =cut
- if ( $c->debug && keys %{ $c->request->uploads } ) {
+ sub log_request_uploads {
+ my $c = shift;
+ my $request = shift;
+ return unless $c->debug;
+ my $uploads = $request->uploads;
+ if ( keys %$uploads ) {
my $t = Text::SimpleTable->new(
[ 12, 'Parameter' ],
[ 26, 'Filename' ],
[ 18, 'Type' ],
[ 9, 'Size' ]
);
- for my $key ( sort keys %{ $c->request->uploads } ) {
- my $upload = $c->request->uploads->{$key};
+ for my $key ( sort keys %$uploads ) {
+ my $upload = $uploads->{$key};
for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
$t->row( $key, $u->filename, $u->type, $u->size );
}
}
}
+ =head2 $c->log_request_headers($headers);
+
+ Hook method which can be wrapped by plugins to log the request headers.
+ No-op in the default implementation.
+
+ =cut
+
+ sub log_request_headers {}
+
+ =head2 $c->log_headers($type => $headers)
+
+ Logs L<HTTP::Headers> (either request or response) to the debug logs.
+
+ =cut
+
+ sub log_headers {
+ my $c = shift;
+ my $type = shift;
+ my $headers = shift; # an HTTP::Headers instance
+
+ return unless $c->debug;
+
+ my $column_width = Catalyst::Utils::term_width() - 28;
+ my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, 'Value' ] );
+ $headers->scan(
+ sub {
+ my ( $name, $value ) = @_;
+ $t->row( $name, $value );
+ }
+ );
+ $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
+ }
+
+
+ =head2 $c->prepare_read
+
+ Prepares the input for reading.
+
+ =cut
+
+ sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
+
+ =head2 $c->prepare_request
+
+ Prepares the engine request.
+
+ =cut
+
+ sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
+
+ =head2 $c->prepare_uploads
+
+ Prepares uploads.
+
+ =cut
+
+ sub prepare_uploads {
+ my $c = shift;
+
+ $c->engine->prepare_uploads( $c, @_ );
+ }
+
=head2 $c->prepare_write
Prepares the output for writing.
# we know M::P::O found a file on disk so this is safe
Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
}
for my $component (@comps) {
- $class->components->{ $component } = $class->setup_component($component);
- for my $component ($class->expand_component_module( $component, $config )) {
+ my $instance = $class->components->{ $component } = $class->setup_component($component);
+ my @expanded_components = $instance->can('expand_modules')
+ ? $instance->expand_modules( $component, $config )
+ : $class->expand_component_module( $component, $config );
+ for my $component (@expanded_components) {
next if $comps{$component};
- $class->_controller_init_base_classes($component); # Also cover inner packages
$class->components->{ $component } = $class->setup_component($component);
}
}
=cut
- # FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes
- # nearest to Catalyst::Controller first, no matter what order stuff happens
- # to be loaded. There are TODO tests in Moose for this, see
- # f2391d17574eff81d911b97be15ea51080500003
- sub _controller_init_base_classes {
- my ($app_class, $component) = @_;
- return unless $component->isa('Catalyst::Controller');
- foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) {
- Moose::Meta::Class->initialize( $class )
- unless find_meta($class);
- }
- }
-
sub setup_component {
my( $class, $component ) = @_;
=cut
sub setup_engine {
- my ( $class, $engine ) = @_;
-
- if ($engine) {
- $engine = 'Catalyst::Engine::' . $engine;
- }
-
- if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
- $engine = 'Catalyst::Engine::' . $env;
- }
-
- if ( $ENV{MOD_PERL} ) {
- my $meta = Class::MOP::get_metaclass_by_name($class);
-
- # create the apache method
- $meta->add_method('apache' => sub { shift->engine->apache });
-
- my ( $software, $version ) =
- $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
-
- $version =~ s/_//g;
- $version =~ s/(\.[^.]+)\./$1/g;
-
- if ( $software eq 'mod_perl' ) {
-
- if ( !$engine ) {
-
- if ( $version >= 1.99922 ) {
- $engine = 'Catalyst::Engine::Apache2::MP20';
- }
-
- elsif ( $version >= 1.9901 ) {
- $engine = 'Catalyst::Engine::Apache2::MP19';
- }
-
- elsif ( $version >= 1.24 ) {
- $engine = 'Catalyst::Engine::Apache::MP13';
- }
-
- else {
- Catalyst::Exception->throw( message =>
- qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
- }
-
- }
-
- # install the correct mod_perl handler
- if ( $version >= 1.9901 ) {
- *handler = sub : method {
- shift->handle_request(@_);
- };
- }
- else {
- *handler = sub ($$) { shift->handle_request(@_) };
- }
-
- }
-
- elsif ( $software eq 'Zeus-Perl' ) {
- $engine = 'Catalyst::Engine::Zeus';
- }
-
- else {
- Catalyst::Exception->throw(
- message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
- }
- }
+ my ($class, $engine) = @_;
unless ($engine) {
$engine = $class->engine_class;
}
+ $engine = 'Catalyst::Engine::' . $engine
+ unless $engine =~ /^Catalyst::Engine/;
+
+ $engine = 'Catalyst::Engine' if $engine eq 'Catalyst::Engine::HTTP';
Class::MOP::load_class($engine);
);
}
- # engine instance
$class->engine( $engine->new );
+ $class->psgi_app( $class->engine->build_psgi_app($class) );
}
=head2 $c->setup_home
if $plugin->isa( 'Catalyst::Component' );
$proto->_plugins->{$plugin} = 1;
unless ($instant) {
- no strict 'refs';
- if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) {
- my @superclasses = ($plugin, $meta->superclasses );
- $meta->superclasses(@superclasses);
- } else {
- unshift @{"$class\::ISA"}, $plugin;
- }
+ my $meta = Class::MOP::get_metaclass_by_name($class);
+ $meta->superclasses($plugin, $meta->superclasses);
}
return $class;
}
my ( $class, $plugins ) = @_;
$class->_plugins( {} ) unless $class->_plugins;
- $plugins ||= [];
+ $plugins = Data::OptList::mkopt($plugins || []);
- my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins);
+ my @plugins = map {
+ [ Catalyst::Utils::resolve_namespace(
+ $class . '::Plugin',
+ 'Catalyst::Plugin', $_->[0]
+ ),
+ $_->[1],
+ ]
+ } @{ $plugins };
for my $plugin ( reverse @plugins ) {
- Class::MOP::load_class($plugin);
- my $meta = find_meta($plugin);
+ Class::MOP::load_class($plugin->[0], $plugin->[1]);
+ my $meta = find_meta($plugin->[0]);
next if $meta && $meta->isa('Moose::Meta::Role');
- $class->_register_plugin($plugin);
+ $class->_register_plugin($plugin->[0]);
}
my @roles =
- map { $_->name }
- grep { $_ && blessed($_) && $_->isa('Moose::Meta::Role') }
- map { find_meta($_) }
+ map { $_->[0]->name, $_->[1] }
+ grep { blessed($_->[0]) && $_->[0]->isa('Moose::Meta::Role') }
+ map { [find_meta($_->[0]), $_->[1]] }
@plugins;
Moose::Util::apply_all_roles(
Returns an arrayref of the internal execution stack (actions that are
currently executing).
+ =head2 $c->stats
+
+ Returns the current timing statistics object. By default Catalyst uses
+ L<Catalyst::Stats|Catalyst::Stats>, but can be set otherwise with
+ L<< stats_class|/"$c->stats_class" >>.
+
+ Even if L<< -Stats|/"-Stats" >> is not enabled, the stats object is still
+ available. By enabling it with C< $c->stats->enabled(1) >, it can be used to
+ profile explicitly, although MyApp.pm still won't profile nor output anything
+ by itself.
+
=head2 $c->stats_class
- Returns or sets the stats (timing statistics) class.
+ Returns or sets the stats (timing statistics) class. L<Catalyst::Stats|Catalyst::Stats> is used by default.
=head2 $c->use_stats
- Returns 1 when stats collection is enabled. Stats collection is enabled
- when the -Stats options is set, debug is on or when the <MYAPP>_STATS
- environment variable is set.
+ Returns 1 when L<< stats collection|/"-Stats" >> is enabled.
Note that this is a static method, not an accessor and should be overridden
by declaring C<sub use_stats { 1 }> in your MyApp.pm, not by calling C<< $c->use_stats(1) >>.
=item *
+ C<use_request_uri_for_path> - Controlls if the C<REQUEST_URI> or C<PATH_INFO> environment
+ variable should be used for determining the request path. See L<Catalyst::Engine::CGI/PATH DECODING>
+ for more information.
+
+ =item *
+
C<using_frontend_proxy> - See L</PROXY SUPPORT>.
=back
Robert Sedlacek C<< <rs@474.at> >>
+ SpiceMan: Marcel Montes
+
sky: Arthur Bergman
+ szbalint: Balint Szilakszi <szbalint@cpan.org>
+
t0m: Tomas Doran <bobtfish@bobtfish.net>
Ulf Edvinsson
willert: Sebastian Willert <willert@cpan.org>
+ wreis: Wallace Reis <wallace@reis.org.br>
+
Yuval Kogman, C<nothingmuch@woobling.org>
=head1 LICENSE
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
+use Moose::Util::TypeConstraints;
+use Plack::Loader;
+use Plack::Middleware::Conditional;
+use Plack::Middleware::ReverseProxy;
use namespace::clean -except => 'meta';
-has env => (is => 'rw');
+has env => (is => 'ro', writer => '_set_env', clearer => '_clear_env');
# input position and length
has read_length => (is => 'rw');
has _prepared_write => (is => 'rw');
+has _response_cb => (
+ is => 'ro',
+ isa => 'CodeRef',
+ writer => '_set_response_cb',
+ clearer => '_clear_response_cb',
+);
+
+has _writer => (
+ is => 'ro',
+ isa => duck_type([qw(write close)]),
+ writer => '_set_writer',
+ clearer => '_clear_writer',
+);
+
# Amount of data to read from input on each pass
our $CHUNKSIZE = 64 * 1024;
else {
$self->write( $c, $body );
}
+
+ $self->_writer->close;
+ $self->_clear_writer;
+ $self->_clear_env;
+
+ return;
}
=head2 $self->finalize_cookies($c)
=cut
-sub finalize_headers { }
+sub finalize_headers {
+ my ($self, $ctx) = @_;
+
+ my @headers;
+ $ctx->response->headers->scan(sub { push @headers, @_ });
+
+ $self->_set_writer($self->_response_cb->([ $ctx->response->status, \@headers ]));
+ $self->_clear_response_cb;
+
+ return;
+}
=head2 $self->finalize_read($c)
sub finalize_uploads {
my ( $self, $c ) = @_;
+ # N.B. This code is theoretically entirely unneeded due to ->cleanup(1)
+ # on the HTTP::Body object.
my $request = $c->request;
foreach my $key (keys %{ $request->uploads }) {
my $upload = $request->uploads->{$key};
unless ( $request->_body ) {
my $type = $request->header('Content-Type');
$request->_body(HTTP::Body->new( $type, $length ));
+ $request->_body->cleanup(1); # Make extra sure!
$request->_body->tmpdir( $appclass->config->{uploadtmp} )
if exists $appclass->config->{uploadtmp};
}
=cut
-sub prepare_connection { }
+sub prepare_connection {
+ my ($self, $ctx) = @_;
+
+ my $env = $self->env;
+ my $request = $ctx->request;
+
+ $request->address( $env->{REMOTE_ADDR} );
+ $request->hostname( $env->{REMOTE_HOST} )
+ if exists $env->{REMOTE_HOST};
+ $request->protocol( $env->{SERVER_PROTOCOL} );
+ $request->remote_user( $env->{REMOTE_USER} );
+ $request->method( $env->{REQUEST_METHOD} );
+ $request->secure( $env->{'psgi.url_scheme'} eq 'https' ? 1 : 0 );
+
+ return;
+}
=head2 $self->prepare_cookies($c)
=cut
-sub prepare_headers { }
+sub prepare_headers {
+ my ($self, $ctx) = @_;
+
+ my $env = $self->env;
+ my $headers = $ctx->request->headers;
+
+ for my $header (keys %{ $env }) {
+ next unless $header =~ /^(HTTP|CONTENT|COOKIE)/i;
+ (my $field = $header) =~ s/^HTTPS?_//;
+ $field =~ tr/_/-/;
+ $headers->header($field => $env->{$header});
+ }
+}
=head2 $self->prepare_parameters($c)
=cut
-sub prepare_path { }
+sub prepare_path {
+ my ($self, $ctx) = @_;
+
+ my $env = $self->env;
+
+ my $scheme = $ctx->request->secure ? 'https' : 'http';
+ my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME};
+ my $port = $env->{SERVER_PORT} || 80;
+ my $base_path = $env->{SCRIPT_NAME} || "/";
+
+ # set the request URI
+ my $req_uri = $env->{REQUEST_URI};
+ $req_uri =~ s/\?.*$//;
+ my $path = $req_uri;
+ $path =~ s{^/+}{};
+
+ # Using URI directly is way too slow, so we construct the URLs manually
+ my $uri_class = "URI::$scheme";
+
+ # HTTP_HOST will include the port even if it's 80/443
+ $host =~ s/:(?:80|443)$//;
+
+ if ($port !~ /^(?:80|443)$/ && $host !~ /:/) {
+ $host .= ":$port";
+ }
+
+ my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : '';
+ my $uri = $scheme . '://' . $host . '/' . $path . $query;
+
+ $ctx->request->uri( (bless \$uri, $uri_class)->canonical );
+
+ # set the base URI
+ # base must end in a slash
+ $base_path .= '/' unless $base_path =~ m{/$};
+
+ my $base_uri = $scheme . '://' . $host . $base_path;
+
+ $ctx->request->base( bless \$base_uri, $uri_class );
+
+ return;
+}
=head2 $self->prepare_request($c)
=cut
sub prepare_query_parameters {
- my ( $self, $c, $query_string ) = @_;
+ my ($self, $c) = @_;
+
+ my $query_string = exists $self->env->{QUERY_STRING}
+ ? $self->env->{QUERY_STRING}
+ : '';
# Check for keywords (no = signs)
# (yes, index() is faster than a regex :))
=cut
-sub prepare_request { }
+sub prepare_request {
+ my ($self, $ctx, %args) = @_;
+ $self->_set_env($args{env});
+}
=head2 $self->prepare_uploads($c)
my $u = Catalyst::Request::Upload->new
(
size => $upload->{size},
- type => $headers->content_type,
+ type => scalar $headers->content_type,
headers => $headers,
tempname => $upload->{tempname},
filename => $upload->{filename},
my $rc = $self->read_chunk( $c, my $buffer, $readlen );
if ( defined $rc ) {
if (0 == $rc) { # Nothing more to read even though Content-Length
- # said there should be. FIXME - Warn in the log here?
+ # said there should be.
$self->finalize_read;
return;
}
=cut
-sub read_chunk { }
+sub read_chunk {
+ my ($self, $ctx) = (shift, shift);
+ return $self->env->{'psgi.input'}->read(@_);
+}
=head2 $self->read_length
The amount of input data that has already been read.
-=head2 $self->run($c)
+=head2 $self->run($app, $server)
+
+Start the engine. Builds a PSGI application and calls the
+run method on the server passed in..
+
+=cut
+
+sub run {
+ my ($self, $app, @args) = @_;
+ my $server = pop @args if blessed $args[-1];
+ $server ||= Plack::Loader->auto(); # We're not being called from a script,
+ # so auto detect what backend to run on.
+ # This does *NOT* cover mod_perl.
+ # FIXME - Do something sensible with the options we're passed
+ my $psgi = $self->build_psgi_app($app, @args);
+ $server->run($psgi);
+}
+
+=head2 build_psgi_app ($app, @args)
-Start the engine. Implemented by the various engine classes.
+Builds and returns a PSGI application closure, wrapping it in the reverse proxy
+middleware if the using_frontend_proxy config setting is set.
=cut
-sub run { }
+sub build_psgi_app {
+ my ($self, $app, @args) = @_;
+
+ my $psgi_app = sub {
+ my ($env) = @_;
+
+ return sub {
+ my ($respond) = @_;
+ $self->_set_response_cb($respond);
+ $app->handle_request(env => $env);
+ };
+ };
+
+ $psgi_app = Plack::Middleware::Conditional->wrap(
+ $psgi_app,
+ condition => sub {
+ my ($env) = @_;
+ return if $app->config->{ignore_frontend_proxy};
+ return $env->{REMOTE_ADDR} eq '127.0.0.1' || $app->config->{using_frontend_proxy};
+ },
+ builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) },
+ );
+
+ return $psgi_app;
+}
=head2 $self->write($c, $buffer)
return 0 if !defined $buffer;
- my $len = length($buffer);
- my $wrote = syswrite STDOUT, $buffer;
-
- if ( !defined $wrote && $! == EWOULDBLOCK ) {
- # Unable to write on the first try, will retry in the loop below
- $wrote = 0;
- }
-
- if ( defined $wrote && $wrote < $len ) {
- # We didn't write the whole buffer
- while (1) {
- my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
- if ( defined $ret ) {
- $wrote += $ret;
- }
- else {
- next if $! == EWOULDBLOCK;
- return;
- }
-
- last if $wrote >= $len;
- }
- }
+ my $len = length($buffer);
+ $self->_writer->write($buffer);
- return $wrote;
+ return $len;
}
=head2 $self->unescape_uri($uri)
=head2 $self->env
- Hash containing enviroment variables including many special variables inserted
+ Hash containing environment variables including many special variables inserted
by WWW server - like SERVER_*, REMOTE_*, HTTP_* ...
- Before accesing enviroment variables consider whether the same information is
+ Before accessing environment variables consider whether the same information is
not directly available via Catalyst objects $c->request, $c->engine ...
- BEWARE: If you really need to access some enviroment variable from your Catalyst
+ BEWARE: If you really need to access some environment variable from your Catalyst
application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME},
as in some enviroments the %ENV hash does not contain what you would expect.
projects / catagits/Catalyst-Runtime.git / commitdiff