lib/Apache/MVC.pm

   1 package Apache::MVC;
   2
   3 our $VERSION = '2.10';
   4
   5 use strict;
   6 use warnings;
   7
   8 use base 'Maypole';
   9 use Maypole::Headers;
  10 use Maypole::Constants;
  11
  12 __PACKAGE__->mk_accessors( qw( ar ) );
  13
  14 BEGIN {
  15     my $version;
  16     eval 'use mod_perl2; $version = $mod_perl2::VERSION; ';
  17     if ($@) {
  18         use mod_perl;
  19         $version = 0;
  20         require Apache;
  21         require Apache::Request;
  22     } else {
  23         require Apache2::RequestIO;
  24         require Apache2::RequestRec;
  25         require Apache2::RequestUtil;
  26         require APR::URI;
  27         require Apache2::Request;
  28     }
  29
  30     use constant APACHE2 => $version;
  31 }
  32
  33 =head1 NAME
  34
  35 Apache::MVC - Apache front-end to Maypole
  36
  37 =head1 SYNOPSIS
  38
  39     package BeerDB;
  40     use Maypole::Application;
  41
  42 =head1 DESCRIPTION
  43
  44 A mod_perl platform driver for Maypole. Your application can inherit from
  45 Apache::MVC directly, but it is recommended that you use
  46 L<Maypole::Application>.
  47
  48 =head1 INSTALLATION
  49
  50 Create a driver module like the one illustrated in L<Maypole::Application>.
  51
  52 Put the following in your Apache config:
  53
  54     <Location /beer>
  55         SetHandler perl-script
  56         PerlHandler BeerDB
  57     </Location>
  58
  59 Copy the templates found in F<templates/factory> into the F<beer/factory>
  60 directory off the web root. When the designers get back to you with custom
  61 templates, they are to go in F<beer/custom>. If you need to override templates
  62 on a database-table-by-table basis, put the new template in F<beer/I<table>>.
  63
  64 This will automatically give you C<add>, C<edit>, C<list>, C<view> and C<delete>
  65 commands; for instance, to see a list of breweries, go to
  66
  67     http://your.site/beer/brewery/list
  68
  69 For more information about how the system works and how to extend it,
  70 see L<Maypole>.
  71
  72 =head1 Implementation
  73
  74 This class overrides a set of methods in the base Maypole class to provide its
  75 functionality. See L<Maypole> for these:
  76
  77 =over
  78
  79 =item get_request
  80
  81 =cut
  82
  83 sub get_request {
  84     my ($self, $r) = @_;
  85     my $ar = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->new($r);
  86     $self->ar($ar);
  87 }
  88
  89 =item get_protocol
  90
  91 =cut
  92
  93 sub get_protocol {
  94   my $self = shift;
  95   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
  96   return $protocol;
  97 }
  98
  99 =item parse_location
 100
 101 =cut
 102
 103 sub parse_location {
 104     my $self = shift;
 105
 106     # Reconstruct the request headers
 107     $self->headers_in(Maypole::Headers->new);
 108     my %headers;
 109     if (APACHE2) { %headers = %{$self->ar->headers_in};
 110     } else { %headers = $self->ar->headers_in; }
 111     for (keys %headers) {
 112         $self->headers_in->set($_, $headers{$_});
 113     }
 114
 115     my $path = $self->ar->uri;
 116     my $loc  = $self->ar->location;
 117     {
 118         no warnings 'uninitialized';
 119         $path .= '/' if $path eq $loc;
 120         $path =~ s/^($loc)?\///;
 121     }
 122     $self->path($path);
 123
 124     $self->parse_path;
 125     $self->parse_args;
 126 }
 127
 128 =item parse_args
 129
 130 =cut
 131
 132 sub parse_args {
 133     my $self = shift;
 134     $self->params( { $self->_mod_perl_args( $self->ar ) } );
 135     $self->query( $self->params );
 136 }
 137
 138 =item redirect_request
 139
 140 =cut
 141
 142 # FIXME: use headers_in to gather host and other information?
 143 sub redirect_request {
 144   my $self = shift;
 145   my $redirect_url = $_[0];
 146   my $status = "302";
 147   if ($_[1]) {
 148     my %args = @_;
 149     if ($args{url}) {
 150       $redirect_url = $args{url};
 151     } else {
 152       my $path = $args{path} || $self->path;
 153       my $host = $args{domain} || $self->ar->hostname;
 154       my $protocol = $args{protocol} ||
 155         ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
 156       $redirect_url = "${protocol}://${host}/${path}";
 157     }
 158     $status = $args{status} if ($args{status});
 159   }
 160
 161   $self->headers_out->set('Status' => $status);
 162   $self->headers_out->set('Location' => $redirect_url);
 163   return OK;
 164 }
 165
 166 =item send_output
 167
 168 =cut
 169
 170 sub send_output {
 171     my $r = shift;
 172     $r->ar->content_type(
 173           $r->content_type =~ m/^text/
 174         ? $r->content_type . "; charset=" . $r->document_encoding
 175         : $r->content_type
 176     );
 177     $r->ar->headers_out->set(
 178         "Content-Length" => do { use bytes; length $r->output }
 179     );
 180
 181     foreach ($r->headers_out->field_names) {
 182         next if /^Content-(Type|Length)/;
 183         $r->ar->headers_out->set($_ => $r->headers_out->get($_));
 184     }
 185
 186     APACHE2 || $r->ar->send_http_header;
 187     $r->ar->print( $r->output );
 188 }
 189
 190 =item get_template_root
 191
 192 =cut
 193
 194 sub get_template_root {
 195     my $r = shift;
 196     $r->ar->document_root . "/" . $r->ar->location;
 197 }
 198
 199 sub _mod_perl_args {
 200     my ( $self, $apr ) = @_;
 201     my %args;
 202     foreach my $key ( $apr->param ) {
 203         my @values = $apr->param($key);
 204         $args{$key} = @values == 1 ? $values[0] : \@values;
 205     }
 206     return %args;
 207 }
 208
 209 1;
 210
 211 =back
 212
 213 =head1 AUTHOR
 214
 215 Simon Cozens, C<simon@cpan.org>
 216 Marcus Ramberg, C<marcus@thefeed.no>
 217 Sebastian Riedel, C<sri@oook.de>
 218
 219 =head1 LICENSE
 220
 221 You may distribute this code under the same terms as Perl itself.
 222
 223 =cut