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