]> git.decadent.org.uk Git - maypole.git/blob - Apache/MVC.pm
Add Vcs-* fields pointing to my public repository
[maypole.git] / Apache / MVC.pm
1 package Apache::MVC;
2
3 our $VERSION = '2.11';
4
5 use strict;
6 use warnings;
7
8 use URI;
9 use URI::QueryParam;
10
11 use base 'Maypole';
12 use Maypole::Headers;
13 use Maypole::Constants;
14
15 __PACKAGE__->mk_accessors( qw( ar ) );
16
17 our $MODPERL2;
18 our $modperl_version;
19
20 BEGIN {
21     $MODPERL2  = ( exists $ENV{MOD_PERL_API_VERSION} and
22                         $ENV{MOD_PERL_API_VERSION} >= 2 );
23     if ($MODPERL2) {
24      eval 'use mod_perl2; $modperl_version = $mod_perl2::VERSION;';
25      if ($@) {
26       $modperl_version = $Apache2::RequestRec::VERSION;
27      }
28      require Apache2::RequestIO;
29      require Apache2::RequestRec;
30      require Apache2::RequestUtil;
31      eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import
32      require APR::URI;
33      require HTTP::Body;
34     } else {
35      eval ' use mod_perl; ';
36      require Apache;
37      require Apache::Request;
38      eval 'use Apache::Constants -compile => qw/REDIRECT/;';
39      $modperl_version = 1;
40     }
41
42 }
43
44 =head1 NAME
45
46 Apache::MVC - Apache front-end to Maypole
47
48 =head1 SYNOPSIS
49
50     package BeerDB;
51     use Maypole::Application;
52
53 =head1 DESCRIPTION
54
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>.
58
59 =head1 INSTALLATION
60
61 Create a driver module like the one illustrated in L<Maypole::Application>.
62
63 Put the following in your Apache config:
64
65     <Location /beer>
66         SetHandler perl-script
67         PerlHandler BeerDB
68     </Location>
69
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>>.
74
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
77
78     http://your.site/beer/brewery/list
79
80 For more information about how the system works and how to extend it,
81 see L<Maypole>.
82
83 =head1 Implementation
84
85 This class overrides a set of methods in the base Maypole class to provide its
86 functionality. See L<Maypole> for these:
87
88 =over
89
90 =item get_request
91
92 =cut
93
94 sub get_request {
95     my ($self, $r) = @_;
96     my $ar;
97     if ($MODPERL2) {
98         $ar = eval {require Apache2::Request} ? Apache2::Request->new($r) : $r;
99         }
100     else { $ar = Apache::Request->instance($r); }
101     $self->ar($ar);
102 }
103
104 =item warn
105
106 =cut
107
108 sub warn {
109   my ($self,@args) = @_;
110   my ($package, $line) = (caller)[0,2];
111   if ( $args[0] and ref $self ) {
112     $self->{ar}->warn("[$package line $line] ", @args) ;
113   } else {
114     print "warn called by ", caller, " with ", @_, "\n";
115   }
116   return;
117 }
118
119
120 =item parse_location
121
122 =cut
123
124 sub parse_location {
125     my $self = shift;
126
127     # Reconstruct the request headers
128     $self->headers_in(Maypole::Headers->new);
129     my %headers;
130     if ($MODPERL2) { %headers = %{$self->ar->headers_in};
131     } else { %headers = $self->ar->headers_in; }
132     for (keys %headers) {
133         $self->headers_in->set($_, $headers{$_});
134     }
135
136     my $path = $self->ar->uri;
137     my $base  = URI->new($self->config->uri_base);
138     my $loc = $base->path;
139
140     {
141         no warnings 'uninitialized';
142         $path .= '/' if $path eq $loc;
143         if ($loc =~ /\/$/) {
144           $path =~ s/^($loc)?//;
145         } else {
146           $path =~ s/^($loc)?\///;
147         }
148     }
149
150     $self->path($path);
151     $self->parse_path;
152     $self->parse_args;
153 }
154
155 =item parse_args
156
157 =cut
158
159 sub parse_args {
160     my $self = shift;
161     $self->params( { $self->_mod_perl_args( $self->ar ) } );
162     $self->query( $self->params );
163 }
164
165 =item redirect_request
166
167 Sets output headers to redirect based on the arguments provided
168
169 Accepts either a single argument of the full url to redirect to, or a hash of
170 named parameters :
171
172 $r->redirect_request('http://www.example.com/path');
173
174 or
175
176 $r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
177
178 The named parameters are protocol, domain, path, status and url
179
180 Only 1 named parameter is required but other than url, they can be combined as
181 required and current values (from the request) will be used in place of any
182 missing arguments. The url argument must be a full url including protocol and
183 can only be combined with status.
184
185 =cut
186
187 sub redirect_request
188 {
189   my $r = shift;
190   my $redirect_url = $_[0];
191   my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' :
192           eval 'Apache::Constants::REDIRECT;'; # why have to eval this?
193   if ($_[1]) {
194     my %args = @_;
195     if ($args{url}) {
196       $redirect_url = $args{url};
197     } else {
198       my $path = $args{path} || $r->path;
199       my $host = $args{domain} || $r->ar->hostname;
200       my $protocol = $args{protocol} || $r->get_protocol;
201       $redirect_url = "${protocol}://${host}/${path}";
202     }
203     $status = $args{status} if ($args{status});
204   }
205
206   $r->ar->status($status);
207   $r->ar->headers_out->set('Location' => $redirect_url);
208   return OK;
209 }
210
211 =item get_protocol
212
213 =cut
214
215 sub get_protocol {
216   my $self = shift;
217   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
218   return $protocol;
219 }
220
221 =item send_output
222
223 =cut
224
225 sub send_output {
226     my $r = shift;
227     $r->ar->content_type(
228           $r->content_type =~ m/^text/
229         ? $r->content_type . "; charset=" . $r->document_encoding
230         : $r->content_type
231     );
232     $r->ar->headers_out->set(
233         "Content-Length" => do { use bytes; length $r->output }
234     );
235
236     foreach ($r->headers_out->field_names) {
237         next if /^Content-(Type|Length)/;
238         $r->ar->headers_out->set($_ => $r->headers_out->get($_));
239     }
240
241     $MODPERL2 || $r->ar->send_http_header;
242     $r->ar->print( $r->output );
243 }
244
245 =item get_template_root
246
247 =cut
248
249 sub get_template_root {
250     my $r = shift;
251     $r->ar->document_root . "/" . $r->ar->location;
252 }
253
254 =back
255
256 =cut
257
258 #########################################################
259 # private / internal methods and subs
260
261
262 sub _mod_perl_args {
263     my ( $self, $apr ) = @_;
264     my %args;
265     if ($apr->isa('Apache::Request')) {
266       foreach my $key ( $apr->param ) {
267         my @values = $apr->param($key);
268         $args{$key} = @values == 1 ? $values[0] : \@values;
269       }
270     } else {
271       my $body = $self->_prepare_body($apr);
272       %args = %{$body->param};
273       my $uri = URI->new($self->ar->unparsed_uri);
274       foreach my $key ($uri->query_param) {
275         if (ref $args{$key}) {
276           push (@{$args{$key}}, $uri->query_param($key));
277         } else {
278           if ($args{$key}) {
279             $args{$key} = [ $args{$key}, $uri->query_param($key) ];
280           } else {
281             my @args = $uri->query_param($key);
282             if (scalar @args > 1) {
283               $args{$key} = [ $uri->query_param($key) ];
284             } else {
285               $args{$key} = $uri->query_param($key);
286             }
287           }
288         }
289       }
290     }
291     return %args;
292 }
293
294 sub _prepare_body {
295     my ( $self, $r ) = @_;
296
297     unless ($self->{__http_body}) {
298         my $content_type   = $r->headers_in->get('Content-Type');
299         my $content_length = $r->headers_in->get('Content-Length');
300         my $body   = HTTP::Body->new( $content_type, $content_length );
301         my $length = $content_length;
302         while ( $length ) {
303             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
304             $length -= length($buffer);
305             $body->add($buffer);
306         }
307         $self->{__http_body} = $body;
308     }
309     return $self->{__http_body};
310 }
311
312
313
314 =head1 AUTHOR
315
316 Simon Cozens, C<simon@cpan.org>
317
318 =head1 CREDITS
319
320 Aaron Trevena
321 Marcus Ramberg, C<marcus@thefeed.no>
322 Sebastian Riedel, C<sri@oook.de>
323
324 =head1 LICENSE
325
326 You may distribute this code under the same terms as Perl itself.
327
328 =cut
329
330 1;