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