3 our $VERSION = '2.121';
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;
31 require Apache2::RequestUtil;
32 eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import
36 eval ' use mod_perl; ';
38 require Apache::Request;
39 eval 'use Apache::Constants -compile => qw/REDIRECT/;';
47 Apache::MVC - Apache front-end to Maypole
52 use Maypole::Application;
56 A mod_perl platform driver for Maypole. Your application can inherit from
57 Apache::MVC directly, but it is recommended that you use
58 L<Maypole::Application>.
62 Create a driver module like the one illustrated in L<Maypole::Application>.
64 Put the following in your Apache config:
67 SetHandler perl-script
71 Copy the templates found in F<templates/factory> into the F<beer/factory>
72 directory off the web root. When the designers get back to you with custom
73 templates, they are to go in F<beer/custom>. If you need to override templates
74 on a database-table-by-table basis, put the new template in F<beer/I<table>>.
76 This will automatically give you C<add>, C<edit>, C<list>, C<view> and C<delete>
77 commands; for instance, to see a list of breweries, go to
79 http://your.site/beer/brewery/list
81 For more information about how the system works and how to extend it,
86 This class overrides a set of methods in the base Maypole class to provide its
87 functionality. See L<Maypole> for these:
97 my $request_options = $self->config->request_options || {};
100 $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r;
102 if (keys %$request_options) {
103 $ar = Apache::Request->new($r,%{$request_options});
105 $ar = Apache::Request->instance($r);
116 my ($self,@args) = @_;
117 my ($package, $line) = (caller)[0,2];
118 my $ar = $self->parent ? $self->parent->{ar} : $self->{ar};
119 if ( $args[0] and ref $self ) {
120 my @lines = split /\n/, (join '', @args);
121 $ar->warn("[$package line $line] ".shift(@lines));
126 $ar->warn("[$package line $line] ", @args) ;
128 print STDERR "warn called by ", caller, " with ", @_, "\n";
141 # Reconstruct the request headers
142 $self->headers_in(Maypole::Headers->new);
145 if ($MODPERL2) { %headers = %{$self->ar->headers_in};
146 } else { %headers = $self->ar->headers_in; }
147 for (keys %headers) {
148 $self->headers_in->set($_, $headers{$_});
151 $self->preprocess_location();
153 my $path = $self->ar->uri;
154 my $base = URI->new($self->config->uri_base);
155 my $loc = $base->path;
158 no warnings 'uninitialized';
159 $path .= '/' if $path eq $loc;
161 $path =~ s/^($loc)?//;
163 $path =~ s/^($loc)?\///;
178 $self->params( { $self->_mod_perl_args( $self->ar ) } );
179 $self->query( $self->params );
182 =item redirect_request
184 Sets output headers to redirect based on the arguments provided
186 Accepts either a single argument of the full url to redirect to, or a hash of
189 $r->redirect_request('http://www.example.com/path');
193 $r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
195 The named parameters are protocol, domain, path, status and url
197 Only 1 named parameter is required but other than url, they can be combined as
198 required and current values (from the request) will be used in place of any
199 missing arguments. The url argument must be a full url including protocol and
200 can only be combined with status.
204 sub redirect_request {
206 my $redirect_url = $_[0];
207 my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : eval 'Apache::Constants::REDIRECT;';
211 $redirect_url = $args{url};
213 my $path = $args{path} || $r->path;
214 my $host = $args{domain} || $r->ar->hostname;
215 my $protocol = $args{protocol} || $r->get_protocol;
217 $redirect_url = URI->new;
218 $redirect_url->scheme($protocol);
219 $redirect_url->host($host);
220 $redirect_url->path($path);
222 $status = $args{status} if ($args{status});
225 $r->ar->status($status);
226 $r->ar->headers_out->set('Location' => $redirect_url);
227 $r->output('<html><head><title>redirecting...</title></head><body><h2>redirecting..</h2></body></html>') unless ($r->output);
238 my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
248 $r->ar->content_type(
249 $r->content_type =~ m/^text/
250 ? $r->content_type . "; charset=" . $r->document_encoding
253 $r->ar->headers_out->set(
254 "Content-Length" => do { use bytes; length $r->output }
257 foreach ($r->headers_out->field_names) {
258 next if /^Content-(Type|Length)/;
259 $r->ar->headers_out->set($_ => $r->headers_out->get($_));
262 $MODPERL2 || $r->ar->send_http_header;
263 $r->ar->print( $r->output );
266 =item get_template_root
270 sub get_template_root {
272 $r->ar->document_root . "/" . $r->ar->location;
279 #########################################################
280 # private / internal methods and subs
284 my ( $self, $apr ) = @_;
286 if ($apr->isa('Apache::Request')) {
287 foreach my $key ( $apr->param ) {
288 my @values = $apr->param($key);
289 $args{$key} = @values == 1 ? $values[0] : \@values;
292 my $body = $self->_prepare_body($apr);
293 %args = %{$body->param};
294 my $uri = URI->new($self->ar->unparsed_uri);
295 foreach my $key ($uri->query_param) {
296 if (ref $args{$key}) {
297 push (@{$args{$key}}, $uri->query_param($key));
300 $args{$key} = [ $args{$key}, $uri->query_param($key) ];
302 my @args = $uri->query_param($key);
303 if (scalar @args > 1) {
304 $args{$key} = [ $uri->query_param($key) ];
306 $args{$key} = $uri->query_param($key);
316 my ( $self, $r ) = @_;
318 unless ($self->{__http_body}) {
319 my $content_type = $r->headers_in->get('Content-Type');
320 my $content_length = $r->headers_in->get('Content-Length');
321 my $body = HTTP::Body->new( $content_type, $content_length );
322 my $length = $content_length;
324 $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
325 $length -= length($buffer);
328 $self->{__http_body} = $body;
330 return $self->{__http_body};
337 Simon Cozens, C<simon@cpan.org>
342 Marcus Ramberg, C<marcus@thefeed.no>
343 Sebastian Riedel, C<sri@oook.de>
347 You may distribute this code under the same terms as Perl itself.