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