lib/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   my $ar = $self->parent ? $self->parent->{ar} : $self->{ar};
 112   if ( $args[0] and ref $self ) {
 113     $ar->warn("[$package line $line] ", @args) ;
 114   } else {
 115     print "warn called by ", caller, " with ", @_, "\n";
 116   }
 117   return;
 118 }
 119
 120
 121 =item parse_location
 122
 123 =cut
 124
 125 sub parse_location {
 126     my $self = shift;
 127
 128     # Reconstruct the request headers
 129     $self->headers_in(Maypole::Headers->new);
 130
 131     my %headers;
 132     if ($MODPERL2) { %headers = %{$self->ar->headers_in};
 133     } else { %headers = $self->ar->headers_in; }
 134     for (keys %headers) {
 135         $self->headers_in->set($_, $headers{$_});
 136     }
 137
 138     $self->preprocess_location();
 139
 140     my $path = $self->ar->uri;
 141     my $base  = URI->new($self->config->uri_base);
 142     my $loc = $base->path;
 143
 144     {
 145         no warnings 'uninitialized';
 146         $path .= '/' if $path eq $loc;
 147         if ($loc =~ /\/$/) {
 148           $path =~ s/^($loc)?//;
 149         } else {
 150           $path =~ s/^($loc)?\///;
 151         }
 152     }
 153
 154     $self->path($path);
 155     $self->parse_path;
 156     $self->parse_args;
 157 }
 158
 159 =item parse_args
 160
 161 =cut
 162
 163 sub parse_args {
 164     my $self = shift;
 165     $self->params( { $self->_mod_perl_args( $self->ar ) } );
 166     $self->query( $self->params );
 167 }
 168
 169 =item redirect_request
 170
 171 Sets output headers to redirect based on the arguments provided
 172
 173 Accepts either a single argument of the full url to redirect to, or a hash of
 174 named parameters :
 175
 176 $r->redirect_request('http://www.example.com/path');
 177
 178 or
 179
 180 $r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
 181
 182 The named parameters are protocol, domain, path, status and url
 183
 184 Only 1 named parameter is required but other than url, they can be combined as
 185 required and current values (from the request) will be used in place of any
 186 missing arguments. The url argument must be a full url including protocol and
 187 can only be combined with status.
 188
 189 =cut
 190
 191 sub redirect_request {
 192   my $r = shift;
 193   my $redirect_url = $_[0];
 194   my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' :
 195           eval 'Apache::Constants::REDIRECT;'; # why have to eval this?
 196   if ($_[1]) {
 197     my %args = @_;
 198     if ($args{url}) {
 199       $redirect_url = $args{url};
 200     } else {
 201       my $path = $args{path} || $r->path;
 202       my $host = $args{domain} || $r->ar->hostname;
 203       my $protocol = $args{protocol} || $r->get_protocol;
 204
 205       $redirect_url = URI->new;
 206          $redirect_url->scheme($protocol);
 207          $redirect_url->host($host);
 208          $redirect_url->path($path);
 209     }
 210     $status = $args{status} if ($args{status});
 211   }
 212
 213   $r->ar->status($status);
 214   $r->ar->headers_out->set('Location' => $redirect_url);
 215   return OK;
 216 }
 217
 218
 219 =item get_protocol
 220
 221 =cut
 222
 223 sub get_protocol {
 224   my $self = shift;
 225   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
 226   return $protocol;
 227 }
 228
 229 =item send_output
 230
 231 =cut
 232
 233 sub send_output {
 234     my $r = shift;
 235     $r->ar->content_type(
 236           $r->content_type =~ m/^text/
 237         ? $r->content_type . "; charset=" . $r->document_encoding
 238         : $r->content_type
 239     );
 240     $r->ar->headers_out->set(
 241         "Content-Length" => do { use bytes; length $r->output }
 242     );
 243
 244     foreach ($r->headers_out->field_names) {
 245         next if /^Content-(Type|Length)/;
 246         $r->ar->headers_out->set($_ => $r->headers_out->get($_));
 247     }
 248
 249     $MODPERL2 || $r->ar->send_http_header;
 250     $r->ar->print( $r->output );
 251 }
 252
 253 =item get_template_root
 254
 255 =cut
 256
 257 sub get_template_root {
 258     my $r = shift;
 259     $r->ar->document_root . "/" . $r->ar->location;
 260 }
 261
 262 =back
 263
 264 =cut
 265
 266 #########################################################
 267 # private / internal methods and subs
 268
 269
 270 sub _mod_perl_args {
 271     my ( $self, $apr ) = @_;
 272     my %args;
 273     if ($apr->isa('Apache::Request')) {
 274       foreach my $key ( $apr->param ) {
 275         my @values = $apr->param($key);
 276         $args{$key} = @values == 1 ? $values[0] : \@values;
 277       }
 278     } else {
 279       my $body = $self->_prepare_body($apr);
 280       %args = %{$body->param};
 281       my $uri = URI->new($self->ar->unparsed_uri);
 282       foreach my $key ($uri->query_param) {
 283         if (ref $args{$key}) {
 284           push (@{$args{$key}}, $uri->query_param($key));
 285         } else {
 286           if ($args{$key}) {
 287             $args{$key} = [ $args{$key}, $uri->query_param($key) ];
 288           } else {
 289             my @args = $uri->query_param($key);
 290             if (scalar @args > 1) {
 291               $args{$key} = [ $uri->query_param($key) ];
 292             } else {
 293               $args{$key} = $uri->query_param($key);
 294             }
 295           }
 296         }
 297       }
 298     }
 299     return %args;
 300 }
 301
 302 sub _prepare_body {
 303     my ( $self, $r ) = @_;
 304
 305     unless ($self->{__http_body}) {
 306         my $content_type   = $r->headers_in->get('Content-Type');
 307         my $content_length = $r->headers_in->get('Content-Length');
 308         my $body   = HTTP::Body->new( $content_type, $content_length );
 309         my $length = $content_length;
 310         while ( $length ) {
 311             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
 312             $length -= length($buffer);
 313             $body->add($buffer);
 314         }
 315         $self->{__http_body} = $body;
 316     }
 317     return $self->{__http_body};
 318 }
 319
 320
 321
 322 =head1 AUTHOR
 323
 324 Simon Cozens, C<simon@cpan.org>
 325
 326 =head1 CREDITS
 327
 328 Aaron Trevena
 329 Marcus Ramberg, C<marcus@thefeed.no>
 330 Sebastian Riedel, C<sri@oook.de>
 331
 332 =head1 LICENSE
 333
 334 You may distribute this code under the same terms as Perl itself.
 335
 336 =cut
 337
 338 1;