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