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