lib/Apache/MVC.pm

   1 package Apache::MVC;
   2
   3 our $VERSION = '2.121';
   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      use Apache2::Log;
  31      require Apache2::RequestUtil;
  32      eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import
  33      require APR::URI;
  34      require HTTP::Body;
  35     } else {
  36      eval ' use mod_perl; ';
  37      require Apache;
  38      require Apache::Request;
  39      eval 'use Apache::Constants -compile => qw/REDIRECT/;';
  40      $modperl_version = 1;
  41     }
  42
  43 }
  44
  45 =head1 NAME
  46
  47 Apache::MVC - Apache front-end to Maypole
  48
  49 =head1 SYNOPSIS
  50
  51     package BeerDB;
  52     use Maypole::Application;
  53
  54 =head1 DESCRIPTION
  55
  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>.
  59
  60 =head1 INSTALLATION
  61
  62 Create a driver module like the one illustrated in L<Maypole::Application>.
  63
  64 Put the following in your Apache config:
  65
  66     <Location /beer>
  67         SetHandler perl-script
  68         PerlHandler BeerDB
  69     </Location>
  70
  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>>.
  75
  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
  78
  79     http://your.site/beer/brewery/list
  80
  81 For more information about how the system works and how to extend it,
  82 see L<Maypole>.
  83
  84 =head1 Implementation
  85
  86 This class overrides a set of methods in the base Maypole class to provide its
  87 functionality. See L<Maypole> for these:
  88
  89 =over
  90
  91 =item get_request
  92
  93 =cut
  94
  95 sub get_request {
  96     my ($self, $r) = @_;
  97     my $request_options = $self->config->request_options || {};
  98     my $ar;
  99     if ($MODPERL2) {
 100       $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r;
 101     } else {
 102       if (keys %$request_options) {
 103         $ar = Apache::Request->new($r,%{$request_options});
 104       } else {
 105         $ar = Apache::Request->instance($r);
 106       }
 107     }
 108     $self->ar($ar);
 109 }
 110
 111 =item warn
 112
 113 =cut
 114
 115 sub warn {
 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));
 122     foreach(@lines) {
 123       next unless $_;
 124       $ar->warn(" $_");
 125     }
 126     $ar->warn("[$package line $line] ", @args) ;
 127   } else {
 128     print STDERR "warn called by ", caller, " with ", @_, "\n";
 129   }
 130   return;
 131 }
 132
 133
 134 =item parse_location
 135
 136 =cut
 137
 138 sub parse_location {
 139     my $self = shift;
 140
 141     # Reconstruct the request headers
 142     $self->headers_in(Maypole::Headers->new);
 143
 144     my %headers;
 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{$_});
 149     }
 150
 151     $self->preprocess_location();
 152
 153     my $path = $self->ar->uri;
 154     my $base  = URI->new($self->config->uri_base);
 155     my $loc = $base->path;
 156
 157     {
 158         no warnings 'uninitialized';
 159         $path .= '/' if $path eq $loc;
 160         if ($loc =~ /\/$/) {
 161           $path =~ s/^($loc)?//;
 162         } else {
 163           $path =~ s/^($loc)?\///;
 164         }
 165     }
 166
 167     $self->path($path);
 168     $self->parse_path;
 169     $self->parse_args;
 170 }
 171
 172 =item parse_args
 173
 174 =cut
 175
 176 sub parse_args {
 177     my $self = shift;
 178     $self->params( { $self->_mod_perl_args( $self->ar ) } );
 179     $self->query( $self->params );
 180 }
 181
 182 =item redirect_request
 183
 184 Sets output headers to redirect based on the arguments provided
 185
 186 Accepts either a single argument of the full url to redirect to, or a hash of
 187 named parameters :
 188
 189 $r->redirect_request('http://www.example.com/path');
 190
 191 or
 192
 193 $r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');
 194
 195 The named parameters are protocol, domain, path, status and url
 196
 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.
 201
 202 =cut
 203
 204 sub redirect_request {
 205   my $r = shift;
 206   my $redirect_url = $_[0];
 207   my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : eval 'Apache::Constants::REDIRECT;';
 208   if ($_[1]) {
 209     my %args = @_;
 210     if ($args{url}) {
 211       $redirect_url = $args{url};
 212     } else {
 213       my $path = $args{path} || $r->path;
 214       my $host = $args{domain} || $r->ar->hostname;
 215       my $protocol = $args{protocol} || $r->get_protocol;
 216
 217       $redirect_url = URI->new;
 218          $redirect_url->scheme($protocol);
 219          $redirect_url->host($host);
 220          $redirect_url->path($path);
 221     }
 222     $status = $args{status} if ($args{status});
 223   }
 224
 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);
 228   return OK;
 229 }
 230
 231
 232 =item get_protocol
 233
 234 =cut
 235
 236 sub get_protocol {
 237   my $self = shift;
 238   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
 239   return $protocol;
 240 }
 241
 242 =item send_output
 243
 244 =cut
 245
 246 sub send_output {
 247     my $r = shift;
 248     $r->ar->content_type(
 249           $r->content_type =~ m/^text/
 250         ? $r->content_type . "; charset=" . $r->document_encoding
 251         : $r->content_type
 252     );
 253     $r->ar->headers_out->set(
 254         "Content-Length" => do { use bytes; length $r->output }
 255     );
 256
 257     foreach ($r->headers_out->field_names) {
 258         next if /^Content-(Type|Length)/;
 259         $r->ar->headers_out->set($_ => $r->headers_out->get($_));
 260     }
 261
 262     $MODPERL2 || $r->ar->send_http_header;
 263     $r->ar->print( $r->output );
 264 }
 265
 266 =item get_template_root
 267
 268 =cut
 269
 270 sub get_template_root {
 271     my $r = shift;
 272     $r->ar->document_root . "/" . $r->ar->location;
 273 }
 274
 275 =back
 276
 277 =cut
 278
 279 #########################################################
 280 # private / internal methods and subs
 281
 282
 283 sub _mod_perl_args {
 284     my ( $self, $apr ) = @_;
 285     my %args;
 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;
 290       }
 291     } else {
 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));
 298         } else {
 299           if ($args{$key}) {
 300             $args{$key} = [ $args{$key}, $uri->query_param($key) ];
 301           } else {
 302             my @args = $uri->query_param($key);
 303             if (scalar @args > 1) {
 304               $args{$key} = [ $uri->query_param($key) ];
 305             } else {
 306               $args{$key} = $uri->query_param($key);
 307             }
 308           }
 309         }
 310       }
 311     }
 312     return %args;
 313 }
 314
 315 sub _prepare_body {
 316     my ( $self, $r ) = @_;
 317
 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;
 323         while ( $length ) {
 324             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
 325             $length -= length($buffer);
 326             $body->add($buffer);
 327         }
 328         $self->{__http_body} = $body;
 329     }
 330     return $self->{__http_body};
 331 }
 332
 333
 334
 335 =head1 AUTHOR
 336
 337 Simon Cozens, C<simon@cpan.org>
 338
 339 =head1 CREDITS
 340
 341 Aaron Trevena
 342 Marcus Ramberg, C<marcus@thefeed.no>
 343 Sebastian Riedel, C<sri@oook.de>
 344
 345 =head1 LICENSE
 346
 347 You may distribute this code under the same terms as Perl itself.
 348
 349 =cut
 350
 351 1;