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