lib/HTTP/Body.pm

   1 package HTTP::Body;
   2
   3 use strict;
   4
   5 use Carp       qw[ ];
   6
   7 our $TYPES = {
   8     'application/octet-stream'          => 'HTTP::Body::OctetStream',
   9     'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
  10     'multipart/form-data'               => 'HTTP::Body::MultiPart',
  11     'multipart/related'                 => 'HTTP::Body::XFormsMultipart',
  12     'application/xml'                   => 'HTTP::Body::XForms',
  13     'application/json'                  => 'HTTP::Body::OctetStream',
  14 };
  15
  16 require HTTP::Body::OctetStream;
  17 require HTTP::Body::UrlEncoded;
  18 require HTTP::Body::MultiPart;
  19 require HTTP::Body::XFormsMultipart;
  20 require HTTP::Body::XForms;
  21
  22 use HTTP::Headers;
  23 use HTTP::Message;
  24
  25 =head1 NAME
  26
  27 HTTP::Body - HTTP Body Parser
  28
  29 =head1 SYNOPSIS
  30
  31     use HTTP::Body;
  32
  33     sub handler : method {
  34         my ( $class, $r ) = @_;
  35
  36         my $content_type   = $r->headers_in->get('Content-Type');
  37         my $content_length = $r->headers_in->get('Content-Length');
  38
  39         my $body   = HTTP::Body->new( $content_type, $content_length );
  40         my $length = $content_length;
  41
  42         while ( $length ) {
  43
  44             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
  45
  46             $length -= length($buffer);
  47
  48             $body->add($buffer);
  49         }
  50
  51         my $uploads     = $body->upload;     # hashref
  52         my $params      = $body->param;      # hashref
  53         my $param_order = $body->param_order # arrayref
  54         my $body        = $body->body;       # IO::Handle
  55     }
  56
  57 =head1 DESCRIPTION
  58
  59 HTTP::Body parses chunks of HTTP POST data and supports
  60 application/octet-stream, application/json, application/x-www-form-urlencoded,
  61 and multipart/form-data.
  62
  63 Chunked bodies are supported by not passing a length value to new().
  64
  65 It is currently used by L<Catalyst>, L<Dancer>, L<Maypole>, L<Web::Simple> and
  66 L<Jedi>.
  67
  68 =head1 NOTES
  69
  70 When parsing multipart bodies, temporary files are created to store any
  71 uploaded files.  You must delete these temporary files yourself after
  72 processing them, or set $body->cleanup(1) to automatically delete them at
  73 DESTROY-time.
  74
  75 With version 1.23, we have changed the basic behavior of how temporary files
  76 are prepared for uploads.  The extension of the file is no longer transferred
  77 to the temporary file, the extension will always be C<.upload>.  We have also
  78 introduced variables that make it possible to set the behavior as required.
  79
  80 =over 4
  81
  82 =item $HTTP::Body::MultiPart::file_temp_suffix
  83
  84 This is the extension that is given to all multipart files. The default
  85 setting here is C<.upload>.  If you want the old behavior from before version
  86 1.23, simply undefine the value here.
  87
  88 =item $HTTP::Body::MultiPart::basename_regexp
  89
  90 This is the regexp used to determine out the file extension.  This is of
  91 course no longer necessary, unless you undefine
  92 C<HTTP::Body::MultiPart::file_temp_suffix>.
  93
  94 =item $HTTP::Body::MultiPart::file_temp_template
  95
  96 This gets passed through to the L<File::Temp> TEMPLATE parameter.  There is no
  97 special default in our module.
  98
  99 =item %HTTP::Body::MultiPart::file_temp_parameters
 100
 101 In this hash you can add up custom settings for the L<File::Temp> invokation.
 102 Those override every other setting.
 103
 104 =back
 105
 106 =head1 METHODS
 107
 108 =over 4
 109
 110 =item new
 111
 112 Constructor. Takes content type and content length as parameters,
 113 returns a L<HTTP::Body> object.
 114
 115 =cut
 116
 117 sub new {
 118     my ( $class, $content_type, $content_length ) = @_;
 119
 120     unless ( @_ >= 2 ) {
 121         Carp::croak( $class, '->new( $content_type, [ $content_length ] )' );
 122     }
 123
 124     my $type;
 125     my $earliest_index;
 126     foreach my $supported ( keys %{$TYPES} ) {
 127         my $index = index( lc($content_type), $supported );
 128         if ($index >= 0 && (!defined $earliest_index || $index < $earliest_index)) {
 129             $type           = $supported;
 130             $earliest_index = $index;
 131         }
 132     }
 133
 134     my $body = $TYPES->{ $type || 'application/octet-stream' };
 135
 136     my $self = {
 137         cleanup        => 0,
 138         buffer         => '',
 139         chunk_buffer   => '',
 140         body           => undef,
 141         chunked        => !defined $content_length,
 142         content_length => defined $content_length ? $content_length : -1,
 143         content_type   => $content_type,
 144         length         => 0,
 145         param          => {},
 146         param_order    => [],
 147         state          => 'buffering',
 148         upload         => {},
 149         part_data      => {},
 150         tmpdir         => File::Spec->tmpdir(),
 151     };
 152
 153     bless( $self, $body );
 154
 155     return $self->init;
 156 }
 157
 158 sub DESTROY {
 159     my $self = shift;
 160
 161     if ( $self->{cleanup} ) {
 162         my @temps = ();
 163         for my $upload ( values %{ $self->{upload} } ) {
 164             push @temps, map { $_->{tempname} || () }
 165                 ( ref $upload eq 'ARRAY' ? @{$upload} : $upload );
 166         }
 167
 168         unlink map { $_ } grep { -e $_ } @temps;
 169     }
 170 }
 171
 172 =item add
 173
 174 Add string to internal buffer. Will call spin unless done. returns
 175 length before adding self.
 176
 177 =cut
 178
 179 sub add {
 180     my $self = shift;
 181
 182     if ( $self->{chunked} ) {
 183         $self->{chunk_buffer} .= $_[0];
 184
 185         while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
 186             my $chunk_len = hex($1);
 187
 188             if ( $chunk_len == 0 ) {
 189                 # Strip chunk len
 190                 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 191
 192                 # End of data, there may be trailing headers
 193                 if (  my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) {
 194                     if ( my $message = HTTP::Message->parse( $headers ) ) {
 195                         $self->{trailing_headers} = $message->headers;
 196                     }
 197                 }
 198
 199                 $self->{chunk_buffer} = '';
 200
 201                 # Set content_length equal to the amount of data we read,
 202                 # so the spin methods can finish up.
 203                 $self->{content_length} = $self->{length};
 204             }
 205             else {
 206                 # Make sure we have the whole chunk in the buffer (+CRLF)
 207                 if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
 208                     # Strip chunk len
 209                     $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 210
 211                     # Pull chunk data out of chunk buffer into real buffer
 212                     $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
 213
 214                     # Strip remaining CRLF
 215                     $self->{chunk_buffer} =~ s/^\x0D\x0A//;
 216
 217                     $self->{length} += $chunk_len;
 218                 }
 219                 else {
 220                     # Not enough data for this chunk, wait for more calls to add()
 221                     return;
 222                 }
 223             }
 224
 225             unless ( $self->{state} eq 'done' ) {
 226                 $self->spin;
 227             }
 228         }
 229
 230         return;
 231     }
 232
 233     my $cl = $self->content_length;
 234
 235     if ( defined $_[0] ) {
 236         $self->{length} += length( $_[0] );
 237
 238         # Don't allow buffer data to exceed content-length
 239         if ( $self->{length} > $cl ) {
 240             $_[0] = substr $_[0], 0, $cl - $self->{length};
 241             $self->{length} = $cl;
 242         }
 243
 244         $self->{buffer} .= $_[0];
 245     }
 246
 247     unless ( $self->state eq 'done' ) {
 248         $self->spin;
 249     }
 250
 251     return ( $self->length - $cl );
 252 }
 253
 254 =item body
 255
 256 accessor for the body.
 257
 258 =cut
 259
 260 sub body {
 261     my $self = shift;
 262     $self->{body} = shift if @_;
 263     return $self->{body};
 264 }
 265
 266 =item chunked
 267
 268 Returns 1 if the request is chunked.
 269
 270 =cut
 271
 272 sub chunked {
 273     return shift->{chunked};
 274 }
 275
 276 =item cleanup
 277
 278 Set to 1 to enable automatic deletion of temporary files at DESTROY-time.
 279
 280 =cut
 281
 282 sub cleanup {
 283     my $self = shift;
 284     $self->{cleanup} = shift if @_;
 285     return $self->{cleanup};
 286 }
 287
 288 =item content_length
 289
 290 Returns the content-length for the body data if known.
 291 Returns -1 if the request is chunked.
 292
 293 =cut
 294
 295 sub content_length {
 296     return shift->{content_length};
 297 }
 298
 299 =item content_type
 300
 301 Returns the content-type of the body data.
 302
 303 =cut
 304
 305 sub content_type {
 306     return shift->{content_type};
 307 }
 308
 309 =item init
 310
 311 return self.
 312
 313 =cut
 314
 315 sub init {
 316     return $_[0];
 317 }
 318
 319 =item length
 320
 321 Returns the total length of data we expect to read if known.
 322 In the case of a chunked request, returns the amount of data
 323 read so far.
 324
 325 =cut
 326
 327 sub length {
 328     return shift->{length};
 329 }
 330
 331 =item trailing_headers
 332
 333 If a chunked request body had trailing headers, trailing_headers will
 334 return an HTTP::Headers object populated with those headers.
 335
 336 =cut
 337
 338 sub trailing_headers {
 339     return shift->{trailing_headers};
 340 }
 341
 342 =item spin
 343
 344 Abstract method to spin the io handle.
 345
 346 =cut
 347
 348 sub spin {
 349     Carp::croak('Define abstract method spin() in implementation');
 350 }
 351
 352 =item state
 353
 354 Returns the current state of the parser.
 355
 356 =cut
 357
 358 sub state {
 359     my $self = shift;
 360     $self->{state} = shift if @_;
 361     return $self->{state};
 362 }
 363
 364 =item param
 365
 366 Get/set body parameters.
 367
 368 =cut
 369
 370 sub param {
 371     my $self = shift;
 372
 373     if ( @_ == 2 ) {
 374
 375         my ( $name, $value ) = @_;
 376
 377         if ( exists $self->{param}->{$name} ) {
 378             for ( $self->{param}->{$name} ) {
 379                 $_ = [$_] unless ref($_) eq "ARRAY";
 380                 push( @$_, $value );
 381             }
 382         }
 383         else {
 384             $self->{param}->{$name} = $value;
 385         }
 386
 387         push @{$self->{param_order}}, $name;
 388     }
 389
 390     return $self->{param};
 391 }
 392
 393 =item upload
 394
 395 Get/set file uploads.
 396
 397 =cut
 398
 399 sub upload {
 400     my $self = shift;
 401
 402     if ( @_ == 2 ) {
 403
 404         my ( $name, $upload ) = @_;
 405
 406         if ( exists $self->{upload}->{$name} ) {
 407             for ( $self->{upload}->{$name} ) {
 408                 $_ = [$_] unless ref($_) eq "ARRAY";
 409                 push( @$_, $upload );
 410             }
 411         }
 412         else {
 413             $self->{upload}->{$name} = $upload;
 414         }
 415     }
 416
 417     return $self->{upload};
 418 }
 419
 420 =item part_data
 421
 422 Just like 'param' but gives you a hash of the full data associated with the
 423 part in a multipart type POST/PUT.  Example:
 424
 425     {
 426       data => "test",
 427       done => 1,
 428       headers => {
 429         "Content-Disposition" => "form-data; name=\"arg2\"",
 430         "Content-Type" => "text/plain"
 431       },
 432       name => "arg2",
 433       size => 4
 434     }
 435
 436 =cut
 437
 438 sub part_data {
 439     my $self = shift;
 440
 441     if ( @_ == 2 ) {
 442
 443         my ( $name, $data ) = @_;
 444
 445         if ( exists $self->{part_data}->{$name} ) {
 446             for ( $self->{part_data}->{$name} ) {
 447                 $_ = [$_] unless ref($_) eq "ARRAY";
 448                 push( @$_, $data );
 449             }
 450         }
 451         else {
 452             $self->{part_data}->{$name} = $data;
 453         }
 454     }
 455
 456     return $self->{part_data};
 457 }
 458
 459 =item tmpdir
 460
 461 Specify a different path for temporary files.  Defaults to the system temporary path.
 462
 463 =cut
 464
 465 sub tmpdir {
 466     my $self = shift;
 467     $self->{tmpdir} = shift if @_;
 468     return $self->{tmpdir};
 469 }
 470
 471 =item param_order
 472
 473 Returns the array ref of the param keys in the order how they appeared on the body
 474
 475 =cut
 476
 477 sub param_order {
 478     return shift->{param_order};
 479 }
 480
 481 =back
 482
 483 =head1 SUPPORT
 484
 485 Since its original creation this module has been taken over by the Catalyst
 486 development team. If you need general support using this module:
 487
 488 IRC:
 489
 490     Join #catalyst on irc.perl.org.
 491
 492 Mailing Lists:
 493
 494     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
 495
 496 If you want to contribute patches, these will be your
 497 primary contact points:
 498
 499 IRC:
 500
 501     Join #catalyst-dev on irc.perl.org.
 502
 503 Mailing Lists:
 504
 505     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
 506
 507 =head1 AUTHOR
 508
 509 Christian Hansen, C<chansen@cpan.org>
 510
 511 Sebastian Riedel, C<sri@cpan.org>
 512
 513 Andy Grundman, C<andy@hybridized.org>
 514
 515 =head1 CONTRIBUTORS
 516
 517 Simon Elliott C<cpan@papercreatures.com>
 518
 519 Kent Fredric C<kentnl@cpan.org>
 520
 521 Christian Walde C<walde.christian@gmail.com>
 522
 523 Torsten Raudssus C<torsten@raudssus.de>
 524
 525 =head1 LICENSE
 526
 527 This library is free software. You can redistribute it and/or modify
 528 it under the same terms as perl itself.
 529
 530 =cut
 531
 532 1;