Commit | Line | Data |
2cdfbf5e |
1 | package Catalyst::Engine::HTTP::Base; |
2 | |
3 | use strict; |
4 | use base 'Catalyst::Engine'; |
5 | |
a2f2cde9 |
6 | use Catalyst::Exception; |
2cdfbf5e |
7 | use Class::Struct (); |
8 | use HTTP::Headers::Util 'split_header_words'; |
9 | use HTTP::Request; |
10 | use HTTP::Response; |
11 | use File::Temp; |
12 | use URI; |
13 | |
14 | __PACKAGE__->mk_accessors(qw/http/); |
15 | |
d837e1a7 |
16 | Class::Struct::struct 'Catalyst::Engine::HTTP::Base::struct' => { |
2cdfbf5e |
17 | request => 'HTTP::Request', |
18 | response => 'HTTP::Response', |
19 | hostname => '$', |
20 | address => '$' |
21 | }; |
22 | |
23 | =head1 NAME |
24 | |
25 | Catalyst::Engine::HTTP::Base - Base class for HTTP Engines |
26 | |
27 | =head1 DESCRIPTION |
28 | |
29 | This is a base class for HTTP Engines. |
30 | |
31 | =head1 OVERLOADED METHODS |
32 | |
33 | This class overloads some methods from C<Catalyst::Engine>. |
34 | |
35 | =over 4 |
36 | |
37 | =item $c->finalize_body |
38 | |
39 | =cut |
40 | |
41 | sub finalize_body { |
42 | my $c = shift; |
43 | $c->http->response->content( $c->response->body ); |
44 | } |
45 | |
46 | =item $c->finalize_headers |
47 | |
48 | =cut |
49 | |
50 | sub finalize_headers { |
51 | my $c = shift; |
52 | |
53 | $c->http->response->code( $c->response->status ); |
54 | |
55 | for my $name ( $c->response->headers->header_field_names ) { |
56 | $c->http->response->push_header( $name => [ $c->response->header($name) ] ); |
57 | } |
58 | } |
59 | |
60 | =item $c->prepare_body |
61 | |
62 | =cut |
63 | |
64 | sub prepare_body { |
65 | my $c = shift; |
66 | $c->request->body( $c->http->request->content ); |
67 | } |
68 | |
69 | =item $c->prepare_connection |
70 | |
71 | =cut |
72 | |
73 | sub prepare_connection { |
74 | my $c = shift; |
75 | $c->request->address( $c->http->address ); |
76 | $c->request->hostname( $c->http->hostname ); |
77 | $c->request->protocol( $c->http->request->protocol ); |
f829e6cc |
78 | $c->request->secure(1) if ( $c->http->request->uri->port == 443 ); |
2cdfbf5e |
79 | } |
80 | |
81 | =item $c->prepare_headers |
82 | |
83 | =cut |
84 | |
85 | sub prepare_headers { |
86 | my $c = shift; |
87 | $c->request->method( $c->http->request->method ); |
88 | $c->request->headers( $c->http->request->headers ); |
89 | } |
90 | |
91 | =item $c->prepare_parameters |
92 | |
93 | =cut |
94 | |
95 | sub prepare_parameters { |
96 | my $c = shift; |
97 | |
98 | my ( @params, @uploads ); |
99 | |
100 | my $request = $c->http->request; |
101 | |
102 | push( @params, $request->uri->query_form ); |
103 | |
104 | if ( $request->content_type eq 'application/x-www-form-urlencoded' ) { |
105 | my $uri = URI->new('http:'); |
106 | $uri->query( $request->content ); |
107 | push( @params, $uri->query_form ); |
108 | } |
109 | |
110 | if ( $request->content_type eq 'multipart/form-data' ) { |
111 | |
112 | for my $part ( $request->parts ) { |
113 | |
114 | my $disposition = $part->header('Content-Disposition'); |
115 | my %parameters = @{ ( split_header_words($disposition) )[0] }; |
116 | |
117 | if ( $parameters{filename} ) { |
118 | |
119 | my $fh = File::Temp->new( UNLINK => 0 ); |
a2f2cde9 |
120 | |
121 | unless ( $fh->write( $part->content ) ) { |
122 | Catalyst::Exception->throw( message => $! ); |
123 | } |
124 | |
125 | unless ( $fh->flush ) { |
126 | Catalyst::Exception->throw( message => $! ); |
127 | } |
2cdfbf5e |
128 | |
129 | my $upload = Catalyst::Request::Upload->new( |
130 | filename => $parameters{filename}, |
131 | size => ( $fh->stat )[7], |
132 | tempname => $fh->filename, |
133 | type => $part->content_type |
134 | ); |
135 | |
a2f2cde9 |
136 | unless ( $fh->close ) { |
137 | Catalyst::Exception->throw( message => $! ); |
138 | } |
2cdfbf5e |
139 | |
140 | push( @uploads, $parameters{name}, $upload ); |
141 | push( @params, $parameters{name}, $parameters{filename} ); |
142 | } |
143 | else { |
144 | push( @params, $parameters{name}, $part->content ); |
145 | } |
146 | } |
147 | } |
148 | |
149 | $c->request->param(@params); |
150 | $c->request->upload(@uploads); |
151 | } |
152 | |
153 | =item $c->prepare_path |
154 | |
155 | =cut |
156 | |
157 | sub prepare_path { |
158 | my $c = shift; |
159 | |
160 | my $base; |
161 | { |
162 | my $scheme = $c->http->request->uri->scheme; |
163 | my $host = $c->http->request->uri->host; |
164 | my $port = $c->http->request->uri->port; |
165 | |
166 | $base = URI->new; |
167 | $base->scheme($scheme); |
168 | $base->host($host); |
169 | $base->port($port); |
170 | |
171 | $base = $base->canonical->as_string; |
172 | } |
173 | |
174 | my $path = $c->http->request->uri->path || '/'; |
175 | $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
176 | $path =~ s/^\///; |
177 | |
178 | $c->req->base($base); |
179 | $c->req->path($path); |
180 | } |
181 | |
182 | =item $c->prepare_request($r) |
183 | |
184 | =cut |
185 | |
186 | sub prepare_request { |
187 | my ( $c, $http ) = @_; |
188 | $c->http($http); |
189 | } |
190 | |
191 | =item $c->prepare_uploads |
192 | |
193 | =cut |
194 | |
195 | sub prepare_uploads { |
196 | my $c = shift; |
197 | } |
198 | |
199 | =back |
200 | |
201 | =head1 SEE ALSO |
202 | |
203 | L<Catalyst>. |
204 | |
205 | =head1 AUTHOR |
206 | |
207 | Sebastian Riedel, C<sri@cpan.org> |
208 | Christian Hansen, C<ch@ngmedia.com> |
209 | |
210 | =head1 COPYRIGHT |
211 | |
212 | This program is free software, you can redistribute it and/or modify it under |
213 | the same terms as Perl itself. |
214 | |
215 | =cut |
216 | |
217 | 1; |