Commit | Line | Data |
c2e8e6fa |
1 | package Catalyst::Engine::Apache::Base; |
2 | |
3 | use strict; |
d837e1a7 |
4 | use base qw[Catalyst::Engine Catalyst::Engine::Apache]; |
c2e8e6fa |
5 | |
fc88e495 |
6 | use File::Spec; |
c2e8e6fa |
7 | use URI; |
8 | use URI::http; |
9 | |
10 | __PACKAGE__->mk_accessors(qw/apache/); |
11 | |
12 | =head1 NAME |
13 | |
14 | Catalyst::Engine::Apache::Base - Base class for Apache Engines |
15 | |
16 | =head1 SYNOPSIS |
17 | |
18 | See L<Catalyst>. |
19 | |
20 | =head1 DESCRIPTION |
21 | |
22 | This is a base class for Apache Engines. |
23 | |
24 | =head1 METHODS |
25 | |
26 | =over 4 |
27 | |
28 | =item $c->apache |
29 | |
30 | Returns an C<Apache::Request> object. |
31 | |
32 | =back |
33 | |
34 | =head1 OVERLOADED METHODS |
35 | |
36 | This class overloads some methods from C<Catalyst::Engine>. |
37 | |
38 | =over 4 |
39 | |
40 | =item $c->finalize_body |
41 | |
42 | =cut |
43 | |
44 | sub finalize_body { |
45 | my $c = shift; |
46 | $c->apache->print( $c->response->body ); |
47 | } |
48 | |
49 | =item $c->prepare_body |
50 | |
51 | =cut |
52 | |
53 | sub prepare_body { |
54 | my $c = shift; |
55 | |
56 | my $length = $c->request->content_length; |
57 | my ( $buffer, $content ); |
58 | |
59 | while ($length) { |
60 | |
61 | $c->apache->read( $buffer, ( $length < 8192 ) ? $length : 8192 ); |
62 | |
63 | $length -= length($buffer); |
64 | $content .= $buffer; |
65 | } |
66 | |
67 | $c->request->body($content); |
68 | } |
69 | |
70 | =item $c->prepare_connection |
71 | |
72 | =cut |
73 | |
74 | sub prepare_connection { |
75 | my $c = shift; |
76 | $c->request->address( $c->apache->connection->remote_ip ); |
77 | $c->request->hostname( $c->apache->connection->remote_host ); |
78 | $c->request->protocol( $c->apache->protocol ); |
66294129 |
79 | $c->request->user( $c->apache->user ); |
80 | |
b7b011a9 |
81 | if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { |
82 | $c->request->secure(1); |
83 | } |
84 | |
85 | if ( $c->apache->get_server_port == 443 ) { |
c2e8e6fa |
86 | $c->request->secure(1); |
87 | } |
88 | } |
89 | |
90 | =item $c->prepare_headers |
91 | |
92 | =cut |
93 | |
94 | sub prepare_headers { |
95 | my $c = shift; |
96 | $c->request->method( $c->apache->method ); |
97 | $c->request->header( %{ $c->apache->headers_in } ); |
98 | } |
99 | |
c2e8e6fa |
100 | =item $c->prepare_path |
101 | |
102 | =cut |
103 | |
104 | # XXX needs fixing, only work with <Location> directive, |
105 | # not <Directory> directive |
106 | sub prepare_path { |
107 | my $c = shift; |
53164bae |
108 | |
fc88e495 |
109 | { |
110 | my $path = $c->apache->uri; |
111 | |
112 | if ( my $location = $c->apache->location ) { |
113 | |
114 | if ( index( $path, $location ) == 0 ) { |
115 | $path = substr( $path, length($location) ); |
116 | } |
117 | } |
118 | |
119 | $path =~ s/^\///; |
120 | |
99386274 |
121 | if ( $c->apache->filename && -x $c->apache->filename ) { |
fc88e495 |
122 | |
53164bae |
123 | my $filename = ( File::Spec->splitpath( $c->apache->filename ) )[2]; |
fc88e495 |
124 | |
125 | if ( index( $path, $filename ) == 0 ) { |
126 | $path = substr( $path, length($filename) ); |
127 | } |
128 | } |
129 | |
130 | $path =~ s/^\///; |
131 | |
132 | $c->request->path($path); |
133 | } |
134 | |
c2e8e6fa |
135 | { |
136 | my $scheme = $c->request->secure ? 'https' : 'http'; |
137 | my $host = $c->apache->hostname; |
138 | my $port = $c->apache->get_server_port; |
fc88e495 |
139 | my $path = $c->apache->uri; |
53164bae |
140 | |
fc88e495 |
141 | if ( length( $c->request->path ) ) { |
142 | $path =~ s/\/$//; |
143 | $path = substr( $path, 0, length($path) - length($c->req->path) ); |
144 | } |
145 | |
c2e8e6fa |
146 | unless ( $path =~ /\/$/ ) { |
147 | $path .= '/'; |
148 | } |
149 | |
fc88e495 |
150 | my $base = URI->new; |
c2e8e6fa |
151 | $base->scheme($scheme); |
152 | $base->host($host); |
153 | $base->port($port); |
154 | $base->path($path); |
53164bae |
155 | |
fc88e495 |
156 | $c->request->base( $base->canonical->as_string ); |
c2e8e6fa |
157 | } |
c2e8e6fa |
158 | } |
159 | |
316bf0f0 |
160 | =item $c->prepare_request($r) |
161 | |
162 | =cut |
163 | |
164 | sub prepare_request { |
165 | my ( $c, $r ) = @_; |
166 | $c->apache($r); |
167 | } |
168 | |
c2e8e6fa |
169 | =item $c->run |
170 | |
171 | =cut |
172 | |
fc88e495 |
173 | sub run { shift->handler(@_) } |
c2e8e6fa |
174 | |
175 | =back |
176 | |
177 | =head1 SEE ALSO |
178 | |
179 | L<Catalyst> L<Catalyst::Engine>. |
180 | |
181 | =head1 AUTHOR |
182 | |
183 | Sebastian Riedel, C<sri@cpan.org> |
184 | Christian Hansen C<ch@ngmedia.com> |
185 | |
186 | =head1 COPYRIGHT |
187 | |
188 | This program is free software, you can redistribute it and/or modify it under |
189 | the same terms as Perl itself. |
190 | |
191 | =cut |
192 | |
193 | 1; |