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