Commit | Line | Data |
c2e8e6fa |
1 | package Catalyst::Engine::CGI::Base; |
2 | |
3 | use strict; |
4 | use base 'Catalyst::Engine'; |
5 | |
6 | use URI; |
7 | use URI::http; |
8 | |
9 | __PACKAGE__->mk_accessors('cgi'); |
10 | |
11 | =head1 NAME |
12 | |
13 | Catalyst::Engine::CGI::Base - Base class for CGI Engines |
14 | |
15 | =head1 DESCRIPTION |
16 | |
17 | This is a base class for CGI engines. |
18 | |
19 | =head1 METHODS |
20 | |
21 | =over 4 |
22 | |
23 | =item $c->cgi |
24 | |
25 | This config parameter contains the C<CGI> object. |
26 | |
27 | =back |
28 | |
29 | =head1 OVERLOADED METHODS |
30 | |
31 | This class overloads some methods from C<Catalyst::Engine>. |
32 | |
33 | =over 4 |
34 | |
35 | =item $c->finalize_body |
36 | |
37 | Prints the response output to STDOUT. |
38 | |
39 | =cut |
40 | |
41 | sub finalize_body { |
42 | my $c = shift; |
43 | print $c->response->output; |
44 | } |
45 | |
46 | =item $c->finalize_headers |
47 | |
48 | =cut |
49 | |
50 | sub finalize_headers { |
51 | my $c = shift; |
52 | |
53 | $c->response->header( Status => $c->response->status ); |
54 | |
55 | print $c->response->headers->as_string("\015\012"); |
56 | print "\015\012"; |
57 | } |
58 | |
59 | =item $c->prepare_connection |
60 | |
61 | =cut |
62 | |
63 | sub prepare_connection { |
64 | my $c = shift; |
65 | $c->request->address( $ENV{REMOTE_ADDR} ); |
66 | $c->request->hostname( $ENV{REMOTE_HOST} ); |
67 | $c->request->protocol( $ENV{SERVER_PROTOCOL} ); |
68 | |
69 | if ( $ENV{HTTPS} || $ENV{SERVER_PORT} == 443 ) { |
70 | $c->request->secure(1); |
71 | } |
72 | } |
73 | |
74 | =item $c->prepare_headers |
75 | |
76 | =cut |
77 | |
78 | sub prepare_headers { |
79 | my $c = shift; |
80 | |
81 | while ( my ( $header, $value ) = each %ENV ) { |
82 | |
83 | next unless $header =~ /^(HTTP|CONTENT)/i; |
84 | |
85 | ( my $field = $header ) =~ s/^HTTPS?_//; |
86 | |
87 | $c->req->headers->header( $field => $value ); |
88 | } |
89 | |
90 | $c->req->method( $ENV{REQUEST_METHOD} || 'GET' ); |
91 | } |
92 | |
93 | =item $c->prepare_path |
94 | |
95 | =cut |
96 | |
97 | sub prepare_path { |
98 | my $c = shift; |
99 | |
100 | my $base; |
101 | { |
102 | my $scheme = $c->request->secure ? 'https' : 'http'; |
103 | my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; |
104 | my $port = $ENV{SERVER_PORT} || 80; |
105 | my $path = $ENV{SCRIPT_NAME} || '/'; |
106 | |
107 | unless ( $path =~ /\/$/ ) { |
108 | $path .= '/'; |
109 | } |
110 | |
111 | $base = URI->new; |
112 | $base->scheme($scheme); |
113 | $base->host($host); |
114 | $base->port($port); |
115 | $base->path($path); |
116 | |
117 | $base = $base->canonical->as_string; |
118 | } |
119 | |
120 | my $path = $ENV{PATH_INFO} || '/'; |
121 | $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
122 | $path =~ s/^\///; |
123 | |
124 | $c->req->base($base); |
125 | $c->req->path($path); |
126 | } |
127 | |
128 | =item $c->run |
129 | |
130 | =cut |
131 | |
132 | sub run { shift->handler } |
133 | |
134 | =back |
135 | |
136 | =head1 SEE ALSO |
137 | |
138 | L<Catalyst>. |
139 | |
140 | =head1 AUTHOR |
141 | |
142 | Sebastian Riedel, C<sri@cpan.org> |
143 | Christian Hansen, C<ch@ngmedia.com> |
144 | |
145 | =head1 COPYRIGHT |
146 | |
147 | This program is free software, you can redistribute it and/or modify it under |
148 | the same terms as Perl itself. |
149 | |
150 | =cut |
151 | |
152 | 1; |