Commit | Line | Data |
32b29b79 |
1 | package HTTP::Body; |
2 | |
3 | use strict; |
4 | |
348fdd5a |
5 | use Carp qw[ ]; |
32b29b79 |
6 | |
2d423a7b |
7 | our $VERSION = 0.91; |
aac7ca02 |
8 | |
7e2df1d9 |
9 | our $TYPES = { |
4f5db602 |
10 | 'application/octet-stream' => 'HTTP::Body::OctetStream', |
11 | 'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded', |
12 | 'multipart/form-data' => 'HTTP::Body::MultiPart' |
32b29b79 |
13 | }; |
14 | |
b018320d |
15 | require HTTP::Body::OctetStream; |
16 | require HTTP::Body::UrlEncoded; |
17 | require HTTP::Body::MultiPart; |
18 | |
aac7ca02 |
19 | =head1 NAME |
20 | |
21 | HTTP::Body - HTTP Body Parser |
22 | |
23 | =head1 SYNOPSIS |
24 | |
25 | use HTTP::Body; |
17c3e9b3 |
26 | |
27 | sub handler : method { |
28 | my ( $class, $r ) = @_; |
29 | |
30 | my $content_type = $r->headers_in->get('Content-Type'); |
31 | my $content_length = $r->headers_in->get('Content-Length'); |
32 | |
33 | my $body = HTTP::Body->new( $content_type, $content_length ); |
34 | my $length = $content_length; |
35 | |
36 | while ( $length ) { |
37 | |
38 | $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 ); |
39 | |
40 | $length -= length($buffer); |
41 | |
42 | $body->add($buffer); |
43 | } |
44 | |
45 | my $uploads = $body->upload; # hashref |
46 | my $params = $body->param; # hashref |
47 | my $body = $body->body; # IO::Handle |
48 | } |
aac7ca02 |
49 | |
50 | =head1 DESCRIPTION |
51 | |
6215b02b |
52 | HTTP::Body parses chunks of HTTP POST data and supports |
53 | application/octet-stream, application/x-www-form-urlencoded, and |
54 | multipart/form-data. |
55 | |
56 | It is currently used by L<Catalyst> to parse POST bodies. |
aac7ca02 |
57 | |
58 | =head1 METHODS |
59 | |
6153c112 |
60 | =over 4 |
61 | |
62 | =item new |
63 | |
64 | Constructor. Takes content type and content length as parameters, |
65 | returns a L<HTTP::Body> object. |
aac7ca02 |
66 | |
67 | =cut |
68 | |
32b29b79 |
69 | sub new { |
70 | my ( $class, $content_type, $content_length ) = @_; |
71 | |
72 | unless ( @_ == 3 ) { |
73 | Carp::croak( $class, '->new( $content_type, $content_length )' ); |
74 | } |
7e2df1d9 |
75 | |
27ee4e94 |
76 | my $type; |
77 | foreach my $supported ( keys %{$TYPES} ) { |
78 | if ( index( lc($content_type), $supported ) >= 0 ) { |
79 | $type = $supported; |
80 | } |
81 | } |
82 | |
7e2df1d9 |
83 | my $body = $TYPES->{ $type || 'application/octet-stream' }; |
84 | |
32b29b79 |
85 | eval "require $body"; |
7e2df1d9 |
86 | |
87 | if ($@) { |
32b29b79 |
88 | die $@; |
89 | } |
7e2df1d9 |
90 | |
32b29b79 |
91 | my $self = { |
92 | buffer => '', |
44761c00 |
93 | body => undef, |
32b29b79 |
94 | content_length => $content_length, |
95 | content_type => $content_type, |
58050177 |
96 | length => 0, |
7e2df1d9 |
97 | param => {}, |
98 | state => 'buffering', |
99 | upload => {} |
32b29b79 |
100 | }; |
101 | |
102 | bless( $self, $body ); |
7e2df1d9 |
103 | |
32b29b79 |
104 | return $self->init; |
105 | } |
106 | |
aac7ca02 |
107 | =item add |
108 | |
4deaf0f0 |
109 | Add string to internal buffer. Will call spin unless done. returns |
6153c112 |
110 | length before adding self. |
111 | |
aac7ca02 |
112 | =cut |
113 | |
32b29b79 |
114 | sub add { |
58050177 |
115 | my $self = shift; |
304dca13 |
116 | |
117 | my $cl = $self->content_length; |
7e2df1d9 |
118 | |
58050177 |
119 | if ( defined $_[0] ) { |
7e2df1d9 |
120 | $self->{length} += length( $_[0] ); |
304dca13 |
121 | |
122 | # Don't allow buffer data to exceed content-length |
123 | if ( $self->{length} > $cl ) { |
124 | $_[0] = substr $_[0], 0, $cl - $self->{length}; |
125 | $self->{length} = $cl; |
126 | } |
127 | |
128 | $self->{buffer} .= $_[0]; |
58050177 |
129 | } |
aac7ca02 |
130 | |
7e2df1d9 |
131 | unless ( $self->state eq 'done' ) { |
132 | $self->spin; |
133 | } |
134 | |
304dca13 |
135 | return ( $self->length - $cl ); |
32b29b79 |
136 | } |
137 | |
aac7ca02 |
138 | =item body |
139 | |
6153c112 |
140 | accessor for the body. |
141 | |
aac7ca02 |
142 | =cut |
143 | |
32b29b79 |
144 | sub body { |
145 | my $self = shift; |
146 | $self->{body} = shift if @_; |
147 | return $self->{body}; |
148 | } |
149 | |
aac7ca02 |
150 | =item buffer |
151 | |
6153c112 |
152 | read only accessor for the buffer. |
153 | |
aac7ca02 |
154 | =cut |
155 | |
58050177 |
156 | sub buffer { |
157 | return shift->{buffer}; |
158 | } |
159 | |
aac7ca02 |
160 | =item content_length |
161 | |
6153c112 |
162 | read only accessor for content length |
163 | |
aac7ca02 |
164 | =cut |
165 | |
32b29b79 |
166 | sub content_length { |
167 | return shift->{content_length}; |
168 | } |
169 | |
aac7ca02 |
170 | =item content_type |
171 | |
807be76d |
172 | read only accessor for the content type |
6153c112 |
173 | |
aac7ca02 |
174 | =cut |
175 | |
32b29b79 |
176 | sub content_type { |
177 | return shift->{content_type}; |
178 | } |
179 | |
aac7ca02 |
180 | =item init |
181 | |
6153c112 |
182 | return self. |
183 | |
aac7ca02 |
184 | =cut |
185 | |
58050177 |
186 | sub init { |
187 | return $_[0]; |
188 | } |
189 | |
aac7ca02 |
190 | =item length |
191 | |
6153c112 |
192 | read only accessor for body length. |
193 | |
aac7ca02 |
194 | =cut |
195 | |
58050177 |
196 | sub length { |
197 | return shift->{length}; |
198 | } |
199 | |
aac7ca02 |
200 | =item spin |
201 | |
6153c112 |
202 | Abstract method to spin the io handle. |
203 | |
aac7ca02 |
204 | =cut |
205 | |
58050177 |
206 | sub spin { |
207 | Carp::croak('Define abstract method spin() in implementation'); |
208 | } |
209 | |
aac7ca02 |
210 | =item state |
211 | |
6153c112 |
212 | accessor for body state. |
213 | |
aac7ca02 |
214 | =cut |
215 | |
7e2df1d9 |
216 | sub state { |
217 | my $self = shift; |
218 | $self->{state} = shift if @_; |
aac7ca02 |
219 | return $self->{state}; |
220 | } |
221 | |
aac7ca02 |
222 | =item param |
223 | |
6153c112 |
224 | accesor for http parameters. |
225 | |
aac7ca02 |
226 | =cut |
227 | |
32b29b79 |
228 | sub param { |
229 | my $self = shift; |
230 | |
231 | if ( @_ == 2 ) { |
232 | |
233 | my ( $name, $value ) = @_; |
234 | |
235 | if ( exists $self->{param}->{$name} ) { |
236 | for ( $self->{param}->{$name} ) { |
237 | $_ = [$_] unless ref($_) eq "ARRAY"; |
238 | push( @$_, $value ); |
239 | } |
240 | } |
241 | else { |
242 | $self->{param}->{$name} = $value; |
243 | } |
244 | } |
245 | |
246 | return $self->{param}; |
247 | } |
248 | |
aac7ca02 |
249 | =item upload |
250 | |
251 | =cut |
252 | |
32b29b79 |
253 | sub upload { |
254 | my $self = shift; |
255 | |
256 | if ( @_ == 2 ) { |
257 | |
258 | my ( $name, $upload ) = @_; |
259 | |
260 | if ( exists $self->{upload}->{$name} ) { |
261 | for ( $self->{upload}->{$name} ) { |
262 | $_ = [$_] unless ref($_) eq "ARRAY"; |
263 | push( @$_, $upload ); |
264 | } |
265 | } |
266 | else { |
267 | $self->{upload}->{$name} = $upload; |
268 | } |
269 | } |
270 | |
271 | return $self->{upload}; |
272 | } |
273 | |
aac7ca02 |
274 | =back |
275 | |
4deaf0f0 |
276 | =head1 BUGS |
277 | |
278 | Chunked requests are currently not supported. |
279 | |
aac7ca02 |
280 | =head1 AUTHOR |
281 | |
282 | Christian Hansen, C<ch@ngmedia.com> |
17c3e9b3 |
283 | |
284 | Sebastian Riedel, C<sri@cpan.org> |
aac7ca02 |
285 | |
286 | =head1 LICENSE |
287 | |
17c3e9b3 |
288 | This library is free software. You can redistribute it and/or modify |
aac7ca02 |
289 | it under the same terms as perl itself. |
290 | |
291 | =cut |
292 | |
32b29b79 |
293 | 1; |