]> git.decadent.org.uk Git - maypole.git/blob - lib/CGI/Maypole.pm
cosmetic tidy/freshen up
[maypole.git] / 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