X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst.pm;h=61e280339eff1f5f096695573b435a199a64fed4;hb=41c0e09a56ab8ea4cc2dc249e7989101169189d0;hp=55999f718dce84824f6f1e87cbe556952b7043ce;hpb=1532731f364575815508332571f6a4a2c804940d;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 55999f7..61e2803 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -15,9 +15,7 @@ use Catalyst::Response; use Catalyst::Utils; use Catalyst::Controller; use Data::OptList; -use Devel::InnerPackage (); use File::stat; -use Module::Pluggable::Object (); use Text::SimpleTable (); use Path::Class::Dir (); use Path::Class::File (); @@ -27,11 +25,17 @@ use URI::https; use Tree::Simple qw/use_weak_refs/; use Tree::Simple::Visitor::FindByUID; use Class::C3::Adopt::NEXT; -use List::Util qw/first/; use List::MoreUtils qw/uniq/; use attributes; +use String::RewritePrefix; +use Catalyst::EngineLoader; use utf8; use Carp qw/croak carp shortmess/; +use Try::Tiny; +use Plack::Middleware::Conditional; +use Plack::Middleware::ReverseProxy; +use Plack::Middleware::IIS6ScriptNameFix; +use Plack::Middleware::LighttpdScriptNameFix; BEGIN { require 5.008004; } @@ -67,20 +71,19 @@ our $GO = Catalyst::Exception::Go->new; #I imagine that very few of these really need to be class variables. if any. #maybe we should just make them attributes with a default? -__PACKAGE__->mk_classdata($_) # XXX FIXME - components remove from here - for qw/container components arguments dispatcher engine log dispatcher_class - engine_class context_class request_class response_class stats_class - setup_finished/; +__PACKAGE__->mk_classdata($_) + for qw/container arguments dispatcher engine log dispatcher_class + engine_loader context_class request_class response_class stats_class + setup_finished _psgi_app loading_psgi_file/; __PACKAGE__->dispatcher_class('Catalyst::Dispatcher'); -__PACKAGE__->engine_class('Catalyst::Engine::CGI'); __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.80032'; +our $VERSION = '5.90005'; sub import { my ( $class, @arguments ) = @_; @@ -95,7 +98,7 @@ sub import { my $meta = Moose::Meta::Class->initialize($caller); unless ( $caller->isa('Catalyst') ) { # XXX - Remove! - my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller'); # XXX - Remove! + my @superclasses = ($meta->superclasses, $class, 'Catalyst::Component'); # XXX - Remove! $meta->superclasses(@superclasses); # XXX - Remove! } # XXX - Remove! @@ -115,6 +118,15 @@ sub import { $caller->setup_home; } +sub MODIFY_CODE_ATTRIBUTES { + Catalyst::Exception->throw( + "Catalyst applications (aka MyApp) cannot be controllers anymore. " . + "That has been deprecated and removed. You should create a " . + "controller class called Root.pm, and move relevant code to that class." + ); +} + + sub _application { $_[0] } =head1 NAME @@ -146,7 +158,7 @@ documentation and tutorials. use Catalyst qw/-Debug/; # include plugins here as well ### In lib/MyApp/Controller/Root.pm (autocreated) - sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc. + sub foo : Chained('/') Args() { # called for /foo, /foo/1, /foo/1/2, etc. my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2 $c->stash->{template} = 'foo.tt'; # set the template # lookup something from db -- stash vars are passed to TT @@ -164,50 +176,16 @@ documentation and tutorials. [% END %] # called for /bar/of/soap, /bar/of/soap/10, etc. - sub bar : Path('/bar/of/soap') { ... } - - # called for all actions, from the top-most controller downwards - sub auto : Private { - my ( $self, $c ) = @_; - if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication - $c->res->redirect( '/login' ); # require login - return 0; # abort request and go immediately to end() - } - return 1; # success; carry on to next action - } + sub bar : Chained('/') PathPart('/bar/of/soap') Args() { ... } # called after all actions are finished - sub end : Private { + sub end : Action { my ( $self, $c ) = @_; if ( scalar @{ $c->error } ) { ... } # handle errors return if $c->res->body; # already have a response $c->forward( 'MyApp::View::TT' ); # render template } - ### in MyApp/Controller/Foo.pm - # called for /foo/bar - sub bar : Local { ... } - - # called for /blargle - sub blargle : Global { ... } - - # an index action matches /foo, but not /foo/1, etc. - sub index : Private { ... } - - ### in MyApp/Controller/Foo/Bar.pm - # called for /foo/bar/baz - sub baz : Local { ... } - - # first Root auto is called, then Foo auto, then this - sub auto : Private { ... } - - # powerful regular expression paths are also possible - sub details : Regex('^product/(\w+)/details$') { - my ( $self, $c ) = @_; - # extract the (\w+) from the URI - my $product = $c->req->captures->[0]; - } - See L for additional information. =head1 DESCRIPTION @@ -234,7 +212,7 @@ fully qualify the name by using a unary plus: +Fully::Qualified::Plugin::Name /; -Special flags like C<-Debug> and C<-Engine> can also be specified as +Special flags like C<-Debug> can also be specified as arguments when Catalyst is loaded: use Catalyst qw/-Debug My::Module/; @@ -254,13 +232,6 @@ 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 -C prefix of the engine name, i.e.: - - use Catalyst qw/-Engine=CGI/; - =head2 -Home Forces Catalyst to use a specific home directory, e.g.: @@ -274,11 +245,11 @@ 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 +home directory. If you are working in a development environment, 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), then Catalyst will use the path to your -application module, without the .pm extension (ie, /foo/MyApp if your +application module, without the .pm extension (e.g., /foo/MyApp if your application was installed at /foo/MyApp.pm) =head2 -Log @@ -346,9 +317,10 @@ call to forward. Note that L<< forward|/"$c->forward( $action [, \@arguments ] )" >> implies an C<< eval { } >> around the call (actually -L<< execute|/"$c->execute( $class, $coderef )" >> does), thus de-fatalizing -all 'dies' within the called action. If you want C to propagate you -need to do something like: +L<< execute|/"$c->execute( $class, $coderef )" >> does), thus rendering all +exceptions thrown by the called action non-fatal and pushing them onto +$c->error instead. If you want C to propagate you need to do something +like: $c->forward('foo'); die join "\n", @{ $c->error } if @{ $c->error }; @@ -410,7 +382,7 @@ L return information for the visited action when they are invoked within the visited action. This is different from the behavior of L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, which continues to use the $c->action object from the caller action even when -invoked from the callee. +invoked from the called action. C<< $c->stash >> is kept unchanged. @@ -558,13 +530,7 @@ If you want to search for controllers, pass in a regexp as the argument. =cut -sub controller { - my ( $c, $name, @args ) = @_; - - $name ||= Catalyst::Utils::class2classshortsuffix( $c->action->class ); - - return $c->container->get_component_from_sub_container( 'controller', $name, $c, @args); -} +sub controller { shift->_lookup_mvc('controller', @_) } =head2 $c->model($name) @@ -587,20 +553,7 @@ If you want to search for models, pass in a regexp as the argument. =cut -sub model { - my ( $c, $name, @args ) = @_; - - if (ref $c && !$name) { - return $c->stash->{current_model_instance} - if $c->stash->{current_model_instance}; - - $name = $c->stash->{current_model} - if $c->stash->{current_model}; - } - - return $c->container->get_component_from_sub_container( 'model', $name, $c, @args); -} - +sub model { shift->_lookup_mvc('model', @_) } =head2 $c->view($name) @@ -623,18 +576,23 @@ If you want to search for views, pass in a regexp as the argument. =cut -sub view { - my ( $c, $name, @args ) = @_; +sub view { shift->_lookup_mvc('view', @_) } + +sub _lookup_mvc { + my ( $c, $type, $name, @args ) = @_; if (ref $c && !$name) { - return $c->stash->{current_view_instance} - if $c->stash->{current_view_instance}; + my $current_instance = $c->stash->{"current_${type}_instance"}; + return $current_instance + if $current_instance && $type ne 'controller'; - $name = $c->stash->{current_view} - if $c->stash->{current_view}; + $name = $type eq 'controller' + ? Catalyst::Utils::class2classshortsuffix($c->action->class) + : $c->stash->{"current_${type}"} + ; } - return $c->container->get_component_from_sub_container( 'view', $name, $c, @args); + return $c->container->get_component_from_sub_container($type, $name, $c, @args); } =head2 $c->controllers @@ -695,12 +653,6 @@ sub component { return $c->component_list; } - my ($type, $name) = _get_component_type_name($component); - - return $c->container->get_component_from_sub_container( - $type, $name, $c, @args - ) if $type; - my @result = $c->container->find_component( $component, $c, @args ); # list context for regexp searches @@ -709,10 +661,11 @@ sub component { # only one component (if it's found) for string searches return shift @result if @result; - # FIXME: I probably shouldn't be doing this - # I'm keeping it temporarily for things like $c->comp('MyApp') - return $c->components->{$component} - if exists $c->components->{$component} and !@args; + if (ref $c eq $component) { + $c->log->warn('You are calling $c->comp("MyApp"). This behaviour is'); + $c->log->warn('deprecated, and will be removed in a future release.'); + return $c; + } $c->log->warn("Looking for '$component', but nothing was found."); @@ -879,26 +832,12 @@ sub path_to { else { return Path::Class::File->new( $c->config->{home}, @path ) } } -=head2 $c->plugin( $name, $class, @args ) - -Helper method for plugins. It creates a class data accessor/mutator and -loads and instantiates the given class. - - MyApp->plugin( 'prototype', 'HTML::Prototype' ); - - $c->prototype->define_javascript_functions; - -B This method of adding plugins is deprecated. The ability -to add plugins like this B in a Catalyst 5.81. -Please do not use this functionality in new code. - -=cut - sub plugin { my ( $class, $name, $plugin, @args ) = @_; # See block comment in t/aggregate/unit_core_plugin.t - $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/); + # See block comment in t/unit_core_plugin.t + $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in a future release/); $class->_register_plugin( $plugin, 1 ); @@ -927,6 +866,9 @@ Catalyst> line. MyApp->setup; MyApp->setup( qw/-Debug/ ); +B You B wrap this method with method modifiers +or bad things will happen - wrap the C method instead. + =cut sub setup { @@ -967,7 +909,10 @@ sub setup { $class->setup_log( delete $flags->{log} ); $class->setup_plugins( delete $flags->{plugins} ); $class->setup_dispatcher( delete $flags->{dispatcher} ); - $class->setup_engine( delete $flags->{engine} ); + if (my $engine = delete $flags->{engine}) { + $class->log->warn("Specifying the engine in ->setup is no longer supported, see Catalyst::Upgrading"); + } + $class->setup_engine(); $class->setup_stats( delete $flags->{stats} ); for my $flag ( sort keys %{$flags} ) { @@ -1026,25 +971,17 @@ EOF $class->setup unless $Catalyst::__AM_RESTARTING; } - # Initialize our data structure - $class->components( {} ); # XXX - Remove! - $class->setup_components; - if ( $class->debug ) { # XXX - Fixme to be a method on the container? (Or at least get a) data structure back from the container!! + if ( + $class->debug and + my $comps = $class->container->get_all_components($class) + ) { my $column_width = Catalyst::Utils::term_width() - 8 - 9; my $t = Text::SimpleTable->new( [ $column_width, 'Class' ], [ 8, 'Type' ] ); - for my $comp ( sort keys %{ $class->components } ) { - my $type = ref $class->components->{$comp} ? 'instance' : 'class'; - $t->row( $comp, $type ); - } - $class->log->debug( "Loaded components:\n" . $t->draw . "\n" ) - if ( keys %{ $class->components } ); - } + $t->row( $_ => ref($comps->{$_}) ? 'instance' : 'class' ) for keys %$comps; - # Add our self to components, since we are also a component - if( $class->isa('Catalyst::Controller') ){ - $class->components->{$class} = $class; + $class->log->debug( "Loaded components:\n" . $t->draw . "\n" ); } $class->setup_actions; @@ -1189,7 +1126,15 @@ sub uri_for { } my $action = $path; - $path = $c->dispatcher->uri_for_action($action, $captures); + # ->uri_for( $action, \@captures_and_args, \%query_values? ) + if( !@args && $action->number_of_args ) { + my $expanded_action = $c->dispatcher->expand_action( $action ); + + my $num_captures = $expanded_action->number_of_captures; + unshift @args, splice @$captures, $num_captures; + } + + $path = $c->dispatcher->uri_for_action($action, $captures); if (not defined $path) { $c->log->debug(qq/Can't find uri_for action '$action' @$captures/) if $c->debug; @@ -1240,9 +1185,9 @@ sub uri_for { $res; } -=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? ) +=head2 $c->uri_for_action( $path, \@captures_and_args?, @args?, \%query_values? ) -=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? ) +=head2 $c->uri_for_action( $action, \@captures_and_args?, @args?, \%query_values? ) =over @@ -1271,6 +1216,30 @@ You can use: and it will create the URI /users/the-list. +=item \@captures_and_args? + +Optional array reference of Captures (i.e. C<req->captures>) +and arguments to the request. Usually used with L +to interpolate all the parameters in the URI. + +=item @args? + +Optional list of extra arguments - can be supplied in the C<< \@captures_and_args? >> +array ref, or here - whichever is easier for your code.. + +If your action may have a zero, a fixed or a variable number of args (e.g. C<< Args(1) >> +for a fixed number or C<< Args() >> for a variable number).. + +=item \%query_values? + +Optional array reference of query parameters to append. E.g. + + { foo => 'bar' } + +will generate + + /rest/of/your/uri?foo=bar + =back =cut @@ -1444,36 +1413,20 @@ Returns a hash of components. =cut -# FIXME - We deal with ->components({'Foo' => 'Bar'}) -# however we DO NOT deal with ->components->{Foo} = 'Bar' -# We should return a locked hash back to the user? So that if they try the latter, they -# get breakage, rather than their addition being silently ignored? -around components => sub { - my $orig = shift; - my $class = shift; - my $comps = shift; - - return $class->$orig if ( !$comps ); - -# FIXME: should this ugly kludge exist? - $class->setup_config unless defined $class->container; - -# FIXME: should there be a warning here, not to use this accessor to create the components? - my $components = {}; - - my $containers; - $containers->{$_} = $class->container->get_sub_container($_) for qw(model view controller); +sub components { + my ( $class, $comps ) = @_; - for my $component ( keys %$comps ) { - $components->{ $component } = $comps->{$component}; + # people create components calling this sub directly, before setup + $class->setup_config unless $class->container; - my ($type, $name) = _get_component_type_name($component); + my $container = $class->container; - $containers->{$type}->add_service(Catalyst::IOC::BlockInjection->new( name => $name, block => sub { return $class->setup_component($component) } )); + if ( $comps ) { + $container->add_component( $_ ) for keys %$comps; } - return $class->$orig($components); -}; + return $container->get_all_components($class); +} =head2 $c->context_class @@ -1738,9 +1691,18 @@ sub finalize_headers { if ( !$response->has_body ) { # Add a default body if none is already present - $response->body( - qq{

This item has moved here.

} - ); + $response->body(<<"EOF"); + + + + Moved + + +

This item has moved here.

+ + +EOF + $response->content_type('text/html; charset=utf-8'); } } @@ -1750,9 +1712,9 @@ sub finalize_headers { # get the length from a filehandle if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' ) { - my $stat = stat $response->body; - if ( $stat && $stat->size > 0 ) { - $response->content_length( $stat->size ); + my $size = -s $response->body; + if ( $size ) { + $response->content_length( $size ); } else { $c->log->warn('Serving filehandle without a content-length'); @@ -1826,7 +1788,7 @@ sub handle_request { # Always expect worst case! my $status = -1; - eval { + try { if ($class->debug) { my $secs = time - $START || 1; my $av = sprintf '%.3f', $COUNT / $secs; @@ -1837,12 +1799,11 @@ sub handle_request { 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++; @@ -1852,7 +1813,7 @@ sub handle_request { return $status; } -=head2 $c->prepare( @arguments ) +=head2 $class->prepare( @arguments ) Creates a Catalyst context from an engine-specific request (Apache, CGI, etc.). @@ -1879,28 +1840,38 @@ sub prepare { $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; @@ -2115,7 +2086,7 @@ sub log_response_status_line { =head2 $c->log_response_headers($headers); -Hook method which can be wrapped by plugins to log the responseheaders. +Hook method which can be wrapped by plugins to log the response headers. No-op in the default implementation. =cut @@ -2279,7 +2250,12 @@ Starts the engine. =cut -sub run { my $c = shift; return $c->engine->run( $c, @_ ) } +sub run { + my $app = shift; + $app->engine_loader->needs_psgi_engine_compat_hack ? + $app->engine->run($app, @_) : + $app->engine->run( $app, $app->_finalized_psgi_app, @_ ); +} =head2 $c->set_action( $action, $code, $namespace, $attrs ) @@ -2306,15 +2282,20 @@ sub setup_config { my %args = %{ $class->config || {} }; - my @container_classes = ( "${class}::Container", 'Catalyst::IOC::Container'); - unshift @container_classes, delete $args{container_class} if exists $args{container_class}; + my $container_class; - my $container_class = Class::MOP::load_first_existing_class(@container_classes); + if ( exists $args{container_class} ) { + $container_class = delete $args{container_class}; + Class::MOP::load_class($container_class); + } + else { + $container_class = Class::MOP::load_first_existing_class("${class}::Container", 'Catalyst::IOC::Container'); + } - my $container = $container_class->new( %args, name => "$class" ); + my $container = $container_class->new( %args, application_name => "$class", name => "$class" ); $class->container($container); - my $config = $container->resolve(service => 'config'); + my $config = $container->resolve( service => 'config' ); $class->config($config); $class->finalize_config; # back-compat } @@ -2330,191 +2311,29 @@ sub finalize_config { } This method is called internally to set up the application's components. It finds modules by calling the L method, expands them to -package names with the L method, and then installs -each component into the application. +package names with the $container->expand_component_module method, and then +installs each component into the application. The C config option is passed to both of the above methods. -Installation of each component is performed by the L method, -below. - =cut -sub setup_components { - my $class = shift; - - my $config = $class->config->{ setup_components }; - my $search_extra = $config->{ search_extra }; - - my @comps = $class->locate_components($config); - my %comps = map { $_ => 1 } @comps; - - my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps; - $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}. - qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n} - ) if $deprecatedcatalyst_component_names; - - for my $component ( @comps ) { - - # We pass ignore_loaded here so that overlay files for (e.g.) - # Model::DBI::Schema sub-classes are loaded - if it's in @comps - # we know M::P::O found a file on disk so this is safe - - Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } ); - } - - my $containers; - $containers->{$_} = $class->container->get_sub_container($_) for qw(model view controller); - - for my $component (@comps) { - my $instance = $class->components->{ $component } = $class->setup_component($component); - if ( my ($type, $name) = _get_component_type_name($component, $search_extra) ) { - $containers->{$type}->add_service(Catalyst::IOC::BlockInjection->new( name => $name, block => sub { return $instance } )); - } - 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}; - - $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @expanded_components; - $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}. - qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n} - ) if $deprecatedcatalyst_component_names; - - if (my ($type, $name) = _get_component_type_name($component, $search_extra)) { - $containers->{$type}->add_service(Catalyst::IOC::BlockInjection->new( name => $name, block => sub { return $class->setup_component($component) } )); - } - - # FIXME - Remove this!! - $class->components->{ $component } = $class->setup_component($component); - } - } - - $containers->{model}->make_single_default; - $containers->{view}->make_single_default; -} - -# FIXME: should this sub exist? -# should it be moved to Catalyst::Utils, -# or replaced by something already existing there? -sub _get_component_type_name { - my ( $component, $search_extra) = @_; - $search_extra ||= []; - my @search_extra = map { s/^:://; lc $_ } @$search_extra; - - my @parts = split /::/, $component; - - if (scalar @parts == 1) { - return (undef, $component); - } - - while (my $type = shift @parts) { - return ('controller', join '::', @parts) - if $type =~ /^(c|controller)$/i; - - return ('model', join '::', @parts) - if $type =~ /^(m|model)$/i; - - return ('view', join '::', @parts) - if $type =~ /^(v|view)$/i; - - return (_get_component_type($component), join '::', @parts) - if @search_extra and ( grep { lc $type eq $_ } @search_extra ); - } -} - -sub _get_component_type { - my ( $instance ) = @_; - - return 'controller' if $instance->isa('Catalyst::Controller'); - return 'model' if $instance->isa('Catalyst::Model'); - return 'view' if $instance->isa('Catalyst::View'); -} +sub setup_components { shift->container->setup_components } -=head2 $c->locate_components( $setup_component_config ) - -This method is meant to provide a list of component modules that should be -setup for the application. By default, it will use L. - -Specify a C config option to pass additional options directly -to L. To add additional search paths, specify a key named -C as an array reference. Items in the array beginning with C<::> -will have the application class name prepended to them. +=head2 locate_components =cut sub locate_components { - my $class = shift; - my $config = shift; - - my @paths = qw( ::Controller ::C ::Model ::M ::View ::V ); - my $extra = delete $config->{ search_extra } || []; - - push @paths, @$extra; + my $class = shift; - my $locator = Module::Pluggable::Object->new( - search_path => [ map { s/^(?=::)/$class/; $_; } @paths ], - %$config - ); + $class->log->warn('The locate_components method has been deprecated.'); + $class->log->warn('Please read Catalyst::IOC::Container documentation to'); + $class->log->warn('update your application.'); # XXX think about ditching this sort entirely - my @comps = sort { length $a <=> length $b } $locator->plugins; - - return @comps; -} - -=head2 $c->expand_component_module( $component, $setup_component_config ) - -Components found by C will be passed to this method, which -is expected to return a list of component (package) names to be set up. - -=cut - -sub expand_component_module { - my ($class, $module) = @_; - return Devel::InnerPackage::list_packages( $module ); -} - -=head2 $c->setup_component - -=cut - -## FIXME - Why the hell do we try calling the ->COMPONENT method twice, this is madness!?! -sub setup_component { - my( $class, $component ) = @_; - - unless ( $component->can( 'COMPONENT' ) ) { - return $component; - } - - my $suffix = Catalyst::Utils::class2classsuffix( $component ); - my $config = $class->config->{ $suffix } || {}; - # Stash catalyst_component_name in the config here, so that custom COMPONENT - # methods also pass it. local to avoid pointlessly shitting in config - # for the debug screen, as $component is already the key name. - local $config->{catalyst_component_name} = $component; - - my $instance = eval { $component->COMPONENT( $class, $config ); }; - - if ( my $error = $@ ) { - chomp $error; - Catalyst::Exception->throw( - message => qq/Couldn't instantiate component "$component", "$error"/ - ); - } - elsif (!blessed $instance) { - my $metaclass = Moose::Util::find_meta($component); - my $method_meta = $metaclass->find_method_by_name('COMPONENT'); - my $component_method_from = $method_meta->associated_metaclass->name; - my $value = defined($instance) ? $instance : 'undef'; - Catalyst::Exception->throw( - message => - qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./ - ); - } - - return $instance; + return sort { length $a <=> length $b } + @{ $class->container->resolve( service => 'locate_components' ) }; } =head2 $c->setup_dispatcher @@ -2550,114 +2369,171 @@ Sets up engine. =cut -sub setup_engine { - my ( $class, $engine ) = @_; +sub engine_class { + my ($class, $requested_engine) = @_; - if ($engine) { - $engine = 'Catalyst::Engine::' . $engine; + if (!$class->engine_loader || $requested_engine) { + $class->engine_loader( + Catalyst::EngineLoader->new({ + application_name => $class, + (defined $requested_engine + ? (catalyst_engine_class => $requested_engine) : ()), + }), + ); } - if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) { - $engine = 'Catalyst::Engine::' . $env; - } + $class->engine_loader->catalyst_engine_class; +} - if ( $ENV{MOD_PERL} ) { - my $meta = Class::MOP::get_metaclass_by_name($class); +sub setup_engine { + my ($class, $requested_engine) = @_; - # create the apache method - $meta->add_method('apache' => sub { shift->engine->apache }); + my $engine = do { + my $loader = $class->engine_loader; - my ( $software, $version ) = - $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/; + if (!$loader || $requested_engine) { + $loader = Catalyst::EngineLoader->new({ + application_name => $class, + (defined $requested_engine + ? (requested_engine => $requested_engine) : ()), + }), - $version =~ s/_//g; - $version =~ s/(\.[^.]+)\./$1/g; + $class->engine_loader($loader); + } - if ( $software eq 'mod_perl' ) { + $loader->catalyst_engine_class; + }; - if ( !$engine ) { + # Don't really setup_engine -- see _setup_psgi_app for explanation. + return if $class->loading_psgi_file; - if ( $version >= 1.99922 ) { - $engine = 'Catalyst::Engine::Apache2::MP20'; - } + Class::MOP::load_class($engine); - elsif ( $version >= 1.9901 ) { - $engine = 'Catalyst::Engine::Apache2::MP19'; - } + if ($ENV{MOD_PERL}) { + my $apache = $class->engine_loader->auto; - elsif ( $version >= 1.24 ) { - $engine = 'Catalyst::Engine::Apache::MP13'; - } + my $meta = find_meta($class); + my $was_immutable = $meta->is_immutable; + my %immutable_options = $meta->immutable_options; + $meta->make_mutable if $was_immutable; - else { - Catalyst::Exception->throw( message => - qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ ); - } + $meta->add_method(handler => sub { + my $r = shift; + my $psgi_app = $class->psgi_app; + $apache->call_app($r, $psgi_app); + }); - } + $meta->make_immutable(%immutable_options) if $was_immutable; + } - # install the correct mod_perl handler - if ( $version >= 1.9901 ) { - *handler = sub : method { - shift->handle_request(@_); - }; - } - else { - *handler = sub ($$) { shift->handle_request(@_) }; - } + $class->engine( $engine->new ); - } + return; +} - elsif ( $software eq 'Zeus-Perl' ) { - $engine = 'Catalyst::Engine::Zeus'; - } +sub _finalized_psgi_app { + my ($app) = @_; - else { - Catalyst::Exception->throw( - message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ ); - } + unless ($app->_psgi_app) { + my $psgi_app = $app->_setup_psgi_app; + $app->_psgi_app($psgi_app); } - unless ($engine) { - $engine = $class->engine_class; - } + return $app->_psgi_app; +} - Class::MOP::load_class($engine); +sub _setup_psgi_app { + my ($app) = @_; - # check for old engines that are no longer compatible - my $old_engine; - if ( $engine->isa('Catalyst::Engine::Apache') - && !Catalyst::Engine::Apache->VERSION ) - { - $old_engine = 1; - } + for my $home (Path::Class::Dir->new($app->config->{home})) { + my $psgi_file = $home->file( + Catalyst::Utils::appprefix($app) . '.psgi', + ); - elsif ( $engine->isa('Catalyst::Engine::Server::Base') - && Catalyst::Engine::Server->VERSION le '0.02' ) - { - $old_engine = 1; - } + next unless -e $psgi_file; - elsif ($engine->isa('Catalyst::Engine::HTTP::POE') - && $engine->VERSION eq '0.01' ) - { - $old_engine = 1; - } + # If $psgi_file calls ->setup_engine, it's doing so to load + # Catalyst::Engine::PSGI. But if it does that, we're only going to + # throw away the loaded PSGI-app and load the 5.9 Catalyst::Engine + # anyway. So set a flag (ick) that tells setup_engine not to populate + # $c->engine or do any other things we might regret. - elsif ($engine->isa('Catalyst::Engine::Zeus') - && $engine->VERSION eq '0.01' ) - { - $old_engine = 1; - } + $app->loading_psgi_file(1); + my $psgi_app = Plack::Util::load_psgi($psgi_file); + $app->loading_psgi_file(0); - if ($old_engine) { - Catalyst::Exception->throw( message => - qq/Engine "$engine" is not supported by this version of Catalyst/ - ); + return $psgi_app + unless $app->engine_loader->needs_psgi_engine_compat_hack; + + warn <<"EOW"; +Found a legacy Catalyst::Engine::PSGI .psgi file at ${psgi_file}. + +Its content has been ignored. Please consult the Catalyst::Upgrading +documentation on how to upgrade from Catalyst::Engine::PSGI. +EOW } - # engine instance - $class->engine( $engine->new ); + return $app->apply_default_middlewares($app->psgi_app); +} + +=head2 $c->apply_default_middlewares + +Adds the following L middlewares to your application, since they are +useful and commonly needed: + +L, (conditionally added based on the status +of your $ENV{REMOTE_ADDR}, and can be forced on with C +or forced off with C), L +(if you are using Lighttpd), L (always +applied since this middleware is smart enough to conditionally apply itself). + +Additionally if we detect we are using Nginx, we add a bit of custom middleware +to solve some problems with the way that server handles $ENV{PATH_INFO} and +$ENV{SCRIPT_NAME} + +=cut + + +sub apply_default_middlewares { + my ($app, $psgi_app) = @_; + + $psgi_app = Plack::Middleware::Conditional->wrap( + $psgi_app, + builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) }, + 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}; + }, + ); + + # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME + # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html + $psgi_app = Plack::Middleware::LighttpdScriptNameFix->wrap($psgi_app); + + # we're applying this unconditionally as the middleware itself already makes + # sure it doesn't fuck things up if it's not running under one of the right + # IIS versions + $psgi_app = Plack::Middleware::IIS6ScriptNameFix->wrap($psgi_app); + + return $psgi_app; +} + +=head2 $c->psgi_app + +Returns a PSGI application code reference for the catalyst application +C<$c>. This is the bare application without any middlewares +applied. C<${myapp}.psgi> is not taken into account. + +This is what you want to be using to retrieve the PSGI application code +reference of your Catalyst application for use in F<.psgi> files. + +=cut + +sub psgi_app { + my ($app) = @_; + return $app->engine->build_psgi_app($app); } =head2 $c->setup_home @@ -2750,7 +2626,7 @@ sub setup_stats { =head2 $c->registered_plugins Returns a sorted list of the plugins which have either been stated in the -import list or which have been added via C<< MyApp->plugin(@args); >>. +import list. If passed a given plugin name, it will report a boolean value indicating whether or not that plugin is loaded. A fully qualified name is required if @@ -2913,7 +2789,7 @@ welcome screens C - The request body (for example file uploads) will not be parsed until it is accessed. This allows you to (for example) check authentication (and reject -the upload) before actually recieving all the data. See L +the upload) before actually receiving all the data. See L =item * @@ -2923,20 +2799,52 @@ templates to a different directory. =item * -C - Array reference passed to Module::Pluggable to for additional -namespaces from which components will be loaded (and constructed and stored in -C<< $c->components >>). - -=item * - C - If true, causes internal actions such as C<< _DISPATCH >> to be shown in hit debug tables in the test server. =item * -C - Controlls if the C or C environment -variable should be used for determining the request path. See L -for more information. +C - Controls if the C or C environment +variable should be used for determining the request path. + +Most web server environments pass the requested path to the application using environment variables, +from which Catalyst has to reconstruct the request base (i.e. the top level path to / in the application, +exposed as C<< $c->request->base >>) and the request path below that base. + +There are two methods of doing this, both of which have advantages and disadvantages. Which method is used +is determined by the C<< $c->config(use_request_uri_for_path) >> setting (which can either be true or false). + +=over + +=item use_request_uri_for_path => 0 + +This is the default (and the) traditional method that Catalyst has used for determining the path information. +The path is generated from a combination of the C and C environment variables. +The allows the application to behave correctly when C is being used to redirect requests +into the application, as these variables are adjusted by mod_rewrite to take account for the redirect. + +However this method has the major disadvantage that it is impossible to correctly decode some elements +of the path, as RFC 3875 says: "C<< Unlike a URI path, the PATH_INFO is not URL-encoded, and cannot +contain path-segment parameters. >>" This means PATH_INFO is B decoded, and therefore Catalyst +can't distinguish / vs %2F in paths (in addition to other encoded values). + +=item use_request_uri_for_path => 1 + +This method uses the C and C environment variables. As C is never +decoded, this means that applications using this mode can correctly handle URIs including the %2F character +(i.e. with C set to C in Apache). + +Given that this method of path resolution is provably more correct, it is recommended that you use +this unless you have a specific need to deploy your application in a non-standard environment, and you are +aware of the implications of not being able to handle encoded URI paths correctly. + +However it also means that in a number of cases when the app isn't installed directly at a path, but instead +is having paths rewritten into it (e.g. as a .cgi/fcgi in a public_html directory, with mod_rewrite in a +.htaccess file, or when SSI is used to rewrite pages into the app, or when sub-paths of the app are exposed +at other URIs than that which the app is 'normally' based at with C), the resolution of +C<< $c->request->base >> will be incorrect. + +=back =item * @@ -3051,6 +2959,8 @@ Wiki: =head2 L - The test suite. +=begin stopwords + =head1 PROJECT FOUNDER sri: Sebastian Riedel @@ -3195,6 +3105,8 @@ rainboxx: Matthias Dietrich, C dd070: Dhaval Dhanani +=end stopwords + =head1 COPYRIGHT Copyright (c) 2005, the above named PROJECT FOUNDER and CONTRIBUTORS.