| 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 | HTTP::Body::BEGIN@26 |
| 1 | 1 | 1 | 6.70ms | 7.35ms | HTTP::Body::BEGIN@25 |
| 1 | 1 | 1 | 18µs | 40µs | HTTP::Body::BEGIN@6 |
| 1 | 1 | 1 | 5µs | 5µs | HTTP::Body::BEGIN@8 |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::DESTROY |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::add |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::body |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::chunked |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::cleanup |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::content_length |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::content_type |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::init |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::length |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::new |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::param |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::param_order |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::spin |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::state |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::tmpdir |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::trailing_headers |
| 0 | 0 | 0 | 0s | 0s | HTTP::Body::upload |
| 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; |