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