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