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 | |
c2e8e6fa |
81 | if ( $ENV{HTTPS} || $c->apache->get_server_port == 443 ) { |
82 | $c->request->secure(1); |
83 | } |
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 | |
c2e8e6fa |
96 | =item $c->prepare_path |
97 | |
98 | =cut |
99 | |
100 | # XXX needs fixing, only work with <Location> directive, |
101 | # not <Directory> directive |
102 | sub prepare_path { |
103 | my $c = shift; |
53164bae |
104 | |
fc88e495 |
105 | { |
106 | my $path = $c->apache->uri; |
107 | |
108 | if ( my $location = $c->apache->location ) { |
109 | |
110 | if ( index( $path, $location ) == 0 ) { |
111 | $path = substr( $path, length($location) ); |
112 | } |
113 | } |
114 | |
115 | $path =~ s/^\///; |
116 | |
53164bae |
117 | if ( $c->apache->filename && -e $c->apache->filename ) { |
fc88e495 |
118 | |
53164bae |
119 | my $filename = ( File::Spec->splitpath( $c->apache->filename ) )[2]; |
fc88e495 |
120 | |
121 | if ( index( $path, $filename ) == 0 ) { |
122 | $path = substr( $path, length($filename) ); |
123 | } |
124 | } |
125 | |
126 | $path =~ s/^\///; |
127 | |
128 | $c->request->path($path); |
129 | } |
130 | |
c2e8e6fa |
131 | { |
132 | my $scheme = $c->request->secure ? 'https' : 'http'; |
133 | my $host = $c->apache->hostname; |
134 | my $port = $c->apache->get_server_port; |
fc88e495 |
135 | my $path = $c->apache->uri; |
53164bae |
136 | |
fc88e495 |
137 | if ( length( $c->request->path ) ) { |
138 | $path =~ s/\/$//; |
139 | $path = substr( $path, 0, length($path) - length($c->req->path) ); |
140 | } |
141 | |
c2e8e6fa |
142 | unless ( $path =~ /\/$/ ) { |
143 | $path .= '/'; |
144 | } |
145 | |
fc88e495 |
146 | my $base = URI->new; |
c2e8e6fa |
147 | $base->scheme($scheme); |
148 | $base->host($host); |
149 | $base->port($port); |
150 | $base->path($path); |
53164bae |
151 | |
fc88e495 |
152 | $c->request->base( $base->canonical->as_string ); |
c2e8e6fa |
153 | } |
c2e8e6fa |
154 | } |
155 | |
316bf0f0 |
156 | =item $c->prepare_request($r) |
157 | |
158 | =cut |
159 | |
160 | sub prepare_request { |
161 | my ( $c, $r ) = @_; |
162 | $c->apache($r); |
163 | } |
164 | |
c2e8e6fa |
165 | =item $c->run |
166 | |
167 | =cut |
168 | |
fc88e495 |
169 | sub run { shift->handler(@_) } |
c2e8e6fa |
170 | |
171 | =back |
172 | |
173 | =head1 SEE ALSO |
174 | |
175 | L<Catalyst> L<Catalyst::Engine>. |
176 | |
177 | =head1 AUTHOR |
178 | |
179 | Sebastian Riedel, C<sri@cpan.org> |
180 | Christian Hansen C<ch@ngmedia.com> |
181 | |
182 | =head1 COPYRIGHT |
183 | |
184 | This program is free software, you can redistribute it and/or modify it under |
185 | the same terms as Perl itself. |
186 | |
187 | =cut |
188 | |
189 | 1; |