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; | |
8 | ||
6dc87a0f | 9 | __PACKAGE__->mk_accessors(qw/apache/); |
fc7ec1d9 | 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 | ||
23f9d934 | 21 | This is the Catalyst engine specialized for Apache (i.e. for mod_perl). |
fc7ec1d9 | 22 | |
23f9d934 | 23 | =head1 METHODS |
fc7ec1d9 | 24 | |
23f9d934 | 25 | =over 4 |
26 | ||
6dc87a0f | 27 | =item $c->apache |
fc7ec1d9 | 28 | |
29 | Returns an C<Apache::Request> object. | |
30 | ||
23f9d934 | 31 | =back |
32 | ||
33 | =head1 OVERLOADED METHODS | |
fc7ec1d9 | 34 | |
35 | This class overloads some methods from C<Catalyst::Engine>. | |
36 | ||
23f9d934 | 37 | =over 4 |
38 | ||
39 | =item $c->finalize_headers | |
fc7ec1d9 | 40 | |
41 | =cut | |
42 | ||
43 | sub finalize_headers { | |
44 | my $c = shift; | |
6dc87a0f | 45 | |
fc7ec1d9 | 46 | for my $name ( $c->response->headers->header_field_names ) { |
47 | next if $name =~ /Content-Type/i; | |
6dc87a0f | 48 | my @values = $c->response->header($name); |
49 | $c->apache->headers_out->add( $name => $_ ) for @values; | |
fc7ec1d9 | 50 | } |
6dc87a0f | 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; | |
fc7ec1d9 | 55 | } |
6dc87a0f | 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 | ||
fc7ec1d9 | 64 | return 0; |
65 | } | |
66 | ||
23f9d934 | 67 | =item $c->finalize_output |
fc7ec1d9 | 68 | |
69 | =cut | |
70 | ||
71 | sub finalize_output { | |
72 | my $c = shift; | |
6dc87a0f | 73 | $c->apache->print( $c->response->{output} ); |
fc7ec1d9 | 74 | } |
75 | ||
0556eb49 | 76 | =item $c->prepare_connection |
77 | ||
78 | =cut | |
79 | ||
80 | sub prepare_connection { | |
81 | my $c = shift; | |
6dc87a0f | 82 | $c->request->hostname( $c->apache->connection->remote_host ); |
83 | $c->request->address( $c->apache->connection->remote_ip ); | |
fc7ec1d9 | 84 | } |
85 | ||
23f9d934 | 86 | =item $c->prepare_headers |
fc7ec1d9 | 87 | |
88 | =cut | |
89 | ||
90 | sub prepare_headers { | |
91 | my $c = shift; | |
6dc87a0f | 92 | $c->request->method( $c->apache->method ); |
93 | $c->request->header( %{ $c->apache->headers_in } ); | |
fc7ec1d9 | 94 | } |
95 | ||
23f9d934 | 96 | =item $c->prepare_parameters |
fc7ec1d9 | 97 | |
98 | =cut | |
99 | ||
100 | sub prepare_parameters { | |
101 | my $c = shift; | |
102 | my %args; | |
6dc87a0f | 103 | foreach my $key ( $c->apache->param ) { |
104 | my @values = $c->apache->param($key); | |
fc7ec1d9 | 105 | $args{$key} = @values == 1 ? $values[0] : \@values; |
106 | } | |
6dc87a0f | 107 | $c->request->parameters( \%args ); |
fc7ec1d9 | 108 | } |
109 | ||
23f9d934 | 110 | =item $c->prepare_path |
fc7ec1d9 | 111 | |
112 | =cut | |
113 | ||
6dc87a0f | 114 | # XXX needs fixing, only work with <Location> directive, |
115 | # not <Directory> directive | |
fc7ec1d9 | 116 | sub prepare_path { |
117 | my $c = shift; | |
6dc87a0f | 118 | $c->request->path( $c->apache->uri ); |
119 | my $loc = $c->apache->location; | |
fc7ec1d9 | 120 | no warnings 'uninitialized'; |
121 | $c->req->{path} =~ s/^($loc)?\///; | |
122 | my $base = URI->new; | |
5ae68c0d | 123 | $base->scheme( $ENV{HTTPS} ? 'https' : 'http' ); |
6dc87a0f | 124 | $base->host( $c->apache->hostname ); |
125 | $base->port( $c->apache->get_server_port ); | |
126 | my $path = $c->apache->location; | |
3803e98f | 127 | $base->path( $path =~ /\/$/ ? $path : "$path/" ); |
6dc87a0f | 128 | $c->request->base( $base->as_string ); |
fc7ec1d9 | 129 | } |
130 | ||
23f9d934 | 131 | =item $c->prepare_request($r) |
fc7ec1d9 | 132 | |
133 | =cut | |
134 | ||
135 | sub prepare_request { | |
136 | my ( $c, $r ) = @_; | |
6dc87a0f | 137 | $c->apache( Apache::Request->new($r) ); |
fc7ec1d9 | 138 | } |
139 | ||
23f9d934 | 140 | =item $c->prepare_uploads |
fc7ec1d9 | 141 | |
142 | =cut | |
143 | ||
144 | sub prepare_uploads { | |
145 | my $c = shift; | |
6dc87a0f | 146 | for my $upload ( $c->apache->upload ) { |
147 | $upload = $c->apache->upload($upload) if MP2; | |
148 | $c->request->uploads->{ $upload->filename } = { | |
7833fdfc | 149 | fh => $upload->fh, |
150 | size => $upload->size, | |
151 | type => $upload->type | |
fc7ec1d9 | 152 | }; |
153 | } | |
154 | } | |
155 | ||
c9afa5fc | 156 | =item $c->run |
157 | ||
158 | =cut | |
159 | ||
e646f111 | 160 | sub run { } |
161 | ||
23f9d934 | 162 | =back |
163 | ||
fc7ec1d9 | 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; |