lib/Catalyst/Engine/Apache.pm

   1 package Catalyst::Engine::Apache;
   2
   3 use strict;
   4 use mod_perl;
   5 use constant MP2 => $mod_perl::VERSION >= 1.99;
   6 use base 'Catalyst::Engine';
   7 use URI;
   8
   9 __PACKAGE__->mk_accessors(qw/apache/);
  10
  11 =head1 NAME
  12
  13 Catalyst::Engine::Apache - Catalyst Apache Engine
  14
  15 =head1 SYNOPSIS
  16
  17 See L<Catalyst>.
  18
  19 =head1 DESCRIPTION
  20
  21 This is the Catalyst engine specialized for Apache (i.e. for mod_perl).
  22
  23 =head1 METHODS
  24
  25 =over 4
  26
  27 =item $c->apache
  28
  29 Returns an C<Apache::Request> object.
  30
  31 =back
  32
  33 =head1 OVERLOADED METHODS
  34
  35 This class overloads some methods from C<Catalyst::Engine>.
  36
  37 =over 4
  38
  39 =item $c->finalize_headers
  40
  41 =cut
  42
  43 sub finalize_headers {
  44     my $c = shift;
  45
  46     for my $name ( $c->response->headers->header_field_names ) {
  47         next if $name =~ /Content-Type/i;
  48         my @values = $c->response->header($name);
  49         $c->apache->headers_out->add( $name => $_ ) for @values;
  50     }
  51
  52     if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
  53         my @values = $c->response->header('Set-Cookie');
  54         $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
  55     }
  56
  57     $c->apache->status( $c->response->status );
  58     $c->apache->content_type( $c->response->header('Content-Type') );
  59
  60     unless ( MP2 ) {
  61         $c->apache->send_http_header;
  62     }
  63
  64     return 0;
  65 }
  66
  67 =item $c->finalize_output
  68
  69 =cut
  70
  71 sub finalize_output {
  72     my $c = shift;
  73     $c->apache->print( $c->response->output );
  74 }
  75
  76 =item $c->prepare_connection
  77
  78 =cut
  79
  80 sub prepare_connection {
  81     my $c = shift;
  82     $c->request->hostname( $c->apache->connection->remote_host );
  83     $c->request->address( $c->apache->connection->remote_ip );
  84 }
  85
  86 =item $c->prepare_headers
  87
  88 =cut
  89
  90 sub prepare_headers {
  91     my $c = shift;
  92     $c->request->method( $c->apache->method );
  93     $c->request->header( %{ $c->apache->headers_in } );
  94 }
  95
  96 =item $c->prepare_parameters
  97
  98 =cut
  99
 100 sub prepare_parameters {
 101     my $c = shift;
 102     my %args;
 103     foreach my $key ( $c->apache->param ) {
 104         my @values = $c->apache->param($key);
 105         $args{$key} = @values == 1 ? $values[0] : \@values;
 106     }
 107     $c->request->parameters( \%args );
 108 }
 109
 110 =item $c->prepare_path
 111
 112 =cut
 113
 114 # XXX needs fixing, only work with <Location> directive,
 115 # not <Directory> directive
 116 sub prepare_path {
 117     my $c = shift;
 118     $c->request->path( $c->apache->uri );
 119     my $loc = $c->apache->location;
 120     no warnings 'uninitialized';
 121     $c->req->{path} =~ s/^($loc)?\///;
 122     my $base = URI->new;
 123     $base->scheme( $ENV{HTTPS} ? 'https' : 'http' );
 124     $base->host( $c->apache->hostname );
 125     $base->port( $c->apache->get_server_port );
 126     my $path = $c->apache->location;
 127     $base->path( $path =~ /\/$/ ? $path : "$path/" );
 128     $c->request->base( $base->as_string );
 129 }
 130
 131 =item $c->prepare_request($r)
 132
 133 =cut
 134
 135 sub prepare_request {
 136     my ( $c, $r ) = @_;
 137     $c->apache( Apache::Request->new($r) );
 138 }
 139
 140 =item $c->prepare_uploads
 141
 142 =cut
 143
 144 sub prepare_uploads {
 145     my $c = shift;
 146     for my $upload ( $c->apache->upload ) {
 147         $upload = $c->apache->upload($upload) if MP2;
 148         $c->request->uploads->{ $upload->filename } = {
 149             fh   => $upload->fh,
 150             size => $upload->size,
 151             type => $upload->type
 152         };
 153     }
 154 }
 155
 156 =item $c->run
 157
 158 =cut
 159
 160 sub run { }
 161
 162 =back
 163
 164 =head1 SEE ALSO
 165
 166 L<Catalyst>.
 167
 168 =head1 AUTHOR
 169
 170 Sebastian Riedel, C<sri@cpan.org>
 171
 172 =head1 COPYRIGHT
 173
 174 This program is free software, you can redistribute it and/or modify it under
 175 the same terms as Perl itself.
 176
 177 =cut
 178
 179 1;