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.10';
  11
  12 sub run {
  13     my $self = shift;
  14     return $self->handler();
  15 }
  16
  17 sub get_request {
  18     shift->{cgi} = CGI::Simple->new();
  19 }
  20
  21 sub get_protocol {
  22   my $self = shift;
  23   my $protocol = ($self->{cgi}->https()) ? 'https' : 'http';
  24   return $protocol;
  25 }
  26
  27 sub parse_location {
  28     my $self = shift;
  29     my $cgi = $self->{cgi};
  30
  31     # Reconstruct the request headers (as far as this is possible)
  32     $self->headers_in(Maypole::Headers->new);
  33     for my $http_header ($cgi->http) {
  34         (my $field_name = $http_header) =~ s/^HTTPS?_//;
  35         $self->headers_in->set($field_name => $cgi->http($http_header));
  36     }
  37
  38     $self->{path} = $cgi->url( -absolute => 1, -path_info => 1 );
  39     my $loc = $cgi->url( -absolute => 1 );
  40     no warnings 'uninitialized';
  41     $self->{path} .= '/' if $self->{path} eq $loc;
  42     $self->{path} =~ s/^($loc)?\///;
  43     $self->parse_path;
  44     $self->parse_args;
  45 }
  46
  47 sub parse_args {
  48     my $self = shift;
  49     my (%vars) = $self->{cgi}->Vars;
  50     while ( my ( $key, $value ) = each %vars ) {
  51         my @values = split "\0", $value;
  52         $vars{$key} = @values <= 1 ? $values[0] : \@values;
  53     }
  54     $self->{params} = {%vars};
  55     $self->{query}  = {%vars};
  56 }
  57
  58 # FIXME: use headers_in to gather host and other information?
  59 sub redirect_request {
  60   my $self = shift;
  61   my $redirect_url = $_[0];
  62   my $status = "302";
  63   if ($_[1]) {
  64     my %args = @_;
  65     if ($args{url}) {
  66       $redirect_url = $args{url};
  67     } else {
  68       my $path = $args{path} || $self->{cgi}->url(-absolute => 1, -query=>1);
  69       my $host = $args{domain};
  70       ($host = $self->{cgi}->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
  71       my $protocol = $args{protocol} || ($self->{cgi}->https()) ? 'https' : 'http';
  72       $redirect_url = "${protocol}://${host}/${path}";
  73     }
  74     $status = $args{status} if ($args{status});
  75   }
  76
  77   $self->headers_out->set('Status' => $status);
  78   $self->headers_out->set('Location' => $redirect_url);
  79
  80   return;
  81 }
  82
  83
  84 sub send_output {
  85     my $r = shift;
  86
  87     # Collect HTTP headers
  88     my %headers = (
  89         -type            => $r->{content_type},
  90         -charset         => $r->{document_encoding},
  91         -content_length  => do { use bytes; length $r->{output} },
  92     );
  93     foreach ($r->headers_out->field_names) {
  94         next if /^Content-(Type|Length)/;
  95         $headers{"-$_"} = $r->headers_out->get($_);
  96     }
  97
  98     print $r->{cgi}->header(%headers), $r->{output};
  99 }
 100
 101 sub get_template_root {
 102     my $r = shift;
 103     $r->{cgi}->document_root . "/" . $r->{cgi}->url( -relative => 1 );
 104 }
 105
 106 1;
 107
 108 =head1 NAME
 109
 110 CGI::Maypole - CGI-based front-end to Maypole
 111
 112 =head1 SYNOPSIS
 113
 114      package BeerDB;
 115      use base 'CGI::Maypole';
 116      BeerDB->setup("dbi:mysql:beerdb");
 117      BeerDB->config->uri_base("http://your.site/cgi-bin/beer.cgi/");
 118      BeerDB->config->display_tables([qw[beer brewery pub style]]);
 119      BeerDB->config->template_root("/var/www/beerdb/");
 120      # Now set up your database:
 121      # has-a relationships
 122      # untaint columns
 123
 124      1;
 125
 126      ## example beer.cgi:
 127
 128      #!/usr/bin/perl -w
 129      use strict;
 130      use BeerDB;
 131      BeerDB->run();
 132
 133 Now to access the beer database, type this URL into your browser:
 134 http://your.site/cgi-bin/beer.cgi/frontpage
 135
 136 NOTE: this Maypole frontend requires additional modules that won't be installed or included with Maypole. Please see below.
 137
 138 =head1 DESCRIPTION
 139
 140 This is a CGI platform driver for Maypole. Your application can inherit from
 141 CGI::Maypole directly, but it is recommended that you use
 142 L<Maypole::Application>.
 143
 144 This module requires CGI::Simple which you will have to install yourself via CPAN or manually.
 145
 146 =head1 METHODS
 147
 148 =over
 149
 150 =item run
 151
 152 Call this from your CGI script to start the Maypole application.
 153
 154 =back
 155
 156 =head1 Implementation
 157
 158 This class overrides a set of methods in the base Maypole class to provide it's
 159 functionality. See L<Maypole> for these:
 160
 161 =over
 162
 163 =item get_request
 164
 165 =item get_template_root
 166
 167 =item parse_args
 168
 169 =item parse_location
 170
 171 =item send_output
 172
 173 =back
 174
 175 =head1 DEPENDANCIES
 176
 177 CGI::Simple
 178
 179 =head1 AUTHORS
 180
 181 Dave Ranney C<dave@sialia.com>
 182
 183 Simon Cozens C<simon@cpan.org>
 184
 185 =cut