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     my $path = $self->ar->uri;
 105     my $loc  = $self->ar->location;
 106     {
 107         no warnings 'uninitialized';
 108         $path .= '/' if $path eq $loc;
 109         $path =~ s/^($loc)?\///;
 110     }
 111     $self->path($path);
 112
 113     $self->parse_path;
 114     $self->parse_args;
 115 }
 116
 117 =item parse_args
 118
 119 =cut
 120
 121 sub parse_args {
 122     my $self = shift;
 123     $self->params( { $self->_mod_perl_args( $self->ar ) } );
 124     $self->query( $self->params );
 125 }
 126
 127 =item redirect_request
 128
 129 =cut
 130
 131 # FIXME: use headers_in to gather host and other information?
 132 sub redirect_request
 133 {
 134   my $r = shift;
 135   my $redirect_url = $_[0];
 136   my $status = "302";
 137   if ($_[1]) {
 138     my %args = @_;
 139     if ($args{url}) {
 140       $redirect_url = $args{url};
 141     } else {
 142       my $path = $args{path} || $r->path;
 143       my $host = $args{domain} || $r->ar->hostname;
 144       my $protocol = $args{protocol} || $r->get_protocol;
 145       $redirect_url = "${protocol}://${host}/${path}";
 146     }
 147     $status = $args{status} if ($args{status});
 148   }
 149
 150   $r->headers_out->set('Status' => $status);
 151   $r->headers_out->set('Location' => $redirect_url);
 152   return OK;
 153 }
 154
 155 =item get_protocol
 156
 157 =cut
 158
 159 sub get_protocol {
 160   my $self = shift;
 161   my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
 162   return $protocol;
 163 }
 164
 165 =item send_output
 166
 167 =cut
 168
 169 sub send_output {
 170     my $r = shift;
 171     $r->ar->content_type(
 172           $r->content_type =~ m/^text/
 173         ? $r->content_type . "; charset=" . $r->document_encoding
 174         : $r->content_type
 175     );
 176     $r->ar->headers_out->set(
 177         "Content-Length" => do { use bytes; length $r->output }
 178     );
 179
 180     foreach ($r->headers_out->field_names) {
 181         next if /^Content-(Type|Length)/;
 182         $r->ar->headers_out->set($_ => $r->headers_out->get($_));
 183     }
 184
 185     APACHE2 || $r->ar->send_http_header;
 186     $r->ar->print( $r->output );
 187 }
 188
 189 =item get_template_root
 190
 191 =cut
 192
 193 sub get_template_root {
 194     my $r = shift;
 195     $r->ar->document_root . "/" . $r->ar->location;
 196 }
 197
 198 sub _mod_perl_args {
 199     my ( $self, $apr ) = @_;
 200     my %args;
 201     foreach my $key ( $apr->param ) {
 202         my @values = $apr->param($key);
 203         $args{$key} = @values == 1 ? $values[0] : \@values;
 204     }
 205     return %args;
 206 }
 207
 208 1;
 209
 210 =back
 211
 212 =head1 AUTHOR
 213
 214 Simon Cozens, C<simon@cpan.org>
 215 Marcus Ramberg, C<marcus@thefeed.no>
 216 Sebastian Riedel, C<sri@oook.de>
 217
 218 =head1 LICENSE
 219
 220 You may distribute this code under the same terms as Perl itself.
 221
 222 =cut