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.13';
  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   my $self = shift;
  59   my $status = $self->handler;
  60   if ($status != OK) {
  61     print <<EOT;
  62 Status: 500 Maypole application error
  63 Content-Type: text/html
  64
  65 <title>Maypole application error</h1>
  66 <h1>Maypole application error</h1>
  67 EOT
  68   }
  69   return $status;
  70 }
  71
  72 =head1 Implementation
  73
  74 This class overrides a set of methods in the base Maypole class to provide it's
  75 functionality. See L<Maypole> for these:
  76
  77 =over
  78
  79 =item get_request
  80
  81 =cut
  82
  83 sub get_request {
  84   my $self = shift;
  85   my $request_options = $self->config->request_options || {};
  86   $CGI::Simple::POST_MAX = $request_options->{POST_MAX} if ($request_options->{POST_MAX});
  87   $self->cgi( CGI::Simple->new );
  88 }
  89
  90 =item parse_location
  91
  92 =cut
  93
  94 sub parse_location
  95 {
  96     my $r = shift;
  97     my $cgi = $r->cgi;
  98
  99     # Reconstruct the request headers (as far as this is possible)
 100     $r->headers_in(Maypole::Headers->new);
 101     for my $http_header ($cgi->http) {
 102         (my $field_name = $http_header) =~ s/^HTTPS?_//;
 103         $r->headers_in->set($field_name => $cgi->http($http_header));
 104     }
 105
 106     $r->preprocess_location();
 107
 108     my $path = $cgi->url( -absolute => 1, -path_info => 1 );
 109     my $loc = $cgi->url( -absolute => 1 );
 110     {
 111         no warnings 'uninitialized';
 112         $path .= '/' if $path eq $loc;
 113         if ($loc =~ /\/$/) {
 114           $path =~ s/^($loc)?//;
 115         } else {
 116           $path =~ s/^($loc)?\///;
 117         }
 118     }
 119     $r->path($path);
 120
 121     $r->parse_path;
 122     $r->parse_args;
 123 }
 124
 125 =item warn
 126
 127 =cut
 128
 129 sub warn {
 130     my ($self,@args) = @_;
 131     my ($package, $line) = (caller)[0,2];
 132     warn "[$package line $line] ", @args ;
 133     return;
 134 }
 135
 136 =item parse_args
 137
 138 =cut
 139
 140 sub parse_args
 141 {
 142     my $r = shift;
 143     my (%vars) = $r->cgi->Vars;
 144     while ( my ( $key, $value ) = each %vars ) {
 145         my @values = split "\0", $value;
 146         $vars{$key} = @values <= 1 ? $values[0] : \@values;
 147     }
 148     $r->params( {%vars} );
 149     $r->query( $r->params );
 150 }
 151
 152 =item redirect_request
 153
 154 =cut
 155
 156 # FIXME: use headers_in to gather host and other information?
 157 sub redirect_request
 158 {
 159   my $r = shift;
 160   my $redirect_url = $_[0];
 161   my $status = "302";
 162   if ($_[1]) {
 163     my %args = @_;
 164     if ($args{url}) {
 165       $redirect_url = $args{url};
 166     } else {
 167       my $path = $args{path} || $r->cgi->url(-absolute => 1, -query=>1);
 168       my $host = $args{domain};
 169       ($host = $r->cgi->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
 170       my $protocol = $args{protocol} || $r->get_protocol;
 171       $redirect_url = "${protocol}://${host}/${path}";
 172     }
 173     $status = $args{status} if ($args{status});
 174   }
 175
 176   $r->headers_out->set('Status' => $status);
 177   $r->headers_out->set('Location' => $redirect_url);
 178
 179   return;
 180 }
 181
 182 =item get_protocol
 183
 184 =cut
 185
 186 sub get_protocol
 187 {
 188   my $self = shift;
 189   my $protocol = ($self->cgi->https) ? 'https' : 'http';
 190   return $protocol;
 191 }
 192
 193 =item send_output
 194
 195 Generates output (using C<collect_output>) and prints it.
 196
 197 =cut
 198
 199 sub send_output
 200 {
 201     my $r = shift;
 202     print $r->collect_output;
 203 }
 204
 205 =item collect_output
 206
 207 Gathers headers and output together into a string and returns it.
 208
 209 Splitting this code out of C<send_output> supports L<Maypole::HTTPD::Frontend>.
 210
 211 =cut
 212
 213 sub collect_output
 214 {
 215     my $r = shift;
 216
 217     # Collect HTTP headers
 218     my %headers = (
 219         -type            => $r->content_type,
 220         -charset         => $r->document_encoding,
 221         -content_length  => do { use bytes; length $r->output },
 222     );
 223     foreach ($r->headers_out->field_names) {
 224         next if /^Content-(Type|Length)/;
 225         $headers{"-$_"} = $r->headers_out->get($_);
 226     }
 227
 228     return $r->cgi->header(%headers) . $r->output;
 229 }
 230
 231 =item get_template_root
 232
 233 =cut
 234
 235 sub get_template_root {
 236     my $r = shift;
 237     $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 );
 238 }
 239
 240 1;
 241
 242
 243 =back
 244
 245 =head1 DEPENDANCIES
 246
 247 CGI::Simple
 248
 249 =head1 AUTHORS
 250
 251 Dave Ranney C<dave@sialia.com>
 252
 253 Simon Cozens C<simon@cpan.org>
 254
 255 =cut