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> to parse POST bodies.
  66
  67 =head1 NOTES
  68
  69 When parsing multipart bodies, temporary files are created to store any
  70 uploaded files.  You must delete these temporary files yourself after
  71 processing them, or set $body->cleanup(1) to automatically delete them
  72 at DESTROY-time.
  73
  74 =head1 METHODS
  75
  76 =over 4
  77
  78 =item new
  79
  80 Constructor. Takes content type and content length as parameters,
  81 returns a L<HTTP::Body> object.
  82
  83 =cut
  84
  85 sub new {
  86     my ( $class, $content_type, $content_length ) = @_;
  87
  88     unless ( @_ >= 2 ) {
  89         Carp::croak( $class, '->new( $content_type, [ $content_length ] )' );
  90     }
  91
  92     my $type;
  93     my $earliest_index;
  94     foreach my $supported ( keys %{$TYPES} ) {
  95         my $index = index( lc($content_type), $supported );
  96         if ($index >= 0 && (!defined $earliest_index || $index < $earliest_index)) {
  97             $type           = $supported;
  98             $earliest_index = $index;
  99         }
 100     }
 101
 102     my $body = $TYPES->{ $type || 'application/octet-stream' };
 103
 104     my $self = {
 105         cleanup        => 0,
 106         buffer         => '',
 107         chunk_buffer   => '',
 108         body           => undef,
 109         chunked        => !defined $content_length,
 110         content_length => defined $content_length ? $content_length : -1,
 111         content_type   => $content_type,
 112         length         => 0,
 113         param          => {},
 114         param_order    => [],
 115         state          => 'buffering',
 116         upload         => {},
 117         part_data      => {},
 118         tmpdir         => File::Spec->tmpdir(),
 119     };
 120
 121     bless( $self, $body );
 122
 123     return $self->init;
 124 }
 125
 126 sub DESTROY {
 127     my $self = shift;
 128
 129     if ( $self->{cleanup} ) {
 130         my @temps = ();
 131         for my $upload ( values %{ $self->{upload} } ) {
 132             push @temps, map { $_->{tempname} || () }
 133                 ( ref $upload eq 'ARRAY' ? @{$upload} : $upload );
 134         }
 135
 136         unlink map { $_ } grep { -e $_ } @temps;
 137     }
 138 }
 139
 140 =item add
 141
 142 Add string to internal buffer. Will call spin unless done. returns
 143 length before adding self.
 144
 145 =cut
 146
 147 sub add {
 148     my $self = shift;
 149
 150     if ( $self->{chunked} ) {
 151         $self->{chunk_buffer} .= $_[0];
 152
 153         while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
 154             my $chunk_len = hex($1);
 155
 156             if ( $chunk_len == 0 ) {
 157                 # Strip chunk len
 158                 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 159
 160                 # End of data, there may be trailing headers
 161                 if (  my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) {
 162                     if ( my $message = HTTP::Message->parse( $headers ) ) {
 163                         $self->{trailing_headers} = $message->headers;
 164                     }
 165                 }
 166
 167                 $self->{chunk_buffer} = '';
 168
 169                 # Set content_length equal to the amount of data we read,
 170                 # so the spin methods can finish up.
 171                 $self->{content_length} = $self->{length};
 172             }
 173             else {
 174                 # Make sure we have the whole chunk in the buffer (+CRLF)
 175                 if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
 176                     # Strip chunk len
 177                     $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 178
 179                     # Pull chunk data out of chunk buffer into real buffer
 180                     $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
 181
 182                     # Strip remaining CRLF
 183                     $self->{chunk_buffer} =~ s/^\x0D\x0A//;
 184
 185                     $self->{length} += $chunk_len;
 186                 }
 187                 else {
 188                     # Not enough data for this chunk, wait for more calls to add()
 189                     return;
 190                 }
 191             }
 192
 193             unless ( $self->{state} eq 'done' ) {
 194                 $self->spin;
 195             }
 196         }
 197
 198         return;
 199     }
 200
 201     my $cl = $self->content_length;
 202
 203     if ( defined $_[0] ) {
 204         $self->{length} += length( $_[0] );
 205
 206         # Don't allow buffer data to exceed content-length
 207         if ( $self->{length} > $cl ) {
 208             $_[0] = substr $_[0], 0, $cl - $self->{length};
 209             $self->{length} = $cl;
 210         }
 211
 212         $self->{buffer} .= $_[0];
 213     }
 214
 215     unless ( $self->state eq 'done' ) {
 216         $self->spin;
 217     }
 218
 219     return ( $self->length - $cl );
 220 }
 221
 222 =item body
 223
 224 accessor for the body.
 225
 226 =cut
 227
 228 sub body {
 229     my $self = shift;
 230     $self->{body} = shift if @_;
 231     return $self->{body};
 232 }
 233
 234 =item chunked
 235
 236 Returns 1 if the request is chunked.
 237
 238 =cut
 239
 240 sub chunked {
 241     return shift->{chunked};
 242 }
 243
 244 =item cleanup
 245
 246 Set to 1 to enable automatic deletion of temporary files at DESTROY-time.
 247
 248 =cut
 249
 250 sub cleanup {
 251     my $self = shift;
 252     $self->{cleanup} = shift if @_;
 253     return $self->{cleanup};
 254 }
 255
 256 =item content_length
 257
 258 Returns the content-length for the body data if known.
 259 Returns -1 if the request is chunked.
 260
 261 =cut
 262
 263 sub content_length {
 264     return shift->{content_length};
 265 }
 266
 267 =item content_type
 268
 269 Returns the content-type of the body data.
 270
 271 =cut
 272
 273 sub content_type {
 274     return shift->{content_type};
 275 }
 276
 277 =item init
 278
 279 return self.
 280
 281 =cut
 282
 283 sub init {
 284     return $_[0];
 285 }
 286
 287 =item length
 288
 289 Returns the total length of data we expect to read if known.
 290 In the case of a chunked request, returns the amount of data
 291 read so far.
 292
 293 =cut
 294
 295 sub length {
 296     return shift->{length};
 297 }
 298
 299 =item trailing_headers
 300
 301 If a chunked request body had trailing headers, trailing_headers will
 302 return an HTTP::Headers object populated with those headers.
 303
 304 =cut
 305
 306 sub trailing_headers {
 307     return shift->{trailing_headers};
 308 }
 309
 310 =item spin
 311
 312 Abstract method to spin the io handle.
 313
 314 =cut
 315
 316 sub spin {
 317     Carp::croak('Define abstract method spin() in implementation');
 318 }
 319
 320 =item state
 321
 322 Returns the current state of the parser.
 323
 324 =cut
 325
 326 sub state {
 327     my $self = shift;
 328     $self->{state} = shift if @_;
 329     return $self->{state};
 330 }
 331
 332 =item param
 333
 334 Get/set body parameters.
 335
 336 =cut
 337
 338 sub param {
 339     my $self = shift;
 340
 341     if ( @_ == 2 ) {
 342
 343         my ( $name, $value ) = @_;
 344
 345         if ( exists $self->{param}->{$name} ) {
 346             for ( $self->{param}->{$name} ) {
 347                 $_ = [$_] unless ref($_) eq "ARRAY";
 348                 push( @$_, $value );
 349             }
 350         }
 351         else {
 352             $self->{param}->{$name} = $value;
 353         }
 354
 355         push @{$self->{param_order}}, $name;
 356     }
 357
 358     return $self->{param};
 359 }
 360
 361 =item upload
 362
 363 Get/set file uploads.
 364
 365 =cut
 366
 367 sub upload {
 368     my $self = shift;
 369
 370     if ( @_ == 2 ) {
 371
 372         my ( $name, $upload ) = @_;
 373
 374         if ( exists $self->{upload}->{$name} ) {
 375             for ( $self->{upload}->{$name} ) {
 376                 $_ = [$_] unless ref($_) eq "ARRAY";
 377                 push( @$_, $upload );
 378             }
 379         }
 380         else {
 381             $self->{upload}->{$name} = $upload;
 382         }
 383     }
 384
 385     return $self->{upload};
 386 }
 387
 388 =item part_data
 389
 390 Just like 'param' but gives you a hash of the full data associated with the
 391 part in a multipart type POST/PUT.  Example:
 392
 393     {
 394       data => "test",
 395       done => 1,
 396       headers => {
 397         "Content-Disposition" => "form-data; name=\"arg2\"",
 398         "Content-Type" => "text/plain"
 399       },
 400       name => "arg2",
 401       size => 4
 402     }
 403
 404 =cut
 405
 406 sub part_data {
 407     my $self = shift;
 408
 409     if ( @_ == 2 ) {
 410
 411         my ( $name, $data ) = @_;
 412
 413         if ( exists $self->{part_data}->{$name} ) {
 414             for ( $self->{part_data}->{$name} ) {
 415                 $_ = [$_] unless ref($_) eq "ARRAY";
 416                 push( @$_, $data );
 417             }
 418         }
 419         else {
 420             $self->{part_data}->{$name} = $data;
 421         }
 422     }
 423
 424     return $self->{part_data};
 425 }
 426
 427 =item tmpdir
 428
 429 Specify a different path for temporary files.  Defaults to the system temporary path.
 430
 431 =cut
 432
 433 sub tmpdir {
 434     my $self = shift;
 435     $self->{tmpdir} = shift if @_;
 436     return $self->{tmpdir};
 437 }
 438
 439 =item param_order
 440
 441 Returns the array ref of the param keys in the order how they appeared on the body
 442
 443 =cut
 444
 445 sub param_order {
 446     return shift->{param_order};
 447 }
 448
 449 =back
 450
 451 =head1 SUPPORT
 452
 453 Since its original creation this module has been taken over by the Catalyst
 454 development team. If you want to contribute patches, these will be your
 455 primary contact points:
 456
 457 IRC:
 458
 459     Join #catalyst-dev on irc.perl.org.
 460
 461 Mailing Lists:
 462
 463     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
 464
 465 =head1 AUTHOR
 466
 467 Christian Hansen, C<chansen@cpan.org>
 468
 469 Sebastian Riedel, C<sri@cpan.org>
 470
 471 Andy Grundman, C<andy@hybridized.org>
 472
 473 =head1 CONTRIBUTORS
 474
 475 Simon Elliott C<cpan@papercreatures.com>
 476
 477 Kent Fredric <kentnl@cpan.org>
 478
 479 Christian Walde
 480
 481 Torsten Raudssus <torsten@raudssus.de>
 482
 483 =head1 LICENSE
 484
 485 This library is free software. You can redistribute it and/or modify
 486 it under the same terms as perl itself.
 487
 488 =cut
 489
 490 1;