use Maypole::Headers;
use Maypole::Constants;
-our $VERSION = '2.10';
+our $VERSION = '2.11';
-sub run {
+__PACKAGE__->mk_accessors( qw/cgi/ );
+
+=head1 NAME
+
+CGI::Maypole - CGI-based front-end to Maypole
+
+=head1 SYNOPSIS
+
+ 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.
+
+=head1 DESCRIPTION
+
+This is a CGI platform driver for Maypole. Your application can inherit from
+CGI::Maypole directly, but it is recommended that you use
+L<Maypole::Application>.
+
+This module requires CGI::Simple which you will have to install yourself via
+CPAN or manually.
+
+=head1 METHODS
+
+=over
+
+=item run
+
+Call this from your CGI script to start the Maypole application.
+
+=back
+
+=cut
+
+sub run
+{
my $self = shift;
- return $self->handler();
+ return $self->handler;
}
-sub get_request {
- shift->{cgi} = CGI::Simple->new();
-}
+=head1 Implementation
-sub get_protocol {
- my $self = shift;
- my $protocol = ($self->{cgi}->https()) ? 'https' : 'http';
- return $protocol;
+This class overrides a set of methods in the base Maypole class to provide it's
+functionality. See L<Maypole> for these:
+
+=over
+
+=item get_request
+
+=cut
+
+sub get_request
+{
+ shift->cgi( CGI::Simple->new );
}
-sub parse_location {
- my $self = shift;
- my $cgi = $self->{cgi};
+=item parse_location
+
+=cut
+
+sub parse_location
+{
+ my $r = shift;
+ my $cgi = $r->cgi;
# Reconstruct the request headers (as far as this is possible)
- $self->headers_in(Maypole::Headers->new);
+ $r->headers_in(Maypole::Headers->new);
for my $http_header ($cgi->http) {
(my $field_name = $http_header) =~ s/^HTTPS?_//;
- $self->headers_in->set($field_name => $cgi->http($http_header));
+ $r->headers_in->set($field_name => $cgi->http($http_header));
}
- $self->{path} = $cgi->url( -absolute => 1, -path_info => 1 );
+ my $path = $cgi->url( -absolute => 1, -path_info => 1 );
my $loc = $cgi->url( -absolute => 1 );
- no warnings 'uninitialized';
- $self->{path} .= '/' if $self->{path} eq $loc;
- $self->{path} =~ s/^($loc)?\///;
- $self->parse_path;
- $self->parse_args;
+ {
+ 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 parse_args {
- my $self = shift;
- my (%vars) = $self->{cgi}->Vars;
+=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;
}
- $self->{params} = {%vars};
- $self->{query} = {%vars};
+ $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 $self = shift;
+sub redirect_request
+{
+ my $r = shift;
my $redirect_url = $_[0];
my $status = "302";
if ($_[1]) {
if ($args{url}) {
$redirect_url = $args{url};
} else {
- my $path = $args{path} || $self->{cgi}->url(-absolute => 1, -query=>1);
+ my $path = $args{path} || $r->cgi->url(-absolute => 1, -query=>1);
my $host = $args{domain};
- ($host = $self->{cgi}->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
- my $protocol = $args{protocol} || ($self->{cgi}->https()) ? 'https' : 'http';
+ ($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});
}
- $self->headers_out->set('Status' => $status);
- $self->headers_out->set('Location' => $redirect_url);
+ $r->headers_out->set('Status' => $status);
+ $r->headers_out->set('Location' => $redirect_url);
return;
}
+=item get_protocol
-sub send_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($_);
- }
-
- print $r->{cgi}->header(%headers), $r->{output};
-}
+=cut
-sub get_template_root {
- my $r = shift;
- $r->{cgi}->document_root . "/" . $r->{cgi}->url( -relative => 1 );
+sub get_protocol
+{
+ my $self = shift;
+ my $protocol = ($self->cgi->https) ? 'https' : 'http';
+ return $protocol;
}
-1;
-
-=head1 NAME
-
-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;
-
- ## 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.
-
-=head1 DESCRIPTION
-
-This is a CGI platform driver for Maypole. Your application can inherit from
-CGI::Maypole directly, but it is recommended that you use
-L<Maypole::Application>.
-
-This module requires CGI::Simple which you will have to install yourself via CPAN or manually.
+=item send_output
-=head1 METHODS
+Generates output (using C<collect_output>) and prints it.
-=over
+=cut
-=item run
+sub send_output
+{
+ my $r = shift;
+ print $r->collect_output;
+}
-Call this from your CGI script to start the Maypole application.
+=item collect_output
-=back
+Gathers headers and output together into a string and returns it.
-=head1 Implementation
+Splitting this code out of C<send_output> supports L<Maypole::HTTPD::Frontend>.
-This class overrides a set of methods in the base Maypole class to provide it's
-functionality. See L<Maypole> for these:
+=cut
-=over
+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($_);
+ }
-=item get_request
+ return $r->cgi->header(%headers) . $r->output;
+}
=item get_template_root
-=item get_protocol
-
-=item parse_args
-
-=item parse_location
+=cut
-=item send_output
+sub get_template_root {
+ my $r = shift;
+ $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 );
+}
-=item redirect_request
+1;
=back
projects / maypole.git / blobdiff