Commit | Line | Data |
32b29b79 |
1 | package HTTP::Body; |
2 | |
3 | use strict; |
4 | |
348fdd5a |
5 | use Carp qw[ ]; |
32b29b79 |
6 | |
9bbd91b6 |
7 | our $VERSION = 0.6; |
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 | |
52 | HTTP Body Parser. |
53 | |
54 | =head1 METHODS |
55 | |
6153c112 |
56 | =over 4 |
57 | |
58 | =item new |
59 | |
60 | Constructor. Takes content type and content length as parameters, |
61 | returns a L<HTTP::Body> object. |
aac7ca02 |
62 | |
63 | =cut |
64 | |
32b29b79 |
65 | sub new { |
66 | my ( $class, $content_type, $content_length ) = @_; |
67 | |
68 | unless ( @_ == 3 ) { |
69 | Carp::croak( $class, '->new( $content_type, $content_length )' ); |
70 | } |
7e2df1d9 |
71 | |
27ee4e94 |
72 | my $type; |
73 | foreach my $supported ( keys %{$TYPES} ) { |
74 | if ( index( lc($content_type), $supported ) >= 0 ) { |
75 | $type = $supported; |
76 | } |
77 | } |
78 | |
7e2df1d9 |
79 | my $body = $TYPES->{ $type || 'application/octet-stream' }; |
80 | |
32b29b79 |
81 | eval "require $body"; |
7e2df1d9 |
82 | |
83 | if ($@) { |
32b29b79 |
84 | die $@; |
85 | } |
7e2df1d9 |
86 | |
32b29b79 |
87 | my $self = { |
88 | buffer => '', |
44761c00 |
89 | body => undef, |
32b29b79 |
90 | content_length => $content_length, |
91 | content_type => $content_type, |
58050177 |
92 | length => 0, |
7e2df1d9 |
93 | param => {}, |
94 | state => 'buffering', |
95 | upload => {} |
32b29b79 |
96 | }; |
97 | |
98 | bless( $self, $body ); |
7e2df1d9 |
99 | |
32b29b79 |
100 | return $self->init; |
101 | } |
102 | |
aac7ca02 |
103 | =item add |
104 | |
4deaf0f0 |
105 | Add string to internal buffer. Will call spin unless done. returns |
6153c112 |
106 | length before adding self. |
107 | |
aac7ca02 |
108 | =cut |
109 | |
32b29b79 |
110 | sub add { |
58050177 |
111 | my $self = shift; |
7e2df1d9 |
112 | |
58050177 |
113 | if ( defined $_[0] ) { |
114 | $self->{buffer} .= $_[0]; |
7e2df1d9 |
115 | $self->{length} += length( $_[0] ); |
58050177 |
116 | } |
aac7ca02 |
117 | |
7e2df1d9 |
118 | unless ( $self->state eq 'done' ) { |
119 | $self->spin; |
120 | } |
121 | |
58050177 |
122 | return ( $self->length - $self->content_length ); |
32b29b79 |
123 | } |
124 | |
aac7ca02 |
125 | =item body |
126 | |
6153c112 |
127 | accessor for the body. |
128 | |
aac7ca02 |
129 | =cut |
130 | |
32b29b79 |
131 | sub body { |
132 | my $self = shift; |
133 | $self->{body} = shift if @_; |
134 | return $self->{body}; |
135 | } |
136 | |
aac7ca02 |
137 | =item buffer |
138 | |
6153c112 |
139 | read only accessor for the buffer. |
140 | |
aac7ca02 |
141 | =cut |
142 | |
58050177 |
143 | sub buffer { |
144 | return shift->{buffer}; |
145 | } |
146 | |
aac7ca02 |
147 | =item content_length |
148 | |
6153c112 |
149 | read only accessor for content length |
150 | |
aac7ca02 |
151 | =cut |
152 | |
32b29b79 |
153 | sub content_length { |
154 | return shift->{content_length}; |
155 | } |
156 | |
aac7ca02 |
157 | =item content_type |
158 | |
6153c112 |
159 | ready only accessor for the content type |
160 | |
aac7ca02 |
161 | =cut |
162 | |
32b29b79 |
163 | sub content_type { |
164 | return shift->{content_type}; |
165 | } |
166 | |
aac7ca02 |
167 | =item init |
168 | |
6153c112 |
169 | return self. |
170 | |
aac7ca02 |
171 | =cut |
172 | |
58050177 |
173 | sub init { |
174 | return $_[0]; |
175 | } |
176 | |
aac7ca02 |
177 | =item length |
178 | |
6153c112 |
179 | read only accessor for body length. |
180 | |
aac7ca02 |
181 | =cut |
182 | |
58050177 |
183 | sub length { |
184 | return shift->{length}; |
185 | } |
186 | |
aac7ca02 |
187 | =item spin |
188 | |
6153c112 |
189 | Abstract method to spin the io handle. |
190 | |
aac7ca02 |
191 | =cut |
192 | |
58050177 |
193 | sub spin { |
194 | Carp::croak('Define abstract method spin() in implementation'); |
195 | } |
196 | |
aac7ca02 |
197 | =item state |
198 | |
6153c112 |
199 | accessor for body state. |
200 | |
aac7ca02 |
201 | =cut |
202 | |
7e2df1d9 |
203 | sub state { |
204 | my $self = shift; |
205 | $self->{state} = shift if @_; |
aac7ca02 |
206 | return $self->{state}; |
207 | } |
208 | |
aac7ca02 |
209 | =item param |
210 | |
6153c112 |
211 | accesor for http parameters. |
212 | |
aac7ca02 |
213 | =cut |
214 | |
32b29b79 |
215 | sub param { |
216 | my $self = shift; |
217 | |
218 | if ( @_ == 2 ) { |
219 | |
220 | my ( $name, $value ) = @_; |
221 | |
222 | if ( exists $self->{param}->{$name} ) { |
223 | for ( $self->{param}->{$name} ) { |
224 | $_ = [$_] unless ref($_) eq "ARRAY"; |
225 | push( @$_, $value ); |
226 | } |
227 | } |
228 | else { |
229 | $self->{param}->{$name} = $value; |
230 | } |
231 | } |
232 | |
233 | return $self->{param}; |
234 | } |
235 | |
aac7ca02 |
236 | =item upload |
237 | |
238 | =cut |
239 | |
32b29b79 |
240 | sub upload { |
241 | my $self = shift; |
242 | |
243 | if ( @_ == 2 ) { |
244 | |
245 | my ( $name, $upload ) = @_; |
246 | |
247 | if ( exists $self->{upload}->{$name} ) { |
248 | for ( $self->{upload}->{$name} ) { |
249 | $_ = [$_] unless ref($_) eq "ARRAY"; |
250 | push( @$_, $upload ); |
251 | } |
252 | } |
253 | else { |
254 | $self->{upload}->{$name} = $upload; |
255 | } |
256 | } |
257 | |
258 | return $self->{upload}; |
259 | } |
260 | |
aac7ca02 |
261 | =back |
262 | |
4deaf0f0 |
263 | =head1 BUGS |
264 | |
265 | Chunked requests are currently not supported. |
266 | |
aac7ca02 |
267 | =head1 AUTHOR |
268 | |
269 | Christian Hansen, C<ch@ngmedia.com> |
17c3e9b3 |
270 | |
271 | Sebastian Riedel, C<sri@cpan.org> |
aac7ca02 |
272 | |
273 | =head1 LICENSE |
274 | |
17c3e9b3 |
275 | This library is free software. You can redistribute it and/or modify |
aac7ca02 |
276 | it under the same terms as perl itself. |
277 | |
278 | =cut |
279 | |
32b29b79 |
280 | 1; |