Filename | /usr/local/share/perl/5.18.2/HTTP/Body.pm |
Statements | Executed 17 statements in 1.77ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 7.13ms | 8.72ms | BEGIN@26 | HTTP::Body::
1 | 1 | 1 | 6.70ms | 7.35ms | BEGIN@25 | HTTP::Body::
1 | 1 | 1 | 18µs | 40µs | BEGIN@6 | HTTP::Body::
1 | 1 | 1 | 5µs | 5µs | BEGIN@8 | HTTP::Body::
0 | 0 | 0 | 0s | 0s | DESTROY | HTTP::Body::
0 | 0 | 0 | 0s | 0s | add | HTTP::Body::
0 | 0 | 0 | 0s | 0s | body | HTTP::Body::
0 | 0 | 0 | 0s | 0s | chunked | HTTP::Body::
0 | 0 | 0 | 0s | 0s | cleanup | HTTP::Body::
0 | 0 | 0 | 0s | 0s | content_length | HTTP::Body::
0 | 0 | 0 | 0s | 0s | content_type | HTTP::Body::
0 | 0 | 0 | 0s | 0s | init | HTTP::Body::
0 | 0 | 0 | 0s | 0s | length | HTTP::Body::
0 | 0 | 0 | 0s | 0s | new | HTTP::Body::
0 | 0 | 0 | 0s | 0s | param | HTTP::Body::
0 | 0 | 0 | 0s | 0s | param_order | HTTP::Body::
0 | 0 | 0 | 0s | 0s | spin | HTTP::Body::
0 | 0 | 0 | 0s | 0s | state | HTTP::Body::
0 | 0 | 0 | 0s | 0s | tmpdir | HTTP::Body::
0 | 0 | 0 | 0s | 0s | trailing_headers | HTTP::Body::
0 | 0 | 0 | 0s | 0s | upload | HTTP::Body::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package HTTP::Body; | ||||
2 | { | ||||
3 | 2 | 2µs | $HTTP::Body::VERSION = '1.19'; | ||
4 | } | ||||
5 | |||||
6 | 2 | 36µs | 2 | 62µs | # spent 40µs (18+22) within HTTP::Body::BEGIN@6 which was called:
# once (18µs+22µs) by Plack::Request::BEGIN@10 at line 6 # spent 40µs making 1 call to HTTP::Body::BEGIN@6
# spent 22µs making 1 call to strict::import |
7 | |||||
8 | 2 | 103µs | 1 | 5µs | # spent 5µs within HTTP::Body::BEGIN@8 which was called:
# once (5µs+0s) by Plack::Request::BEGIN@10 at line 8 # spent 5µs making 1 call to HTTP::Body::BEGIN@8 |
9 | |||||
10 | 1 | 5µs | our $TYPES = { | ||
11 | 'application/octet-stream' => 'HTTP::Body::OctetStream', | ||||
12 | 'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded', | ||||
13 | 'multipart/form-data' => 'HTTP::Body::MultiPart', | ||||
14 | 'multipart/related' => 'HTTP::Body::XFormsMultipart', | ||||
15 | 'application/xml' => 'HTTP::Body::XForms', | ||||
16 | 'application/json' => 'HTTP::Body::OctetStream', | ||||
17 | }; | ||||
18 | |||||
19 | 1 | 80µs | require HTTP::Body::OctetStream; | ||
20 | 1 | 59µs | require HTTP::Body::UrlEncoded; | ||
21 | 1 | 67µs | require HTTP::Body::MultiPart; | ||
22 | 1 | 56µs | require HTTP::Body::XFormsMultipart; | ||
23 | 1 | 56µs | require HTTP::Body::XForms; | ||
24 | |||||
25 | 2 | 144µs | 1 | 7.35ms | # spent 7.35ms (6.70+654µs) within HTTP::Body::BEGIN@25 which was called:
# once (6.70ms+654µs) by Plack::Request::BEGIN@10 at line 25 # spent 7.35ms making 1 call to HTTP::Body::BEGIN@25 |
26 | 2 | 1.16ms | 1 | 8.72ms | # spent 8.72ms (7.13+1.59) within HTTP::Body::BEGIN@26 which was called:
# once (7.13ms+1.59ms) by Plack::Request::BEGIN@10 at line 26 # spent 8.72ms making 1 call to HTTP::Body::BEGIN@26 |
27 | |||||
28 | =head1 NAME | ||||
29 | |||||
30 | HTTP::Body - HTTP Body Parser | ||||
31 | |||||
32 | =head1 SYNOPSIS | ||||
33 | |||||
34 | use HTTP::Body; | ||||
35 | |||||
36 | sub handler : method { | ||||
37 | my ( $class, $r ) = @_; | ||||
38 | |||||
39 | my $content_type = $r->headers_in->get('Content-Type'); | ||||
40 | my $content_length = $r->headers_in->get('Content-Length'); | ||||
41 | |||||
42 | my $body = HTTP::Body->new( $content_type, $content_length ); | ||||
43 | my $length = $content_length; | ||||
44 | |||||
45 | while ( $length ) { | ||||
46 | |||||
47 | $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 ); | ||||
48 | |||||
49 | $length -= length($buffer); | ||||
50 | |||||
51 | $body->add($buffer); | ||||
52 | } | ||||
53 | |||||
54 | my $uploads = $body->upload; # hashref | ||||
55 | my $params = $body->param; # hashref | ||||
56 | my $param_order = $body->param_order # arrayref | ||||
57 | my $body = $body->body; # IO::Handle | ||||
58 | } | ||||
59 | |||||
60 | =head1 DESCRIPTION | ||||
61 | |||||
62 | HTTP::Body parses chunks of HTTP POST data and supports | ||||
63 | application/octet-stream, application/json, application/x-www-form-urlencoded, | ||||
64 | and multipart/form-data. | ||||
65 | |||||
66 | Chunked bodies are supported by not passing a length value to new(). | ||||
67 | |||||
68 | It is currently used by L<Catalyst> to parse POST bodies. | ||||
69 | |||||
70 | =head1 NOTES | ||||
71 | |||||
72 | When parsing multipart bodies, temporary files are created to store any | ||||
73 | uploaded files. You must delete these temporary files yourself after | ||||
74 | processing them, or set $body->cleanup(1) to automatically delete them | ||||
75 | at DESTROY-time. | ||||
76 | |||||
77 | =head1 METHODS | ||||
78 | |||||
79 | =over 4 | ||||
80 | |||||
81 | =item new | ||||
82 | |||||
83 | Constructor. Takes content type and content length as parameters, | ||||
84 | returns a L<HTTP::Body> object. | ||||
85 | |||||
86 | =cut | ||||
87 | |||||
88 | sub new { | ||||
89 | my ( $class, $content_type, $content_length ) = @_; | ||||
90 | |||||
91 | unless ( @_ >= 2 ) { | ||||
92 | Carp::croak( $class, '->new( $content_type, [ $content_length ] )' ); | ||||
93 | } | ||||
94 | |||||
95 | my $type; | ||||
96 | my $earliest_index; | ||||
97 | foreach my $supported ( keys %{$TYPES} ) { | ||||
98 | my $index = index( lc($content_type), $supported ); | ||||
99 | if ($index >= 0 && (!defined $earliest_index || $index < $earliest_index)) { | ||||
100 | $type = $supported; | ||||
101 | $earliest_index = $index; | ||||
102 | } | ||||
103 | } | ||||
104 | |||||
105 | my $body = $TYPES->{ $type || 'application/octet-stream' }; | ||||
106 | |||||
107 | my $self = { | ||||
108 | cleanup => 0, | ||||
109 | buffer => '', | ||||
110 | chunk_buffer => '', | ||||
111 | body => undef, | ||||
112 | chunked => !defined $content_length, | ||||
113 | content_length => defined $content_length ? $content_length : -1, | ||||
114 | content_type => $content_type, | ||||
115 | length => 0, | ||||
116 | param => {}, | ||||
117 | param_order => [], | ||||
118 | state => 'buffering', | ||||
119 | upload => {}, | ||||
120 | tmpdir => File::Spec->tmpdir(), | ||||
121 | }; | ||||
122 | |||||
123 | bless( $self, $body ); | ||||
124 | |||||
125 | return $self->init; | ||||
126 | } | ||||
127 | |||||
128 | sub DESTROY { | ||||
129 | my $self = shift; | ||||
130 | |||||
131 | if ( $self->{cleanup} ) { | ||||
132 | my @temps = (); | ||||
133 | for my $upload ( values %{ $self->{upload} } ) { | ||||
134 | push @temps, map { $_->{tempname} || () } | ||||
135 | ( ref $upload eq 'ARRAY' ? @{$upload} : $upload ); | ||||
136 | } | ||||
137 | |||||
138 | unlink map { $_ } grep { -e $_ } @temps; | ||||
139 | } | ||||
140 | } | ||||
141 | |||||
142 | =item add | ||||
143 | |||||
144 | Add string to internal buffer. Will call spin unless done. returns | ||||
145 | length before adding self. | ||||
146 | |||||
147 | =cut | ||||
148 | |||||
149 | sub add { | ||||
150 | my $self = shift; | ||||
151 | |||||
152 | if ( $self->{chunked} ) { | ||||
153 | $self->{chunk_buffer} .= $_[0]; | ||||
154 | |||||
155 | while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) { | ||||
156 | my $chunk_len = hex($1); | ||||
157 | |||||
158 | if ( $chunk_len == 0 ) { | ||||
159 | # Strip chunk len | ||||
160 | $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//; | ||||
161 | |||||
162 | # End of data, there may be trailing headers | ||||
163 | if ( my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) { | ||||
164 | if ( my $message = HTTP::Message->parse( $headers ) ) { | ||||
165 | $self->{trailing_headers} = $message->headers; | ||||
166 | } | ||||
167 | } | ||||
168 | |||||
169 | $self->{chunk_buffer} = ''; | ||||
170 | |||||
171 | # Set content_length equal to the amount of data we read, | ||||
172 | # so the spin methods can finish up. | ||||
173 | $self->{content_length} = $self->{length}; | ||||
174 | } | ||||
175 | else { | ||||
176 | # Make sure we have the whole chunk in the buffer (+CRLF) | ||||
177 | if ( length( $self->{chunk_buffer} ) >= $chunk_len ) { | ||||
178 | # Strip chunk len | ||||
179 | $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//; | ||||
180 | |||||
181 | # Pull chunk data out of chunk buffer into real buffer | ||||
182 | $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, ''; | ||||
183 | |||||
184 | # Strip remaining CRLF | ||||
185 | $self->{chunk_buffer} =~ s/^\x0D\x0A//; | ||||
186 | |||||
187 | $self->{length} += $chunk_len; | ||||
188 | } | ||||
189 | else { | ||||
190 | # Not enough data for this chunk, wait for more calls to add() | ||||
191 | return; | ||||
192 | } | ||||
193 | } | ||||
194 | |||||
195 | unless ( $self->{state} eq 'done' ) { | ||||
196 | $self->spin; | ||||
197 | } | ||||
198 | } | ||||
199 | |||||
200 | return; | ||||
201 | } | ||||
202 | |||||
203 | my $cl = $self->content_length; | ||||
204 | |||||
205 | if ( defined $_[0] ) { | ||||
206 | $self->{length} += length( $_[0] ); | ||||
207 | |||||
208 | # Don't allow buffer data to exceed content-length | ||||
209 | if ( $self->{length} > $cl ) { | ||||
210 | $_[0] = substr $_[0], 0, $cl - $self->{length}; | ||||
211 | $self->{length} = $cl; | ||||
212 | } | ||||
213 | |||||
214 | $self->{buffer} .= $_[0]; | ||||
215 | } | ||||
216 | |||||
217 | unless ( $self->state eq 'done' ) { | ||||
218 | $self->spin; | ||||
219 | } | ||||
220 | |||||
221 | return ( $self->length - $cl ); | ||||
222 | } | ||||
223 | |||||
224 | =item body | ||||
225 | |||||
226 | accessor for the body. | ||||
227 | |||||
228 | =cut | ||||
229 | |||||
230 | sub body { | ||||
231 | my $self = shift; | ||||
232 | $self->{body} = shift if @_; | ||||
233 | return $self->{body}; | ||||
234 | } | ||||
235 | |||||
236 | =item chunked | ||||
237 | |||||
238 | Returns 1 if the request is chunked. | ||||
239 | |||||
240 | =cut | ||||
241 | |||||
242 | sub chunked { | ||||
243 | return shift->{chunked}; | ||||
244 | } | ||||
245 | |||||
246 | =item cleanup | ||||
247 | |||||
248 | Set to 1 to enable automatic deletion of temporary files at DESTROY-time. | ||||
249 | |||||
250 | =cut | ||||
251 | |||||
252 | sub cleanup { | ||||
253 | my $self = shift; | ||||
254 | $self->{cleanup} = shift if @_; | ||||
255 | return $self->{cleanup}; | ||||
256 | } | ||||
257 | |||||
258 | =item content_length | ||||
259 | |||||
260 | Returns the content-length for the body data if known. | ||||
261 | Returns -1 if the request is chunked. | ||||
262 | |||||
263 | =cut | ||||
264 | |||||
265 | sub content_length { | ||||
266 | return shift->{content_length}; | ||||
267 | } | ||||
268 | |||||
269 | =item content_type | ||||
270 | |||||
271 | Returns the content-type of the body data. | ||||
272 | |||||
273 | =cut | ||||
274 | |||||
275 | sub content_type { | ||||
276 | return shift->{content_type}; | ||||
277 | } | ||||
278 | |||||
279 | =item init | ||||
280 | |||||
281 | return self. | ||||
282 | |||||
283 | =cut | ||||
284 | |||||
285 | sub init { | ||||
286 | return $_[0]; | ||||
287 | } | ||||
288 | |||||
289 | =item length | ||||
290 | |||||
291 | Returns the total length of data we expect to read if known. | ||||
292 | In the case of a chunked request, returns the amount of data | ||||
293 | read so far. | ||||
294 | |||||
295 | =cut | ||||
296 | |||||
297 | sub length { | ||||
298 | return shift->{length}; | ||||
299 | } | ||||
300 | |||||
301 | =item trailing_headers | ||||
302 | |||||
303 | If a chunked request body had trailing headers, trailing_headers will | ||||
304 | return an HTTP::Headers object populated with those headers. | ||||
305 | |||||
306 | =cut | ||||
307 | |||||
308 | sub trailing_headers { | ||||
309 | return shift->{trailing_headers}; | ||||
310 | } | ||||
311 | |||||
312 | =item spin | ||||
313 | |||||
314 | Abstract method to spin the io handle. | ||||
315 | |||||
316 | =cut | ||||
317 | |||||
318 | sub spin { | ||||
319 | Carp::croak('Define abstract method spin() in implementation'); | ||||
320 | } | ||||
321 | |||||
322 | =item state | ||||
323 | |||||
324 | Returns the current state of the parser. | ||||
325 | |||||
326 | =cut | ||||
327 | |||||
328 | sub state { | ||||
329 | my $self = shift; | ||||
330 | $self->{state} = shift if @_; | ||||
331 | return $self->{state}; | ||||
332 | } | ||||
333 | |||||
334 | =item param | ||||
335 | |||||
336 | Get/set body parameters. | ||||
337 | |||||
338 | =cut | ||||
339 | |||||
340 | sub param { | ||||
341 | my $self = shift; | ||||
342 | |||||
343 | if ( @_ == 2 ) { | ||||
344 | |||||
345 | my ( $name, $value ) = @_; | ||||
346 | |||||
347 | if ( exists $self->{param}->{$name} ) { | ||||
348 | for ( $self->{param}->{$name} ) { | ||||
349 | $_ = [$_] unless ref($_) eq "ARRAY"; | ||||
350 | push( @$_, $value ); | ||||
351 | } | ||||
352 | } | ||||
353 | else { | ||||
354 | $self->{param}->{$name} = $value; | ||||
355 | } | ||||
356 | |||||
357 | push @{$self->{param_order}}, $name; | ||||
358 | } | ||||
359 | |||||
360 | return $self->{param}; | ||||
361 | } | ||||
362 | |||||
363 | =item upload | ||||
364 | |||||
365 | Get/set file uploads. | ||||
366 | |||||
367 | =cut | ||||
368 | |||||
369 | sub upload { | ||||
370 | my $self = shift; | ||||
371 | |||||
372 | if ( @_ == 2 ) { | ||||
373 | |||||
374 | my ( $name, $upload ) = @_; | ||||
375 | |||||
376 | if ( exists $self->{upload}->{$name} ) { | ||||
377 | for ( $self->{upload}->{$name} ) { | ||||
378 | $_ = [$_] unless ref($_) eq "ARRAY"; | ||||
379 | push( @$_, $upload ); | ||||
380 | } | ||||
381 | } | ||||
382 | else { | ||||
383 | $self->{upload}->{$name} = $upload; | ||||
384 | } | ||||
385 | } | ||||
386 | |||||
387 | return $self->{upload}; | ||||
388 | } | ||||
389 | |||||
390 | =item tmpdir | ||||
391 | |||||
392 | Specify a different path for temporary files. Defaults to the system temporary path. | ||||
393 | |||||
394 | =cut | ||||
395 | |||||
396 | sub tmpdir { | ||||
397 | my $self = shift; | ||||
398 | $self->{tmpdir} = shift if @_; | ||||
399 | return $self->{tmpdir}; | ||||
400 | } | ||||
401 | |||||
402 | =item param_order | ||||
403 | |||||
404 | Returns the array ref of the param keys in the order how they appeared on the body | ||||
405 | |||||
406 | =cut | ||||
407 | |||||
408 | sub param_order { | ||||
409 | return shift->{param_order}; | ||||
410 | } | ||||
411 | |||||
412 | =back | ||||
413 | |||||
414 | =head1 SUPPORT | ||||
415 | |||||
416 | Since its original creation this module has been taken over by the Catalyst | ||||
417 | development team. If you want to contribute patches, these will be your | ||||
418 | primary contact points: | ||||
419 | |||||
420 | IRC: | ||||
421 | |||||
422 | Join #catalyst-dev on irc.perl.org. | ||||
423 | |||||
424 | Mailing Lists: | ||||
425 | |||||
426 | http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev | ||||
427 | |||||
428 | =head1 AUTHOR | ||||
429 | |||||
430 | Christian Hansen, C<chansen@cpan.org> | ||||
431 | |||||
432 | Sebastian Riedel, C<sri@cpan.org> | ||||
433 | |||||
434 | Andy Grundman, C<andy@hybridized.org> | ||||
435 | |||||
436 | =head1 CONTRIBUTORS | ||||
437 | |||||
438 | Simon Elliott C<cpan@papercreatures.com> | ||||
439 | |||||
440 | Kent Fredric <kentnl@cpan.org> | ||||
441 | |||||
442 | Christian Walde | ||||
443 | |||||
444 | Torsten Raudssus <torsten@raudssus.de> | ||||
445 | |||||
446 | =head1 LICENSE | ||||
447 | |||||
448 | This library is free software. You can redistribute it and/or modify | ||||
449 | it under the same terms as perl itself. | ||||
450 | |||||
451 | =cut | ||||
452 | |||||
453 | 1 | 6µs | 1; |