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