Make legacy IIS env fixing work again
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
index 73c63fb..39962a6 100644 (file)
@@ -30,9 +30,12 @@ use Class::C3::Adopt::NEXT;
 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;
 
 BEGIN { require 5.008004; }
 
@@ -70,18 +73,17 @@ our $GO        = Catalyst::Exception::Go->new;
 #maybe we should just make them attributes with a default?
 __PACKAGE__->mk_classdata($_)
   for qw/components arguments dispatcher engine log dispatcher_class
-  engine_class context_class request_class response_class stats_class
-  setup_finished psgi_app/;
+  engine_loader context_class request_class response_class stats_class
+  setup_finished _psgi_app/;
 
 __PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
-__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.80024';
+our $VERSION = '5.89002';
 
 sub import {
     my ( $class, @arguments ) = @_;
@@ -102,7 +104,12 @@ sub import {
     $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses);
 
     unless( $meta->has_method('meta') ){
-        $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
+        if ($Moose::VERSION >= 1.15) {
+            $meta->_add_meta_method('meta');
+        }
+        else {
+            $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
+        }
     }
 
     $caller->arguments( [@arguments] );
@@ -367,6 +374,8 @@ or stash it like so:
 
 and access it from the stash.
 
+Keep in mind that the C<end> method used is that of the caller action. So a C<$c-E<gt>detach> inside a forwarded action would run the C<end> method from the original action requested.
+
 =cut
 
 sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) }
@@ -430,6 +439,10 @@ with localized C<< $c->action >> and C<< $c->namespace >>. Like C<detach>,
 C<go> escapes the processing of the current request chain on completion, and
 does not return to its caller.
 
+@arguments are arguments to the final destination of $action. @captures are
+arguments to the intermediate steps, if any, on the way to the final sub of
+$action.
+
 =cut
 
 sub go { my $c = shift; $c->dispatcher->go( $c, @_ ) }
@@ -743,7 +756,12 @@ sub view {
         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};
+            if( exists $comps->{$check} ) {
+                return $c->_filter_component( $comps->{$check}, @args );
+            }
+            else {
+                $c->log->warn( "Attempted to use view '$check', but does not exist" );
+            }
         }
         my @result = $c->_comp_search_prefixes( $name, qw/View V/ );
         return map { $c->_filter_component( $_, @args ) } @result if ref $name;
@@ -894,7 +912,7 @@ component is constructed.
 For example:
 
     MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } });
-    MyApp::Model::Foo->config({ quux => 'frob', 'overrides => 'this' });
+    MyApp::Model::Foo->config({ quux => 'frob', overrides => 'this' });
 
 will mean that C<MyApp::Model::Foo> receives the following data when
 constructed:
@@ -905,6 +923,27 @@ constructed:
         overrides => 'me',
     });
 
+It's common practice to use a Moose attribute
+on the receiving component to access the config value.
+
+    package MyApp::Model::Foo;
+
+    use Moose;
+
+    # this attr will receive 'baz' at construction time
+    has 'bar' => (
+        is  => 'rw',
+        isa => 'Str',
+    );
+
+You can then get the value 'baz' by calling $c->model('Foo')->bar
+(or $self->bar inside code in the model).
+
+B<NOTE:> you MUST NOT call C<< $self->config >> or C<< __PACKAGE__->config >>
+as a way of reading config within your code, as this B<will not> give you the
+correctly merged config back. You B<MUST> take the config values supplied to
+the constructor and use those instead.
+
 =cut
 
 around config => sub {
@@ -1079,7 +1118,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, XXX FIXME");
+    }
+    $class->setup_engine();
     $class->setup_stats( delete $flags->{stats} );
 
     for my $flag ( sort keys %{$flags} ) {
@@ -1229,7 +1271,9 @@ sub setup_finalize {
 
 Constructs an absolute L<URI> object based on the application root, the
 provided path, and the additional arguments and query parameters provided.
-When used as a string, provides a textual URI.
+When used as a string, provides a textual URI.  If you need more flexibility
+than this (i.e. the option to provide relative URIs etc.) see
+L<Catalyst::Plugin::SmartURI>.
 
 If no arguments are provided, the URI for the current action is returned.
 To return the current action and also provide @args, use
@@ -1623,7 +1667,9 @@ sub execute {
     push( @{ $c->stack }, $code );
 
     no warnings 'recursion';
-    eval { $c->state( $code->execute( $class, $c, @{ $c->req->args } ) || 0 ) };
+    # N.B. This used to be combined, but I have seen $c get clobbered if so, and
+    #      I have no idea how, ergo $ret (which appears to fix the issue)
+    eval { my $ret = $code->execute( $class, $c, @{ $c->req->args } ) || 0; $c->state( $ret ) };
 
     $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
 
@@ -1686,7 +1732,7 @@ sub _stats_start_execute {
         my $parent = $c->stack->[-1];
 
         # forward, locate the caller
-        if ( exists $c->counter->{"$parent"} ) {
+        if ( defined $parent && exists $c->counter->{"$parent"} ) {
             $c->stats->profile(
                 begin  => $action,
                 parent => "$parent" . $c->counter->{"$parent"},
@@ -1820,10 +1866,10 @@ sub finalize_headers {
     }
 
     # Content-Length
-    if ( $response->body && !$response->content_length ) {
+    if ( defined $response->body && length $response->body && !$response->content_length ) {
 
         # get the length from a filehandle
-        if ( blessed( $response->body ) && $response->body->can('read') )
+        if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' )
         {
             my $stat = stat $response->body;
             if ( $stat && $stat->size > 0 ) {
@@ -2144,7 +2190,7 @@ sub log_request {
         $c->log->debug("Query keywords are: $keywords");
     }
 
-    $c->log_request_parameters( query => $request->query_parameters, body => $request->body_parameters );
+    $c->log_request_parameters( query => $request->query_parameters, $request->_has_body ? (body => $request->body_parameters) : () );
 
     $c->log_request_uploads($request);
 }
@@ -2334,11 +2380,11 @@ sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
 
 =head2 $c->request_class
 
-Returns or sets the request class.
+Returns or sets the request class. Defaults to L<Catalyst::Request>.
 
 =head2 $c->response_class
 
-Returns or sets the response class.
+Returns or sets the response class. Defaults to L<Catalyst::Response>.
 
 =head2 $c->read( [$maxlength] )
 
@@ -2363,7 +2409,7 @@ Starts the engine.
 
 =cut
 
-sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
+sub run { my $c = shift; return $c->engine->run( $c, $c->_finalized_psgi_app, @_ ) }
 
 =head2 $c->set_action( $action, $code, $namespace, $attrs )
 
@@ -2401,8 +2447,7 @@ sub setup_components {
 
     my $config  = $class->config->{ setup_components };
 
-    my @comps = sort { length $a <=> length $b }
-                $class->locate_components($config);
+    my @comps = $class->locate_components($config);
     my %comps = map { $_ => 1 } @comps;
 
     my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
@@ -2457,7 +2502,8 @@ sub locate_components {
         %$config
     );
 
-    my @comps = $locator->plugins;
+    # XXX think about ditching this sort entirely
+    my @comps = sort { length $a <=> length $b } $locator->plugins;
 
     return @comps;
 }
@@ -2547,66 +2593,152 @@ Sets up engine.
 
 =cut
 
-sub setup_engine {
-    my ($class, $engine) = @_;
+sub engine_class {
+    my $class = shift;
+    $class->engine_loader->catalyst_engine_class(@_);
+}
 
-    unless ($engine) {
-        $engine = $class->engine_class;
-    }
-    else {
-        $engine = String::RewritePrefix->rewrite( { '' => 'Catalyst::Engine::', '+' => '' }, $engine );
-    }
+sub setup_engine {
+    my ($class) = @_;
 
-    $engine = 'Catalyst::Engine' if $engine eq 'Catalyst::Engine::HTTP';
+    $class->engine_loader(Catalyst::EngineLoader->new(application_name => $class));
 
+    my $engine = $class->engine_class;
     Class::MOP::load_class($engine);
 
-    # 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;
+    if ($ENV{MOD_PERL}) {
+        my $apache = $class->engine_loader->auto;
+        # FIXME - Immutable
+        $class->meta->add_method(handler => sub {
+            my $r = shift;
+            my $psgi_app = $class->psgi_app;
+            $apache->call_app($r, $psgi_app);
+        });
     }
 
-    elsif ( $engine->isa('Catalyst::Engine::Server::Base')
-        && Catalyst::Engine::Server->VERSION le '0.02' )
-    {
-        $old_engine = 1;
-    }
+    $class->engine( $engine->new );
 
-    elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
-        && $engine->VERSION eq '0.01' )
-    {
-        $old_engine = 1;
-    }
+    return;
+}
 
-    elsif ($engine->isa('Catalyst::Engine::Zeus')
-        && $engine->VERSION eq '0.01' )
-    {
-        $old_engine = 1;
+sub _finalized_psgi_app {
+    my ($app) = @_;
+
+    unless ($app->_psgi_app) {
+        my $psgi_app = $app->_setup_psgi_app;
+        $app->_psgi_app($psgi_app);
     }
 
-    if ($old_engine) {
-        Catalyst::Exception->throw( message =>
-              qq/Engine "$engine" is not supported by this version of Catalyst/
+    return $app->_psgi_app;
+}
+
+sub _setup_psgi_app {
+    my ($app) = @_;
+
+    if (my $home = Path::Class::Dir->new($app->config->{home})) {
+        my $psgi_file = $home->file(
+            Catalyst::Utils::appprefix($app) . '.psgi',
         );
-    }
 
-    if ($ENV{MOD_PERL}) {
-        use Catalyst::Engine::Loader;
-        my $apache = Catalyst::Engine::Loader->auto;
-        # FIXME - Immutable
-        $class->meta->add_method(handler => sub {
-            my $r = shift;
-            my $app = $class->psgi_app;
-            $apache->call_app($r, $app);
-        });
+        return Plack::Util::load_psgi($psgi_file)
+            if -e $psgi_file;
     }
 
-    $class->engine( $engine->new );
-    $class->psgi_app( $class->engine->build_psgi_app($class) );
+    return $app->_wrapped_legacy_psgi_app($app->psgi_app);
+}
+
+# Note - this is for back compatibility. Catalyst should not know or care about
+#        how it's deployed. The recommended way of configuring this is now to
+#        use the ReverseProxy middleware yourself if you want it in a .psgi
+#        file.
+sub _wrapped_legacy_psgi_app {
+    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
+    # Thanks to Mark Blythe for this fix
+    #
+    # Note that this has probably the same effect as
+    # Plack::Middleware::LighttpdScriptNameFix and we should switch to that if
+    # we can.
+    $psgi_app = Plack::Middleware::Conditional->wrap(
+        $psgi_app,
+        builder => sub {
+            my ($to_wrap) = @_;
+            return sub {
+                my ($env) = @_;
+                $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME};
+                return $to_wrap->($env);
+            };
+        },
+        condition => sub {
+            my ($env) = @_;
+            my $server = $env->{SERVER_SOFTWARE};
+            return unless $server;
+            return $server =~ /lighttpd/ ? 1 : 0;
+        },
+    );
+
+    $psgi_app = Plack::Middleware::Conditional->wrap(
+        $psgi_app,
+        builder => sub {
+            my ($to_wrap) = @_;
+            return sub {
+                my ($env) = @_;
+
+                my @script_name = split(m!/!, $env->{PATH_INFO});
+                my @path_translated = split(m!/|\\\\?!, $env->{PATH_TRANSLATED});
+                my @path_info;
+
+                while ($script_name[$#script_name] eq $path_translated[$#path_translated]) {
+                    pop(@path_translated);
+                    unshift(@path_info, pop(@script_name));
+                }
+
+                unshift(@path_info, '', '');
+
+                $env->{PATH_INFO} = join('/', @path_info);
+                $env->{SCRIPT_NAME} = join('/', @script_name);
+
+                return $to_wrap->($env);
+            };
+        },
+        condition => sub {
+            my ($env) = @_;
+            my $server = $env->{SERVER_SOFTWARE};
+            return unless $server;
+            return $server =~ /IIS\/[6-9]\.[0-9]/ ? 1 : 0;
+        },
+    );
+
+    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
@@ -3146,6 +3278,10 @@ wreis: Wallace Reis <wallace@reis.org.br>
 
 Yuval Kogman, C<nothingmuch@woobling.org>
 
+rainboxx: Matthias Dietrich, C<perl@rainboxx.de>
+
+dd070: Dhaval Dhanani <dhaval070@gmail.com>
+
 =head1 LICENSE
 
 This library is free software. You can redistribute it and/or modify it under