X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FCGI%2FMaypole.pm;h=dda15fcd7a52df6c8dabd3616b4bb22223d1e77a;hb=ac7eb8f3a1780223d5376e623ab90af3c8f83f04;hp=88abc3cebf7218ed1f8c419937834ca04c96d5bd;hpb=271fd90b8a1b9f843853601a75a1334407ff87c4;p=maypole.git diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm index 88abc3c..dda15fc 100644 --- a/lib/CGI/Maypole.pm +++ b/lib/CGI/Maypole.pm @@ -4,61 +4,12 @@ use base 'Maypole'; use strict; use warnings; use CGI::Simple; +use Maypole::Headers; +use Maypole::Constants; -our $VERSION = '2.05'; +our $VERSION = '2.11'; -sub run { - my $self = shift; - return $self->handler(); -} - -sub get_request { - shift->{cgi} = CGI::Simple->new(); -} - -sub parse_location { - my $self = shift; - $self->{path} = $self->{cgi}->url( -absolute => 1, -path_info => 1 ); - my $loc = $self->{cgi}->url( -absolute => 1 ); - no warnings 'uninitialized'; - $self->{path} .= '/' if $self->{path} eq $loc; - $self->{path} =~ s/^($loc)?\///; - $self->parse_path; - $self->parse_args; -} - -sub parse_args { - my $self = shift; - my (%vars) = $self->{cgi}->Vars; - while ( my ( $key, $value ) = each %vars ) { - my @values = split "\0", $value; - $vars{$key} = @values <= 1 ? $values[0] : \@values; - } - $self->{params} = {%vars}; - $self->{query} = {%vars}; -} - -sub send_output { - my $r = shift; - my %processed = map { "-".$_,$r->{extra_headers}{$_} } - keys %{$r->{extra_headers}}; - print $r->{cgi}->header( - -type => $r->{content_type}, - -charset => $r->{document_encoding}, - -content_length => do { use bytes; length $r->{output} }, - %processed - ? %processed - : {} - ); - print $r->{output}; -} - -sub get_template_root { - my $r = shift; - $r->{cgi}->document_root . "/" . $r->{cgi}->url( -relative => 1 ); -} - -1; +__PACKAGE__->mk_accessors( qw/cgi/ ); =head1 NAME @@ -67,16 +18,7 @@ CGI::Maypole - CGI-based front-end to Maypole =head1 SYNOPSIS package BeerDB; - use base 'CGI::Maypole'; - BeerDB->setup("dbi:mysql:beerdb"); - BeerDB->config->uri_base("http://your.site/cgi-bin/beer.cgi/"); - BeerDB->config->display_tables([qw[beer brewery pub style]]); - BeerDB->config->template_root("/var/www/beerdb/"); - # Now set up your database: - # has-a relationships - # untaint columns - - 1; + use Maypole::Application; ## example beer.cgi: @@ -88,10 +30,17 @@ CGI::Maypole - CGI-based front-end to Maypole 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. + =head1 DESCRIPTION -This is a handler for Maypole which will use the CGI instead of Apache's -C 1.x. This handler can also be used for Apache 2.0. +This is a CGI platform driver for Maypole. Your application can inherit from +CGI::Maypole directly, but it is recommended that you use +L. + +This module requires CGI::Simple which you will have to install yourself via +CPAN or manually. =head1 METHODS @@ -103,27 +52,193 @@ Call this from your CGI script to start the Maypole application. =back +=cut + +sub run +{ + my $self = shift; + return $self->handler; +} + =head1 Implementation -This class overrides a set of methods in the base Maypole class to provide it's +This class overrides a set of methods in the base Maypole class to provide it's functionality. See L for these: =over =item get_request -=item get_template_root +=cut -=item parse_args +sub get_request +{ + shift->cgi( CGI::Simple->new ); +} =item parse_location +=cut + +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; +} + +=item warn + +=cut + +sub warn { + my ($self,@args) = @_; + my ($package, $line) = (caller)[0,2]; + warn "[$package line $line] ", @args ; + return; +} + +=item parse_args + +=cut + +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 ); +} + +=item redirect_request + +=cut + +# 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; +} + +=item get_protocol + +=cut + +sub get_protocol +{ + my $self = shift; + my $protocol = ($self->cgi->https) ? 'https' : 'http'; + return $protocol; +} + =item send_output +Generates output (using C) and prints it. + +=cut + +sub send_output +{ + my $r = shift; + print $r->collect_output; +} + +=item collect_output + +Gathers headers and output together into a string and returns it. + +Splitting this code out of C supports L. + +=cut + +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; +} + +=item get_template_root + +=cut + +sub get_template_root { + my $r = shift; + $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 ); +} + +1; + + =back +=head1 DEPENDANCIES + +CGI::Simple + =head1 AUTHORS Dave Ranney C Simon Cozens C + +=cut