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 parse_location
  90
  91 =cut
  92
  93 sub parse_location {
  94     my $self = shift;
  95
  96     # Reconstruct the request headers
  97     $self->headers_in(Maypole::Headers->new);
  98     my %headers;
  99     if (APACHE2) { %headers = %{$self->ar->headers_in};
 100     } else { %headers = $self->ar->headers_in; }
 101     for (keys %headers) {
 102         $self->headers_in->set($_, $headers{$_});
 103     }
 104
 105     my $path = $self->ar->uri;
 106     my $loc  = $self->ar->location;
 107     {
 108         no warnings 'uninitialized';
 109         $path .= '/' if $path eq $loc;
 110         $path =~ s/^($loc)?\///;
 111     }
 112     $self->path($path);
 113
 114     $self->parse_path;
 115     $self->parse_args;
 116 }
 117
 118 =item parse_args
 119
 120 =cut
 121
 122 sub parse_args {
 123     my $self = shift;
 124     $self->params( { $self->_mod_perl_args( $self->ar ) } );
 125     $self->query( $self->params );
 126 }
 127
 128 =item redirect_request
 129
 130 =cut
 131
 132 # FIXME: use headers_in to gather host and other information?
 133 sub redirect_request
 134 {
 135   my $r = shift;
 136   my $redirect_url = $_[0];
 137   my $status = "302";
 138   if ($_[1]) {
 139     my %args = @_;
 140     if ($args{url}) {
 141       $redirect_url = $args{url};
 142     } else {
 143       my $path = $args{path} || $r->path;
 144       my $host = $args{domain} || $r->ar->hostname;
 145       my $protocol = $args{protocol} || $r->get_protocol;
 146       $redirect_url = "${protocol}://${host}/${path}";
 147     }
 148     $status = $args{status} if ($args{status});
 149   }
 150
 151   $r->headers_out->set('Status' => $status);
 152   $r->headers_out->set('Location' => $redirect_url);
 153   return OK;
 154 }
 155
 156 =item get_protocol
 157
 158 =cut
 159
 160 sub get_protocol {
 161   my $self = shift;
 162   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
 163   return $protocol;
 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