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