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