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