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
  11 __PACKAGE__->mk_accessors( qw( ar ) );
  12
  13 BEGIN {
  14     my $version;
  15     eval 'use mod_perl2; $version = $mod_perl2::VERSION; ';
  16     if ($@) {
  17         warn "no mod_perl 2.x using mod_perl 1.x\n";
  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
  34 sub get_request {
  35     my ( $self, $r ) = @_;
  36     $self->{ar} = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->new($r);
  37 }
  38
  39 sub parse_location {
  40     my $self = shift;
  41
  42     # Reconstruct the request headers
  43     $self->headers_in(Maypole::Headers->new);
  44     my %headers;
  45     if (APACHE2) { %headers = %{$self->{ar}->headers_in};
  46     } else { %headers = $self->{ar}->headers_in; }
  47     for (keys %headers) {
  48         $self->headers_in->set($_, $headers{$_});
  49     }
  50
  51     $self->{path} = $self->{ar}->uri;
  52     my $loc = $self->{ar}->location;
  53     no warnings 'uninitialized';
  54     $self->{path} .= '/' if $self->{path} eq $loc;
  55     $self->{path} =~ s/^($loc)?\///;
  56     $self->parse_path;
  57     $self->parse_args;
  58 }
  59
  60 sub parse_args {
  61     my $self = shift;
  62     $self->{params} = { $self->_mod_perl_args( $self->{ar} ) };
  63     $self->{query}  = { $self->_mod_perl_args( $self->{ar} ) };
  64 }
  65
  66 sub send_output {
  67     my $r = shift;
  68     $r->{ar}->content_type(
  69           $r->{content_type} =~ m/^text/
  70         ? $r->{content_type} . "; charset=" . $r->{document_encoding}
  71         : $r->{content_type}
  72     );
  73     $r->{ar}->headers_out->set(
  74         "Content-Length" => do { use bytes; length $r->{output} }
  75     );
  76
  77     foreach ($r->headers_out->field_names) {
  78         next if /^Content-(Type|Length)/;
  79         $r->{ar}->headers_out->set($_ => $r->headers_out->get($_));
  80     }
  81
  82     APACHE2 || $r->{ar}->send_http_header;
  83     $r->{ar}->print( $r->{output} );
  84 }
  85
  86 sub get_template_root {
  87     my $r = shift;
  88     $r->{ar}->document_root . "/" . $r->{ar}->location;
  89 }
  90
  91 sub _mod_perl_args {
  92     my ( $self, $apr ) = @_;
  93     my %args;
  94     foreach my $key ( $apr->param ) {
  95         my @values = $apr->param($key);
  96         $args{$key} = @values == 1 ? $values[0] : \@values;
  97     }
  98     return %args;
  99 }
 100
 101 1;
 102
 103 =head1 NAME
 104
 105 Apache::MVC - Apache front-end to Maypole
 106
 107 =head1 SYNOPSIS
 108
 109     package BeerDB;
 110     use base 'Apache::MVC';
 111     BeerDB->setup("dbi:mysql:beerdb");
 112     BeerDB->config->uri_base("http://your.site/");
 113     BeerDB->config->display_tables([qw[beer brewery pub style]]);
 114     # Now set up your database:
 115     # has-a relationships
 116     # untaint columns
 117
 118     1;
 119
 120 =head1 DESCRIPTION
 121
 122 A mod_perl platform driver for Maypole. Your application can inherit from
 123 Apache::MVC directly, but it is recommended that you use
 124 L<Maypole::Application>.
 125
 126 =head1 INSTALLATION
 127
 128 Create a driver module like the one above.
 129
 130 Put the following in your Apache config:
 131
 132     <Location /beer>
 133         SetHandler perl-script
 134         PerlHandler BeerDB
 135     </Location>
 136
 137 Copy the templates found in F<templates/factory> into the
 138 F<beer/factory> directory off the web root. When the designers get
 139 back to you with custom templates, they are to go in
 140 F<beer/custom>. If you need to do override templates on a
 141 database-table-by-table basis, put the new template in
 142 F<beer/I<table>>.
 143
 144 This will automatically give you C<add>, C<edit>, C<list>, C<view> and
 145 C<delete> commands; for instance, a list of breweries, go to
 146
 147     http://your.site/beer/brewery/list
 148
 149 For more information about how the system works and how to extend it,
 150 see L<Maypole>.
 151
 152 =head1 Implementation
 153
 154 This class overrides a set of methods in the base Maypole class to provide it's
 155 functionality. See L<Maypole> for these:
 156
 157 =over
 158
 159 =item get_request
 160
 161 =item get_template_root
 162
 163 =item parse_args
 164
 165 =item parse_location
 166
 167 =item send_output
 168
 169 =back
 170
 171 =head1 AUTHOR
 172
 173 Simon Cozens, C<simon@cpan.org>
 174 Marcus Ramberg, C<marcus@thefeed.no>
 175 Screwed up by Sebastian Riedel, C<sri@oook.de>
 176
 177 =head1 LICENSE
 178
 179 You may distribute this code under the same terms as Perl itself.
 180
 181 =cut