lib/CGI/Maypole.pm

   1 package CGI::Maypole;
   2 use base 'Maypole';
   3
   4 use strict;
   5 use warnings;
   6 use CGI::Simple;
   7 use Maypole::Headers;
   8 use Maypole::Constants;
   9
  10 our $VERSION = '2.12';
  11
  12 __PACKAGE__->mk_accessors( qw/cgi/ );
  13
  14 =head1 NAME
  15
  16 CGI::Maypole - CGI-based front-end to Maypole
  17
  18 =head1 SYNOPSIS
  19
  20      package BeerDB;
  21      use Maypole::Application;
  22
  23      ## example beer.cgi:
  24
  25      #!/usr/bin/perl -w
  26      use strict;
  27      use BeerDB;
  28      BeerDB->run();
  29
  30 Now to access the beer database, type this URL into your browser:
  31 http://your.site/cgi-bin/beer.cgi/frontpage
  32
  33 NOTE: this Maypole frontend requires additional modules that won't be installed
  34 or included with Maypole. Please see below.
  35
  36 =head1 DESCRIPTION
  37
  38 This is a CGI platform driver for Maypole. Your application can inherit from
  39 CGI::Maypole directly, but it is recommended that you use
  40 L<Maypole::Application>.
  41
  42 This module requires CGI::Simple which you will have to install yourself via
  43 CPAN or manually.
  44
  45 =head1 METHODS
  46
  47 =over
  48
  49 =item run
  50
  51 Call this from your CGI script to start the Maypole application.
  52
  53 =back
  54
  55 =cut
  56
  57 sub run
  58 {
  59     my $self = shift;
  60     return $self->handler;
  61 }
  62
  63 =head1 Implementation
  64
  65 This class overrides a set of methods in the base Maypole class to provide it's
  66 functionality. See L<Maypole> for these:
  67
  68 =over
  69
  70 =item get_request
  71
  72 =cut
  73
  74 sub get_request {
  75   my $self = shift;
  76   my $request_options = $self->config->request_options || {};
  77   $CGI::Simple::POST_MAX = $request_options->{POST_MAX} if ($request_options->{POST_MAX});
  78   $self->cgi( CGI::Simple->new );
  79 }
  80
  81 =item parse_location
  82
  83 =cut
  84
  85 sub parse_location
  86 {
  87     my $r = shift;
  88     my $cgi = $r->cgi;
  89
  90     # Reconstruct the request headers (as far as this is possible)
  91     $r->headers_in(Maypole::Headers->new);
  92     for my $http_header ($cgi->http) {
  93         (my $field_name = $http_header) =~ s/^HTTPS?_//;
  94         $r->headers_in->set($field_name => $cgi->http($http_header));
  95     }
  96
  97     $r->preprocess_location();
  98
  99     my $path = $cgi->url( -absolute => 1, -path_info => 1 );
 100     my $loc = $cgi->url( -absolute => 1 );
 101     {
 102         no warnings 'uninitialized';
 103         $path .= '/' if $path eq $loc;
 104         if ($loc =~ /\/$/) {
 105           $path =~ s/^($loc)?//;
 106         } else {
 107           $path =~ s/^($loc)?\///;
 108         }
 109     }
 110     $r->path($path);
 111
 112     $r->parse_path;
 113     $r->parse_args;
 114 }
 115
 116 =item warn
 117
 118 =cut
 119
 120 sub warn {
 121     my ($self,@args) = @_;
 122     my ($package, $line) = (caller)[0,2];
 123     warn "[$package line $line] ", @args ;
 124     return;
 125 }
 126
 127 =item parse_args
 128
 129 =cut
 130
 131 sub parse_args
 132 {
 133     my $r = shift;
 134     my (%vars) = $r->cgi->Vars;
 135     while ( my ( $key, $value ) = each %vars ) {
 136         my @values = split "\0", $value;
 137         $vars{$key} = @values <= 1 ? $values[0] : \@values;
 138     }
 139     $r->params( {%vars} );
 140     $r->query( $r->params );
 141 }
 142
 143 =item redirect_request
 144
 145 =cut
 146
 147 # FIXME: use headers_in to gather host and other information?
 148 sub redirect_request
 149 {
 150   my $r = shift;
 151   my $redirect_url = $_[0];
 152   my $status = "302";
 153   if ($_[1]) {
 154     my %args = @_;
 155     if ($args{url}) {
 156       $redirect_url = $args{url};
 157     } else {
 158       my $path = $args{path} || $r->cgi->url(-absolute => 1, -query=>1);
 159       my $host = $args{domain};
 160       ($host = $r->cgi->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
 161       my $protocol = $args{protocol} || $r->get_protocol;
 162       $redirect_url = "${protocol}://${host}/${path}";
 163     }
 164     $status = $args{status} if ($args{status});
 165   }
 166
 167   $r->headers_out->set('Status' => $status);
 168   $r->headers_out->set('Location' => $redirect_url);
 169
 170   return;
 171 }
 172
 173 =item get_protocol
 174
 175 =cut
 176
 177 sub get_protocol
 178 {
 179   my $self = shift;
 180   my $protocol = ($self->cgi->https) ? 'https' : 'http';
 181   return $protocol;
 182 }
 183
 184 =item send_output
 185
 186 Generates output (using C<collect_output>) and prints it.
 187
 188 =cut
 189
 190 sub send_output
 191 {
 192     my $r = shift;
 193     print $r->collect_output;
 194 }
 195
 196 =item collect_output
 197
 198 Gathers headers and output together into a string and returns it.
 199
 200 Splitting this code out of C<send_output> supports L<Maypole::HTTPD::Frontend>.
 201
 202 =cut
 203
 204 sub collect_output
 205 {
 206     my $r = shift;
 207
 208     # Collect HTTP headers
 209     my %headers = (
 210         -type            => $r->content_type,
 211         -charset         => $r->document_encoding,
 212         -content_length  => do { use bytes; length $r->output },
 213     );
 214     foreach ($r->headers_out->field_names) {
 215         next if /^Content-(Type|Length)/;
 216         $headers{"-$_"} = $r->headers_out->get($_);
 217     }
 218
 219     return $r->cgi->header(%headers) . $r->output;
 220 }
 221
 222 =item get_template_root
 223
 224 =cut
 225
 226 sub get_template_root {
 227     my $r = shift;
 228     $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 );
 229 }
 230
 231 1;
 232
 233
 234 =back
 235
 236 =head1 DEPENDANCIES
 237
 238 CGI::Simple
 239
 240 =head1 AUTHORS
 241
 242 Dave Ranney C<dave@sialia.com>
 243
 244 Simon Cozens C<simon@cpan.org>
 245
 246 =cut