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;
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 if (keys %$request_options) {
102 $ar = Apache::Request->new($r,%{$request_options});
104 $ar = Apache::Request->instance($r);
115 my ($self,@args) = @_;
116 my ($package, $line) = (caller)[0,2];
117 my $ar = $self->parent ? $self->parent->{ar} : $self->{ar};
118 if ( $args[0] and ref $self ) {
119 $ar->warn("[$package line $line] ", @args) ;
121 print "warn called by ", caller, " with ", @_, "\n";
134 # Reconstruct the request headers
135 $self->headers_in(Maypole::Headers->new);
138 if ($MODPERL2) { %headers = %{$self->ar->headers_in};
139 } else { %headers = $self->ar->headers_in; }
140 for (keys %headers) {
141 $self->headers_in->set($_, $headers{$_});
144 $self->preprocess_location();
146 my $path = $self->ar->uri;
147 my $base = URI->new($self->config->uri_base);
148 my $loc = $base->path;
151 no warnings 'uninitialized';
152 $path .= '/' if $path eq $loc;
154 $path =~ s/^($loc)?//;
156 $path =~ s/^($loc)?\///;
171 $self->params( { $self->_mod_perl_args( $self->ar ) } );
172 $self->query( $self->params );
175 =item redirect_request
177 Sets output headers to redirect based on the arguments provided
179 Accepts either a single argument of the full url to redirect to, or a hash of
182 $r->redirect_request('http://www.example.com/path');
186 $r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
188 The named parameters are protocol, domain, path, status and url
190 Only 1 named parameter is required but other than url, they can be combined as
191 required and current values (from the request) will be used in place of any
192 missing arguments. The url argument must be a full url including protocol and
193 can only be combined with status.
197 sub redirect_request {
199 my $redirect_url = $_[0];
200 my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : eval 'Apache::Constants::REDIRECT;';
204 $redirect_url = $args{url};
206 my $path = $args{path} || $r->path;
207 my $host = $args{domain} || $r->ar->hostname;
208 my $protocol = $args{protocol} || $r->get_protocol;
210 $redirect_url = URI->new;
211 $redirect_url->scheme($protocol);
212 $redirect_url->host($host);
213 $redirect_url->path($path);
215 $status = $args{status} if ($args{status});
218 $r->ar->status($status);
219 $r->ar->headers_out->set('Location' => $redirect_url);
220 $r->output('<html><head><title>redirecting...</title></head><body><h2>redirecting..</h2></body></html>') unless ($r->output)
231 my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
241 $r->ar->content_type(
242 $r->content_type =~ m/^text/
243 ? $r->content_type . "; charset=" . $r->document_encoding
246 $r->ar->headers_out->set(
247 "Content-Length" => do { use bytes; length $r->output }
250 foreach ($r->headers_out->field_names) {
251 next if /^Content-(Type|Length)/;
252 $r->ar->headers_out->set($_ => $r->headers_out->get($_));
255 $MODPERL2 || $r->ar->send_http_header;
256 $r->ar->print( $r->output );
259 =item get_template_root
263 sub get_template_root {
265 $r->ar->document_root . "/" . $r->ar->location;
272 #########################################################
273 # private / internal methods and subs
277 my ( $self, $apr ) = @_;
279 if ($apr->isa('Apache::Request')) {
280 foreach my $key ( $apr->param ) {
281 my @values = $apr->param($key);
282 $args{$key} = @values == 1 ? $values[0] : \@values;
285 my $body = $self->_prepare_body($apr);
286 %args = %{$body->param};
287 my $uri = URI->new($self->ar->unparsed_uri);
288 foreach my $key ($uri->query_param) {
289 if (ref $args{$key}) {
290 push (@{$args{$key}}, $uri->query_param($key));
293 $args{$key} = [ $args{$key}, $uri->query_param($key) ];
295 my @args = $uri->query_param($key);
296 if (scalar @args > 1) {
297 $args{$key} = [ $uri->query_param($key) ];
299 $args{$key} = $uri->query_param($key);
309 my ( $self, $r ) = @_;
311 unless ($self->{__http_body}) {
312 my $content_type = $r->headers_in->get('Content-Type');
313 my $content_length = $r->headers_in->get('Content-Length');
314 my $body = HTTP::Body->new( $content_type, $content_length );
315 my $length = $content_length;
317 $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
318 $length -= length($buffer);
321 $self->{__http_body} = $body;
323 return $self->{__http_body};
330 Simon Cozens, C<simon@cpan.org>
335 Marcus Ramberg, C<marcus@thefeed.no>
336 Sebastian Riedel, C<sri@oook.de>
340 You may distribute this code under the same terms as Perl itself.