1package Plack::Handler::Apache2;
2use strict;
3use warnings;
4use Apache2::RequestRec;
5use Apache2::RequestIO;
6use Apache2::RequestUtil;
7use Apache2::Response;
8use Apache2::Const -compile => qw(OK);
9use Apache2::Log;
10use APR::Table;
11use IO::Handle;
12use Plack::Util;
13use Scalar::Util;
14use URI;
15use URI::Escape;
16
17my %apps; # psgi file to $app mapping
18
19sub new { bless {}, shift }
20
21sub preload {
22    my $class = shift;
23    for my $app (@_) {
24        $class->load_app($app);
25    }
26}
27
28sub load_app {
29    my($class, $app) = @_;
30    return $apps{$app} ||= do {
31        # Trick Catalyst, CGI.pm, CGI::Cookie and others that check
32        # for $ENV{MOD_PERL}.
33        #
34        # Note that we delete it instead of just localizing
35        # $ENV{MOD_PERL} because some users may check if the key
36        # exists, and we do it this way because "delete local" is new
37        # in 5.12:
38        # http://perldoc.perl.org/5.12.0/perldelta.html#delete-local
39        local $ENV{MOD_PERL};
40        delete $ENV{MOD_PERL};
41
42        Plack::Util::load_psgi $app;
43    };
44}
45
46sub call_app {
47    my ($class, $r, $app) = @_;
48
49    $r->subprocess_env; # let Apache create %ENV for us :)
50
51    my $env = {
52        %ENV,
53        'psgi.version'           => [ 1, 1 ],
54        'psgi.url_scheme'        => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
55        'psgi.input'             => $r,
56        'psgi.errors'            => *STDERR,
57        'psgi.multithread'       => Plack::Util::FALSE,
58        'psgi.multiprocess'      => Plack::Util::TRUE,
59        'psgi.run_once'          => Plack::Util::FALSE,
60        'psgi.streaming'         => Plack::Util::TRUE,
61        'psgi.nonblocking'       => Plack::Util::FALSE,
62        'psgix.harakiri'         => Plack::Util::TRUE,
63        'psgix.cleanup'          => Plack::Util::TRUE,
64        'psgix.cleanup.handlers' => [],
65    };
66
67    if (defined(my $HTTP_AUTHORIZATION = $r->headers_in->{Authorization})) {
68        $env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
69    }
70
71    # If you supply more than one Content-Length header Apache will
72    # happily concat the values with ", ", e.g. "72, 72". This
73    # violates the PSGI spec so fix this up and just take the first
74    # one.
75    if (exists $env->{CONTENT_LENGTH} && $env->{CONTENT_LENGTH} =~ /,/) {
76        no warnings qw(numeric);
77        $env->{CONTENT_LENGTH} = int $env->{CONTENT_LENGTH};
78    }
79
80    # Actually, we can not trust PATH_INFO from mod_perl because mod_perl squeezes multiple slashes into one slash.
81    my $uri = URI->new("http://".$r->hostname.$r->unparsed_uri);
82
83    $env->{PATH_INFO} = uri_unescape($uri->path);
84
85    $class->fixup_path($r, $env);
86
87    my $res = $app->($env);
88
89    if (ref $res eq 'ARRAY') {
90        _handle_response($r, $res);
91    }
92    elsif (ref $res eq 'CODE') {
93        $res->(sub {
94            _handle_response($r, $_[0]);
95        });
96    }
97    else {
98        die "Bad response $res";
99    }
100
101    if (@{ $env->{'psgix.cleanup.handlers'} }) {
102        $r->push_handlers(
103            PerlCleanupHandler => sub {
104                for my $cleanup_handler (@{ $env->{'psgix.cleanup.handlers'} }) {
105                    $cleanup_handler->($env);
106                }
107
108                if ($env->{'psgix.harakiri.commit'}) {
109                    $r->child_terminate;
110                }
111            },
112        );
113    } else {
114        if ($env->{'psgix.harakiri.commit'}) {
115            $r->child_terminate;
116        }
117    }
118
119    return Apache2::Const::OK;
120}
121
122sub handler {
123    my $class = __PACKAGE__;
124    my $r     = shift;
125    my $psgi  = $r->dir_config('psgi_app');
126    $class->call_app($r, $class->load_app($psgi));
127}
128
129# The method for PH::Apache2::Registry to override.
130sub fixup_path {
131    my ($class, $r, $env) = @_;
132
133    # $env->{PATH_INFO} is created from unparsed_uri so it is raw.
134    my $path_info = $env->{PATH_INFO} || '';
135
136    # Get argument of <Location> or <LocationMatch> directive
137    # This may be string or regexp and we can't know either.
138    my $location = $r->location;
139
140    # Let's *guess* if we're in a LocationMatch directive
141    if ($location eq '/') {
142        # <Location /> could be handled as a 'root' case where we make
143        # everything PATH_INFO and empty SCRIPT_NAME as in the PSGI spec
144        $env->{SCRIPT_NAME} = '';
145    } elsif ($path_info =~ s{^($location)/?}{/}) {
146        $env->{SCRIPT_NAME} = $1 || '';
147    } else {
148        # Apache's <Location> is matched but here is not.
149        # This is something wrong. We can only respect original.
150        $r->server->log_error(
151            "Your request path is '$path_info' and it doesn't match your Location(Match) '$location'. " .
152            "This should be due to the configuration error. See perldoc Plack::Handler::Apache2 for details."
153        );
154    }
155
156    $env->{PATH_INFO}   = $path_info;
157}
158
159sub _handle_response {
160    my ($r, $res) = @_;
161
162    my ($status, $headers, $body) = @{ $res };
163
164    my $hdrs = ($status >= 200 && $status < 300)
165        ? $r->headers_out : $r->err_headers_out;
166
167    Plack::Util::header_iter($headers, sub {
168        my($h, $v) = @_;
169        if (lc $h eq 'content-type') {
170            $r->content_type($v);
171        } elsif (lc $h eq 'content-length') {
172            $r->set_content_length($v);
173        } else {
174            $hdrs->add($h => $v);
175        }
176    });
177
178    $r->status($status);
179
180    if (Scalar::Util::blessed($body) and $body->can('path') and my $path = $body->path) {
181        $r->sendfile($path);
182    } elsif (defined $body) {
183        Plack::Util::foreach($body, sub { $r->print(@_) });
184        $r->rflush;
185    }
186    else {
187        return Plack::Util::inline_object
188            write => sub { $r->print(@_); $r->rflush },
189            close => sub { $r->rflush };
190    }
191
192    return Apache2::Const::OK;
193}
194
1951;
196
197__END__
198
199=encoding utf-8
200
201=head1 NAME
202
203Plack::Handler::Apache2 - Apache 2.0 mod_perl handler to run PSGI application
204
205=head1 SYNOPSIS
206
207  # in your httpd.conf
208  <Location />
209  SetHandler perl-script
210  PerlResponseHandler Plack::Handler::Apache2
211  PerlSetVar psgi_app /path/to/app.psgi
212  </Location>
213
214  # Optionally preload your apps in startup
215  PerlPostConfigRequire /etc/httpd/startup.pl
216
217See L</STARTUP FILE> for more details on writing a C<startup.pl>.
218
219=head1 DESCRIPTION
220
221This is a mod_perl handler module to run any PSGI application with mod_perl on Apache 2.x.
222
223If you want to run PSGI applications I<behind> Apache instead of using
224mod_perl, see L<Plack::Handler::FCGI> to run with FastCGI, or use
225standalone HTTP servers such as L<Starman> or L<Starlet> proxied with
226mod_proxy.
227
228=head1 CREATING CUSTOM HANDLER
229
230If you want to create a custom handler that loads or creates PSGI
231applications using other means than loading from C<.psgi> files, you
232can create your own handler class and use C<call_app> class method to
233run your application.
234
235  package My::ModPerl::Handler;
236  use Plack::Handler::Apache2;
237
238  sub get_app {
239    # magic!
240  }
241
242  sub handler {
243    my $r = shift;
244    my $app = get_app();
245    Plack::Handler::Apache2->call_app($r, $app);
246  }
247
248=head1 STARTUP FILE
249
250Here is an example C<startup.pl> to preload PSGI applications:
251
252    #!/usr/bin/env perl
253
254    use strict;
255    use warnings;
256    use Apache2::ServerUtil ();
257
258    BEGIN {
259        return unless Apache2::ServerUtil::restart_count() > 1;
260
261        require lib;
262        lib->import('/path/to/my/perl/libs');
263
264        require Plack::Handler::Apache2;
265
266        my @psgis = ('/path/to/app1.psgi', '/path/to/app2.psgi');
267        foreach my $psgi (@psgis) {
268            Plack::Handler::Apache2->preload($psgi);
269        }
270    }
271
272    1; # file must return true!
273
274See L<http://perl.apache.org/docs/2.0/user/handlers/server.html#Startup_File>
275for general information on the C<startup.pl> file for preloading perl modules
276and your apps.
277
278Some things to keep in mind when writing this file:
279
280=over 4
281
282=item * multiple init phases
283
284You have to check that L<Apache2::ServerUtil/restart_count> is C<< > 1 >>,
285otherwise your app will load twice and the env vars you set with
286L<PerlSetEnv|http://perl.apache.org/docs/2.0/user/config/config.html#C_PerlSetEnv_>
287will not be available when your app is loading the first time.
288
289Use the example above as a template.
290
291=item * C<@INC>
292
293The C<startup.pl> file is a good place to add entries to your C<@INC>.
294Use L<lib> to add entries, they can be in your app or C<.psgi> as well, but if
295your modules are in a L<local::lib> or some such, you will need to add the path
296for anything to load.
297
298Alternately, if you follow the example above, you can use:
299
300    PerlSetEnv PERL5LIB /some/path
301
302or
303
304    PerlSwitches -I/some/path
305
306in your C<httpd.conf>, which will also work.
307
308=item * loading errors
309
310Any exceptions thrown in your C<startup.pl> will stop Apache from starting at
311all.
312
313You probably don't want a stray syntax error to bring your whole server down in
314a shared or development environment, in which case it's a good idea to wrap the
315L</preload> call in an eval, using something like this:
316
317    require Plack::Handler::Apache2;
318
319    my @psgis = ('/path/to/app1.psgi', '/path/to/app2.psgi');
320
321    foreach my $psgi (@psgis) {
322        eval {
323            Plack::Handler::Apache2->preload($psgi); 1;
324        } or do {
325            my $error = $@ || 'Unknown Error';
326            # STDERR goes to the error_log
327            print STDERR "Failed to load psgi '$psgi': $error\n";
328        };
329    }
330
331
332=item * dynamically loaded modules
333
334Some modules load their dependencies at runtime via e.g. L<Class::Load>. These
335modules will not get preloaded into your parent process by just including the
336app/module you are using.
337
338As an optimization, you can dump C<%INC> from a request to see if you are using
339any such modules and preload them in your C<startup.pl>.
340
341Another method is dumping the difference between the C<%INC> on
342process start and process exit. You can use something like this to
343accomplish this:
344
345    my $start_inc = { %INC };
346
347    END {
348        my @m;
349        foreach my $m (keys %INC) {
350            push @m, $m unless exists $start_inc->{$m};
351        }
352
353        if (@m) {
354            # STDERR goes to the error_log
355            print STDERR "The following modules need to be preloaded:\n";
356            print STDERR "$_\n" for @m;
357        }
358    }
359
360=back
361
362=head1 AUTHOR
363
364Tatsuhiko Miyagawa
365
366=head1 CONTRIBUTORS
367
368Paul Driver
369
370Ævar Arnfjörð Bjarmason
371
372Rafael Kitover
373
374=head1 SEE ALSO
375
376L<Plack>
377
378=cut
379