lib/Apache/MVC.pm

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