Commit | Line | Data |
---|---|---|
fc7ec1d9 | 1 | package Catalyst::Engine::Apache; |
2 | ||
3 | use strict; | |
fc7ec1d9 | 4 | use base 'Catalyst::Engine'; |
e7c0c583 | 5 | |
fc7ec1d9 | 6 | use URI; |
bc146cf4 | 7 | use URI::http; |
fc7ec1d9 | 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 | ||
329a7e51 | 21 | This is a base class 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 | ||
06e1b616 | 39 | =item $c->finalize_body |
fc7ec1d9 | 40 | |
41 | =cut | |
42 | ||
06e1b616 | 43 | sub finalize_body { |
fc7ec1d9 | 44 | my $c = shift; |
e060fe05 | 45 | $c->apache->print( $c->response->body ); |
fc7ec1d9 | 46 | } |
47 | ||
06e1b616 | 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 | ||
e060fe05 | 66 | $c->request->body($content); |
06e1b616 | 67 | } |
68 | ||
0556eb49 | 69 | =item $c->prepare_connection |
70 | ||
71 | =cut | |
72 | ||
73 | sub prepare_connection { | |
74 | my $c = shift; | |
6dc87a0f | 75 | $c->request->hostname( $c->apache->connection->remote_host ); |
76 | $c->request->address( $c->apache->connection->remote_ip ); | |
fc7ec1d9 | 77 | } |
78 | ||
23f9d934 | 79 | =item $c->prepare_headers |
fc7ec1d9 | 80 | |
81 | =cut | |
82 | ||
83 | sub prepare_headers { | |
84 | my $c = shift; | |
6dc87a0f | 85 | $c->request->method( $c->apache->method ); |
86 | $c->request->header( %{ $c->apache->headers_in } ); | |
fc7ec1d9 | 87 | } |
88 | ||
23f9d934 | 89 | =item $c->prepare_parameters |
fc7ec1d9 | 90 | |
91 | =cut | |
92 | ||
93 | sub prepare_parameters { | |
94 | my $c = shift; | |
e7c0c583 | 95 | |
6dc87a0f | 96 | foreach my $key ( $c->apache->param ) { |
97 | my @values = $c->apache->param($key); | |
e7c0c583 | 98 | $c->req->parameters->{$key} = ( @values == 1 ) ? $values[0] : \@values; |
fc7ec1d9 | 99 | } |
fc7ec1d9 | 100 | } |
101 | ||
23f9d934 | 102 | =item $c->prepare_path |
fc7ec1d9 | 103 | |
104 | =cut | |
105 | ||
13cafd1a | 106 | # XXX needs fixing, only work with <Location> directive, |
6dc87a0f | 107 | # not <Directory> directive |
fc7ec1d9 | 108 | sub prepare_path { |
109 | my $c = shift; | |
6dc87a0f | 110 | $c->request->path( $c->apache->uri ); |
111 | my $loc = $c->apache->location; | |
fc7ec1d9 | 112 | no warnings 'uninitialized'; |
113 | $c->req->{path} =~ s/^($loc)?\///; | |
114 | my $base = URI->new; | |
5ae68c0d | 115 | $base->scheme( $ENV{HTTPS} ? 'https' : 'http' ); |
6dc87a0f | 116 | $base->host( $c->apache->hostname ); |
117 | $base->port( $c->apache->get_server_port ); | |
118 | my $path = $c->apache->location; | |
3803e98f | 119 | $base->path( $path =~ /\/$/ ? $path : "$path/" ); |
6dc87a0f | 120 | $c->request->base( $base->as_string ); |
fc7ec1d9 | 121 | } |
122 | ||
c9afa5fc | 123 | =item $c->run |
124 | ||
125 | =cut | |
126 | ||
e646f111 | 127 | sub run { } |
128 | ||
23f9d934 | 129 | =back |
130 | ||
fc7ec1d9 | 131 | =head1 SEE ALSO |
132 | ||
133 | L<Catalyst>. | |
134 | ||
135 | =head1 AUTHOR | |
136 | ||
137 | Sebastian Riedel, C<sri@cpan.org> | |
329a7e51 | 138 | Christian Hansen C<ch@ngmedia.com> |
fc7ec1d9 | 139 | |
140 | =head1 COPYRIGHT | |
141 | ||
142 | This program is free software, you can redistribute it and/or modify it under | |
143 | the same terms as Perl itself. | |
144 | ||
145 | =cut | |
146 | ||
147 | 1; |