13 use Maypole::Constants;
15 __PACKAGE__->mk_accessors( qw( ar ) );
21 $MODPERL2 = ( exists $ENV{MOD_PERL_API_VERSION} and
22 $ENV{MOD_PERL_API_VERSION} >= 2 );
24 eval 'use mod_perl2; $modperl_version = $mod_perl2::VERSION;';
26 $modperl_version = $Apache2::RequestRec::VERSION;
28 require Apache2::RequestIO;
29 require Apache2::RequestRec;
30 require Apache2::RequestUtil;
31 eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import
35 eval ' use mod_perl; ';
37 require Apache::Request;
38 eval 'use Apache::Constants -compile => qw/REDIRECT/;';
46 Apache::MVC - Apache front-end to Maypole
51 use Maypole::Application;
55 A mod_perl platform driver for Maypole. Your application can inherit from
56 Apache::MVC directly, but it is recommended that you use
57 L<Maypole::Application>.
61 Create a driver module like the one illustrated in L<Maypole::Application>.
63 Put the following in your Apache config:
66 SetHandler perl-script
70 Copy the templates found in F<templates/factory> into the F<beer/factory>
71 directory off the web root. When the designers get back to you with custom
72 templates, they are to go in F<beer/custom>. If you need to override templates
73 on a database-table-by-table basis, put the new template in F<beer/I<table>>.
75 This will automatically give you C<add>, C<edit>, C<list>, C<view> and C<delete>
76 commands; for instance, to see a list of breweries, go to
78 http://your.site/beer/brewery/list
80 For more information about how the system works and how to extend it,
85 This class overrides a set of methods in the base Maypole class to provide its
86 functionality. See L<Maypole> for these:
96 my $request_options = $self->config->request_options || {};
99 $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r;
101 else { $ar = Apache::Request->instance($r,%{$request_options}); }
110 my ($self,@args) = @_;
111 my ($package, $line) = (caller)[0,2];
112 my $ar = $self->parent ? $self->parent->{ar} : $self->{ar};
113 if ( $args[0] and ref $self ) {
114 $ar->warn("[$package line $line] ", @args) ;
116 print "warn called by ", caller, " with ", @_, "\n";
129 # Reconstruct the request headers
130 $self->headers_in(Maypole::Headers->new);
133 if ($MODPERL2) { %headers = %{$self->ar->headers_in};
134 } else { %headers = $self->ar->headers_in; }
135 for (keys %headers) {
136 $self->headers_in->set($_, $headers{$_});
139 $self->preprocess_location();
141 my $path = $self->ar->uri;
142 my $base = URI->new($self->config->uri_base);
143 my $loc = $base->path;
146 no warnings 'uninitialized';
147 $path .= '/' if $path eq $loc;
149 $path =~ s/^($loc)?//;
151 $path =~ s/^($loc)?\///;
166 $self->params( { $self->_mod_perl_args( $self->ar ) } );
167 $self->query( $self->params );
170 =item redirect_request
172 Sets output headers to redirect based on the arguments provided
174 Accepts either a single argument of the full url to redirect to, or a hash of
177 $r->redirect_request('http://www.example.com/path');
181 $r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
183 The named parameters are protocol, domain, path, status and url
185 Only 1 named parameter is required but other than url, they can be combined as
186 required and current values (from the request) will be used in place of any
187 missing arguments. The url argument must be a full url including protocol and
188 can only be combined with status.
192 sub redirect_request {
194 my $redirect_url = $_[0];
195 my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' :
196 eval 'Apache::Constants::REDIRECT;'; # why have to eval this?
200 $redirect_url = $args{url};
202 my $path = $args{path} || $r->path;
203 my $host = $args{domain} || $r->ar->hostname;
204 my $protocol = $args{protocol} || $r->get_protocol;
206 $redirect_url = URI->new;
207 $redirect_url->scheme($protocol);
208 $redirect_url->host($host);
209 $redirect_url->path($path);
211 $status = $args{status} if ($args{status});
214 $r->ar->status($status);
215 $r->ar->headers_out->set('Location' => $redirect_url);
226 my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
236 $r->ar->content_type(
237 $r->content_type =~ m/^text/
238 ? $r->content_type . "; charset=" . $r->document_encoding
241 $r->ar->headers_out->set(
242 "Content-Length" => do { use bytes; length $r->output }
245 foreach ($r->headers_out->field_names) {
246 next if /^Content-(Type|Length)/;
247 $r->ar->headers_out->set($_ => $r->headers_out->get($_));
250 $MODPERL2 || $r->ar->send_http_header;
251 $r->ar->print( $r->output );
254 =item get_template_root
258 sub get_template_root {
260 $r->ar->document_root . "/" . $r->ar->location;
267 #########################################################
268 # private / internal methods and subs
272 my ( $self, $apr ) = @_;
274 if ($apr->isa('Apache::Request')) {
275 foreach my $key ( $apr->param ) {
276 my @values = $apr->param($key);
277 $args{$key} = @values == 1 ? $values[0] : \@values;
280 my $body = $self->_prepare_body($apr);
281 %args = %{$body->param};
282 my $uri = URI->new($self->ar->unparsed_uri);
283 foreach my $key ($uri->query_param) {
284 if (ref $args{$key}) {
285 push (@{$args{$key}}, $uri->query_param($key));
288 $args{$key} = [ $args{$key}, $uri->query_param($key) ];
290 my @args = $uri->query_param($key);
291 if (scalar @args > 1) {
292 $args{$key} = [ $uri->query_param($key) ];
294 $args{$key} = $uri->query_param($key);
304 my ( $self, $r ) = @_;
306 unless ($self->{__http_body}) {
307 my $content_type = $r->headers_in->get('Content-Type');
308 my $content_length = $r->headers_in->get('Content-Length');
309 my $body = HTTP::Body->new( $content_type, $content_length );
310 my $length = $content_length;
312 $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
313 $length -= length($buffer);
316 $self->{__http_body} = $body;
318 return $self->{__http_body};
325 Simon Cozens, C<simon@cpan.org>
330 Marcus Ramberg, C<marcus@thefeed.no>
331 Sebastian Riedel, C<sri@oook.de>
335 You may distribute this code under the same terms as Perl itself.