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 {
 190   my $r = shift;
 191   my $redirect_url = $_[0];
 192   my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' :
 193           eval 'Apache::Constants::REDIRECT;'; # why have to eval this?
 194   if ($_[1]) {
 195     my %args = @_;
 196     if ($args{url}) {
 197       $redirect_url = $args{url};
 198     } else {
 199       my $path = $args{path} || $r->path;
 200       my $host = $args{domain} || $r->ar->hostname;
 201       my $protocol = $args{protocol} || $r->get_protocol;
 202       $redirect_url = "${protocol}://${host}/${path}";
 203     }
 204     $status = $args{status} if ($args{status});
 205   }
 206
 207   $r->ar->status($status);
 208   $r->ar->headers_out->set('Location' => $redirect_url);
 209   return OK;
 210 }
 211
 212 =item get_protocol
 213
 214 =cut
 215
 216 sub get_protocol {
 217   my $self = shift;
 218   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
 219   return $protocol;
 220 }
 221
 222 =item send_output
 223
 224 =cut
 225
 226 sub send_output {
 227     my $r = shift;
 228     $r->ar->content_type(
 229           $r->content_type =~ m/^text/
 230         ? $r->content_type . "; charset=" . $r->document_encoding
 231         : $r->content_type
 232     );
 233     $r->ar->headers_out->set(
 234         "Content-Length" => do { use bytes; length $r->output }
 235     );
 236
 237     foreach ($r->headers_out->field_names) {
 238         next if /^Content-(Type|Length)/;
 239         $r->ar->headers_out->set($_ => $r->headers_out->get($_));
 240     }
 241
 242     $MODPERL2 || $r->ar->send_http_header;
 243     $r->ar->print( $r->output );
 244 }
 245
 246 =item get_template_root
 247
 248 =cut
 249
 250 sub get_template_root {
 251     my $r = shift;
 252     $r->ar->document_root . "/" . $r->ar->location;
 253 }
 254
 255 =back
 256
 257 =cut
 258
 259 #########################################################
 260 # private / internal methods and subs
 261
 262
 263 sub _mod_perl_args {
 264     my ( $self, $apr ) = @_;
 265     my %args;
 266     if ($apr->isa('Apache::Request')) {
 267       foreach my $key ( $apr->param ) {
 268         my @values = $apr->param($key);
 269         $args{$key} = @values == 1 ? $values[0] : \@values;
 270       }
 271     } else {
 272       my $body = $self->_prepare_body($apr);
 273       %args = %{$body->param};
 274       my $uri = URI->new($self->ar->unparsed_uri);
 275       foreach my $key ($uri->query_param) {
 276         if (ref $args{$key}) {
 277           push (@{$args{$key}}, $uri->query_param($key));
 278         } else {
 279           if ($args{$key}) {
 280             $args{$key} = [ $args{$key}, $uri->query_param($key) ];
 281           } else {
 282             my @args = $uri->query_param($key);
 283             if (scalar @args > 1) {
 284               $args{$key} = [ $uri->query_param($key) ];
 285             } else {
 286               $args{$key} = $uri->query_param($key);
 287             }
 288           }
 289         }
 290       }
 291     }
 292     return %args;
 293 }
 294
 295 sub _prepare_body {
 296     my ( $self, $r ) = @_;
 297
 298     unless ($self->{__http_body}) {
 299         my $content_type   = $r->headers_in->get('Content-Type');
 300         my $content_length = $r->headers_in->get('Content-Length');
 301         my $body   = HTTP::Body->new( $content_type, $content_length );
 302         my $length = $content_length;
 303         while ( $length ) {
 304             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
 305             $length -= length($buffer);
 306             $body->add($buffer);
 307         }
 308         $self->{__http_body} = $body;
 309     }
 310     return $self->{__http_body};
 311 }
 312
 313
 314
 315 =head1 AUTHOR
 316
 317 Simon Cozens, C<simon@cpan.org>
 318
 319 =head1 CREDITS
 320
 321 Aaron Trevena
 322 Marcus Ramberg, C<marcus@thefeed.no>
 323 Sebastian Riedel, C<sri@oook.de>
 324
 325 =head1 LICENSE
 326
 327 You may distribute this code under the same terms as Perl itself.
 328
 329 =cut
 330
 331 1;