CGI::Maypole - CGI-based front-end to Maypole

Maypole documentation Contained in the Maypole distribution.

Index

Code Index:

NAME

Top

CGI::Maypole - CGI-based front-end to Maypole

SYNOPSIS

Top

     package BeerDB;
     use Maypole::Application;

     ## example beer.cgi:

     #!/usr/bin/perl -w
     use strict;
     use BeerDB;
     BeerDB->run();

Now to access the beer database, type this URL into your browser: http://your.site/cgi-bin/beer.cgi/frontpage

NOTE: this Maypole frontend requires additional modules that won't be installed or included with Maypole. Please see below.

DESCRIPTION

Top

This is a CGI platform driver for Maypole. Your application can inherit from CGI::Maypole directly, but it is recommended that you use Maypole::Application.

This module requires CGI::Simple which you will have to install yourself via CPAN or manually.

METHODS

Top

run

Call this from your CGI script to start the Maypole application.

Implementation

Top

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

get_request
parse_location
warn
parse_args
redirect_request
get_protocol
send_output

Generates output (using collect_output) and prints it.

collect_output

Gathers headers and output together into a string and returns it.

Splitting this code out of send_output supports Maypole::HTTPD::Frontend.

get_template_root

DEPENDANCIES

Top

CGI::Simple

AUTHORS

Top

Dave Ranney dave@sialia.com

Simon Cozens simon@cpan.org

Maypole documentation Contained in the Maypole distribution. 
package CGI::Maypole;
use base 'Maypole';

use strict;
use warnings;
use CGI::Simple;
use Maypole::Headers;
use Maypole::Constants;

our $VERSION = '2.13';

__PACKAGE__->mk_accessors( qw/cgi/ );


sub run  {
  my $self = shift;
  my $status = $self->handler;
  if ($status != OK) {
    print <<EOT;
Status: 500 Maypole application error
Content-Type: text/html

<title>Maypole application error</h1>
<h1>Maypole application error</h1>
EOT
  }
  return $status;
}


sub get_request {
  my $self = shift;
  my $request_options = $self->config->request_options || {};
  $CGI::Simple::POST_MAX = $request_options->{POST_MAX} if ($request_options->{POST_MAX});
  $self->cgi( CGI::Simple->new );
}


sub parse_location 
{
    my $r = shift;
    my $cgi = $r->cgi;

    # Reconstruct the request headers (as far as this is possible)
    $r->headers_in(Maypole::Headers->new);
    for my $http_header ($cgi->http) {
        (my $field_name = $http_header) =~ s/^HTTPS?_//;
        $r->headers_in->set($field_name => $cgi->http($http_header));
    }

    $r->preprocess_location();

    my $path = $cgi->url( -absolute => 1, -path_info => 1 );
    my $loc = $cgi->url( -absolute => 1 );
    {
        no warnings 'uninitialized';
        $path .= '/' if $path eq $loc;
	if ($loc =~ /\/$/) {
	  $path =~ s/^($loc)?//;
	} else {
	  $path =~ s/^($loc)?\///;
	}
    }
    $r->path($path);
    
    $r->parse_path;
    $r->parse_args;
}


sub warn {
    my ($self,@args) = @_;
    my ($package, $line) = (caller)[0,2];
    warn "[$package line $line] ", @args ;
    return;
}


sub parse_args 
{
    my $r = shift;
    my (%vars) = $r->cgi->Vars;
    while ( my ( $key, $value ) = each %vars ) {
        my @values = split "\0", $value;
        $vars{$key} = @values <= 1 ? $values[0] : \@values;
    }
    $r->params( {%vars} );
    $r->query( $r->params );
}


# FIXME: use headers_in to gather host and other information?
sub redirect_request 
{
  my $r = shift;
  my $redirect_url = $_[0];
  my $status = "302";
  if ($_[1]) {
    my %args = @_;
    if ($args{url}) {
      $redirect_url = $args{url};
    } else {
      my $path = $args{path} || $r->cgi->url(-absolute => 1, -query=>1);
      my $host = $args{domain};
      ($host = $r->cgi->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
      my $protocol = $args{protocol} || $r->get_protocol;
      $redirect_url = "${protocol}://${host}/${path}";
    }
    $status = $args{status} if ($args{status});
  }

  $r->headers_out->set('Status' => $status);
  $r->headers_out->set('Location' => $redirect_url);

  return;
}


sub get_protocol 
{
  my $self = shift;
  my $protocol = ($self->cgi->https) ? 'https' : 'http';
  return $protocol;
}


sub send_output 
{
    my $r = shift;
    print $r->collect_output;
}


sub collect_output
{
    my $r = shift;
    
    # Collect HTTP headers
    my %headers = (
        -type            => $r->content_type,
        -charset         => $r->document_encoding,
        -content_length  => do { use bytes; length $r->output },
    );
    foreach ($r->headers_out->field_names) {
        next if /^Content-(Type|Length)/;
        $headers{"-$_"} = $r->headers_out->get($_);
    }

    return $r->cgi->header(%headers) . $r->output;
}


sub get_template_root {
    my $r = shift;
    $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 );
}

1;