Apache::MVC - Apache front-end to Maypole

Maypole documentation Contained in the Maypole distribution.

Index

Code Index:

NAME

Top

Apache::MVC - Apache front-end to Maypole

SYNOPSIS

Top

    package BeerDB;
    use Maypole::Application;

DESCRIPTION

Top

A mod_perl platform driver for Maypole. Your application can inherit from Apache::MVC directly, but it is recommended that you use Maypole::Application.

INSTALLATION

Top

Create a driver module like the one illustrated in Maypole::Application.

Put the following in your Apache config:

    <Location /beer>
        SetHandler perl-script
        PerlHandler BeerDB
    </Location>

Copy the templates found in templates/factory into the beer/factory directory off the web root. When the designers get back to you with custom templates, they are to go in beer/custom. If you need to override templates on a database-table-by-table basis, put the new template in beer/table.

This will automatically give you add, edit, list, view and delete commands; for instance, to see a list of breweries, go to

    http://your.site/beer/brewery/list

For more information about how the system works and how to extend it, see Maypole.

Implementation

Top

This class overrides a set of methods in the base Maypole class to provide its functionality. See Maypole for these:

get_request
warn
parse_location
parse_args
redirect_request

Sets output headers to redirect based on the arguments provided

Accepts either a single argument of the full url to redirect to, or a hash of named parameters :

$r->redirect_request('http://www.example.com/path');

or

$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..');

The named parameters are protocol, domain, path, status and url

Only 1 named parameter is required but other than url, they can be combined as required and current values (from the request) will be used in place of any missing arguments. The url argument must be a full url including protocol and can only be combined with status.

get_protocol
send_output
get_template_root

AUTHOR

Top

Simon Cozens, simon@cpan.org

CREDITS

Top

Aaron Trevena Marcus Ramberg, marcus@thefeed.no Sebastian Riedel, sri@oook.de

LICENSE

Top

You may distribute this code under the same terms as Perl itself.

Maypole documentation Contained in the Maypole distribution. 
package Apache::MVC;

our $VERSION = '2.121';

use strict;
use warnings;

use URI;
use URI::QueryParam;

use base 'Maypole';
use Maypole::Headers;
use Maypole::Constants;

__PACKAGE__->mk_accessors( qw( ar ) );

our $MODPERL2;
our $modperl_version;

BEGIN {
    $MODPERL2  = ( exists $ENV{MOD_PERL_API_VERSION} and
                        $ENV{MOD_PERL_API_VERSION} >= 2 );
    if ($MODPERL2) {
     eval 'use mod_perl2; $modperl_version = $mod_perl2::VERSION;';
     if ($@) {
      $modperl_version = $Apache2::RequestRec::VERSION;
     }
     require Apache2::RequestIO;
     require Apache2::RequestRec;
     require Apache2::RequestUtil;
     eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import
     require APR::URI;
     require HTTP::Body;
    } else {
     eval ' use mod_perl; ';
     require Apache;
     require Apache::Request;
     eval 'use Apache::Constants -compile => qw/REDIRECT/;';
     $modperl_version = 1;
    }

}


sub get_request {
    my ($self, $r) = @_;
    my $request_options = $self->config->request_options || {};
    my $ar;
    if ($MODPERL2) {
      $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r;
    } else {
      if (keys %$request_options) {
	$ar = Apache::Request->new($r,%{$request_options});
      } else {
	$ar = Apache::Request->instance($r);
      }
    }
    $self->ar($ar);
}


sub warn {
  my ($self,@args) = @_;
  my ($package, $line) = (caller)[0,2];
  my $ar = $self->parent ? $self->parent->{ar} : $self->{ar};
  if ( $args[0] and ref $self ) {
    $ar->warn("[$package line $line] ", @args) ;
  } else {
    print "warn called by ", caller, " with ", @_, "\n";
  }
  return;
}



sub parse_location {
    my $self = shift;

    # Reconstruct the request headers
    $self->headers_in(Maypole::Headers->new);

    my %headers;
    if ($MODPERL2) { %headers = %{$self->ar->headers_in};
    } else { %headers = $self->ar->headers_in; }
    for (keys %headers) {
        $self->headers_in->set($_, $headers{$_});
    }

    $self->preprocess_location();

    my $path = $self->ar->uri;
    my $base  = URI->new($self->config->uri_base);
    my $loc = $base->path;

    {
        no warnings 'uninitialized';
        $path .= '/' if $path eq $loc;
	if ($loc =~ /\/$/) {
	  $path =~ s/^($loc)?//;
	} else {
	  $path =~ s/^($loc)?\///;
	}
    }

    $self->path($path);
    $self->parse_path;
    $self->parse_args;
}


sub parse_args {
    my $self = shift;
    $self->params( { $self->_mod_perl_args( $self->ar ) } );
    $self->query( $self->params );
}


sub redirect_request {
  my $r = shift;
  my $redirect_url = $_[0];
  my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : eval 'Apache::Constants::REDIRECT;';
  if ($_[1]) {
    my %args = @_;
    if ($args{url}) {
      $redirect_url = $args{url};
    } else {
      my $path = $args{path} || $r->path;
      my $host = $args{domain} || $r->ar->hostname;
      my $protocol = $args{protocol} || $r->get_protocol;

      $redirect_url = URI->new;
         $redirect_url->scheme($protocol);
         $redirect_url->host($host);
         $redirect_url->path($path);
    }
    $status = $args{status} if ($args{status});
  }

  $r->ar->status($status);
  $r->ar->headers_out->set('Location' => $redirect_url);
  $r->output('<html><head><title>redirecting...</title></head><body><h2>redirecting..</h2></body></html>') unless ($r->output);
  return OK;
}



sub get_protocol {
  my $self = shift;
  my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ;
  return $protocol;
}


sub send_output {
    my $r = shift;
    $r->ar->content_type(
          $r->content_type =~ m/^text/
        ? $r->content_type . "; charset=" . $r->document_encoding
        : $r->content_type
    );
    $r->ar->headers_out->set(
        "Content-Length" => do { use bytes; length $r->output }
    );

    foreach ($r->headers_out->field_names) {
        next if /^Content-(Type|Length)/;
        $r->ar->headers_out->set($_ => $r->headers_out->get($_));
    }

    $MODPERL2 || $r->ar->send_http_header;
    $r->ar->print( $r->output );
}


sub get_template_root {
    my $r = shift;
    $r->ar->document_root . "/" . $r->ar->location;
}


#########################################################
# private / internal methods and subs


sub _mod_perl_args {
    my ( $self, $apr ) = @_;
    my %args;
    if ($apr->isa('Apache::Request')) {
      foreach my $key ( $apr->param ) {
        my @values = $apr->param($key);
        $args{$key} = @values == 1 ? $values[0] : \@values;
      }
    } else {
      my $body = $self->_prepare_body($apr);
      %args = %{$body->param};
      my $uri = URI->new($self->ar->unparsed_uri);
      foreach my $key ($uri->query_param) {
	if (ref $args{$key}) {
	  push (@{$args{$key}}, $uri->query_param($key));
	} else {
	  if ($args{$key}) {
	    $args{$key} = [ $args{$key}, $uri->query_param($key) ];
	  } else {
	    my @args = $uri->query_param($key);
	    if (scalar @args > 1) {
	      $args{$key} = [ $uri->query_param($key) ];
	    } else {
	      $args{$key} = $uri->query_param($key);
	    }
	  }
	}
      }
    }
    return %args;
}

sub _prepare_body {
    my ( $self, $r ) = @_;

    unless ($self->{__http_body}) {
        my $content_type   = $r->headers_in->get('Content-Type');
        my $content_length = $r->headers_in->get('Content-Length');
        my $body   = HTTP::Body->new( $content_type, $content_length );
        my $length = $content_length;
        while ( $length ) {
            $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
            $length -= length($buffer);
            $body->add($buffer);
        }
	$self->{__http_body} = $body;
    }
    return $self->{__http_body};
}




1;