File Coverage

blib/lib/Catalyst/Engine/CGI.pm
Criterion Covered Total %
statement 78 85 91.8
branch 25 36 69.4
condition 9 20 45.0
subroutine 12 13 92.3
pod 9 9 100.0
total 133 163 81.6


line stmt bran cond sub pod time code
1             package Catalyst::Engine::CGI;
2              
3 48     48   679 use strict;
  48         570  
  48         766  
4 48     48   1021 use base 'Catalyst::Engine';
  48         621  
  48         774  
5 48     48   1054 use NEXT;
  48         452  
  48         926  
6 48     48   778 use URI;
  48         489  
  48         2496  
7              
8             my $uri_proto=URI->new();
9             __PACKAGE__->mk_accessors('env');
10              
11             =head1 NAME
12            
13             Catalyst::Engine::CGI - The CGI Engine
14            
15             =head1 SYNOPSIS
16            
17             A script using the Catalyst::Engine::CGI module might look like:
18            
19             #!/usr/bin/perl -w
20            
21             use strict;
22             use lib '/path/to/MyApp/lib';
23             use MyApp;
24            
25             MyApp->run;
26            
27             The application module (C<MyApp>) would use C<Catalyst>, which loads the
28             appropriate engine module.
29            
30             =head1 DESCRIPTION
31            
32             This is the Catalyst engine specialized for the CGI environment.
33            
34             =head1 OVERLOADED METHODS
35            
36             This class overloads some methods from C<Catalyst::Engine>.
37            
38             =head2 $self->finalize_headers($c)
39            
40             =cut
41              
42             sub finalize_headers {
43 816     816 1 35487     my ( $self, $c ) = @_;
44              
45 816         10201     $c->response->header( Status => $c->response->status );
46              
47 816         125952     print $c->response->headers->as_string("\015\012") . "\015\012";
48             }
49              
50             =head2 $self->prepare_connection($c)
51            
52             =cut
53              
54             sub prepare_connection {
55 818     818 1 30150     my ( $self, $c ) = @_;
56 818   50     24144     local (*ENV) = $self->env || \%ENV;
57              
58 818         27768     $c->request->address( $ENV{REMOTE_ADDR} );
59              
60               PROXY_CHECK:
61                 {
62 818 50       9023         unless ( $c->config->{using_frontend_proxy} ) {
  818         14684  
63 818 50       13073             last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
64 818 100       19507             last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
65                     }
66 817 100       11828         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
67              
68             # If we are running as a backend server, the user will always appear
69             # as 127.0.0.1. Select the most recent upstream IP (last in the list)
70 1         24         my ($ip) = $ENV{HTTP_X_FORWARDED_FOR} =~ /([^,\s]+)$/;
71 1         13         $c->request->address($ip);
72                 }
73              
74 818         14153     $c->request->hostname( $ENV{REMOTE_HOST} );
75 818         10588     $c->request->protocol( $ENV{SERVER_PROTOCOL} );
76 818         11405     $c->request->user( $ENV{REMOTE_USER} );
77 818         15606     $c->request->method( $ENV{REQUEST_METHOD} );
78              
79 818 50 33     71231     if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) {
80 0         0         $c->request->secure(1);
81                 }
82              
83 818 50       15733     if ( $ENV{SERVER_PORT} == 443 ) {
84 0         0         $c->request->secure(1);
85                 }
86             }
87              
88             =head2 $self->prepare_headers($c)
89            
90             =cut
91              
92             sub prepare_headers {
93 818     818 1 23781     my ( $self, $c ) = @_;
94 818   50     26859     local (*ENV) = $self->env || \%ENV;
95              
96             # Read headers from %ENV
97 818         95239     foreach my $header ( keys %ENV ) {
98 65473 100       2515340         next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i;
99 1669         201265         ( my $field = $header ) =~ s/^HTTPS?_//;
100 1669         28523         $c->req->headers->header( $field => $ENV{$header} );
101                 }
102             }
103              
104             =head2 $self->prepare_path($c)
105            
106             =cut
107              
108             sub prepare_path {
109 818     818 1 33950     my ( $self, $c ) = @_;
110 818   50     13578     local (*ENV) = $self->env || \%ENV;
111              
112 818 50       31875     my $scheme = $c->request->secure ? 'https' : 'http';
113 818   33     13706     my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
114 818   50     11328     my $port = $ENV{SERVER_PORT} || 80;
115 818         8384     my $base_path;
116 818 50       10411     if ( exists $ENV{REDIRECT_URL} ) {
117 0         0         $base_path = $ENV{REDIRECT_URL};
118 0         0         $base_path =~ s/$ENV{PATH_INFO}$//;
119                 }
120                 else {
121 818   50     17934         $base_path = $ENV{SCRIPT_NAME} || '/';
122                 }
123              
124             # If we are running as a backend proxy, get the true hostname
125               PROXY_CHECK:
126                 {
127 818 50       9991         unless ( $c->config->{using_frontend_proxy} ) {
  818         13925  
128 818 50       11772             last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
129 818 100       12166             last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
130                     }
131 817 100       11537         last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_HOST};
132              
133 1         10         $host = $ENV{HTTP_X_FORWARDED_HOST};
134              
135             # backend could be on any port, so
136             # assume frontend is on the default port
137 1 50       12         $port = $c->request->secure ? 443 : 80;
138                 }
139              
140             # set the base URI
141             # base must end in a slash
142 818 50       14739     $base_path .= '/' unless ( $base_path =~ /\/$/ );
143              
144 818   50     17411     my $path = $base_path . ( $ENV{PATH_INFO} || '' );
145 818         11013     $path =~ s{^/+}{};
146              
147 818         13282     my $uri = $uri_proto->clone;
148 818         52213     $uri->scheme($scheme);
149 818         15541     $uri->host($host);
150 818         16465     $uri->port($port);
151 818         14666     $uri->path($path);
152 818 100       86690     $uri->query( $ENV{QUERY_STRING} ) if $ENV{QUERY_STRING};
153              
154             # sanitize the URI
155 818         12198     $uri = $uri->canonical;
156 818         18393     $c->request->uri($uri);
157 818         11706     my $base = $uri->clone;
158 818         24218     $base->path_query($base_path);
159 818         101250     $c->request->base($base);
160             }
161              
162             =head2 $self->prepare_query_parameters($c)
163            
164             =cut
165              
166             sub prepare_query_parameters {
167 818     818 1 41214     my ( $self, $c ) = @_;
168 818   50     10117     local (*ENV) = $self->env || \%ENV;
169              
170 818 100       36612     if ( $ENV{QUERY_STRING} ) {
171 8         209         $self->SUPER::prepare_query_parameters( $c, $ENV{QUERY_STRING} );
172                 }
173             }
174              
175             =head2 $self->prepare_request($c, (env => \%env))
176            
177             =cut
178              
179             sub prepare_request {
180 818     818 1 40408     my ( $self, $c, %args ) = @_;
181              
182 818 50       13121     if ( $args{env} ) {
183 0         0         $self->env( $args{env} );
184                 }
185             }
186              
187             =head2 $self->prepare_write($c)
188            
189             Enable autoflush on the output handle for CGI-based engines.
190            
191             =cut
192              
193             sub prepare_write {
194 39     39 1 419     my ( $self, $c ) = @_;
195              
196             # Set the output handle to autoflush
197 39         1157     *STDOUT->autoflush(1);
198              
199 39         1687     $self->NEXT::prepare_write($c);
200             }
201              
202             =head2 $self->read_chunk($c, $buffer, $length)
203            
204             =cut
205              
206 13     13 1 155 sub read_chunk { shift; shift; *STDIN->sysread(@_); }
  13         113  
  13         279  
207              
208             =head2 $self->run
209            
210             =cut
211              
212 0     0 1   sub run { shift; shift->handle_request(@_) }
  0            
213              
214             =head1 SEE ALSO
215            
216             L<Catalyst> L<Catalyst::Engine>.
217            
218             =head1 AUTHORS
219            
220             Sebastian Riedel, <sri@cpan.org>
221            
222             Christian Hansen, <ch@ngmedia.com>
223            
224             Andy Grundman, <andy@hybridized.org>
225            
226             =head1 COPYRIGHT
227            
228             This program is free software, you can redistribute it and/or modify it under
229             the same terms as Perl itself.
230            
231             =cut
232              
233             1;
234