lib/HTTP/Body.pm

   1 package HTTP::Body;
   2
   3 use strict;
   4
   5 use Carp       qw[ ];
   6
   7 our $VERSION = '1.06';
   8
   9 our $TYPES = {
  10     'application/octet-stream'          => 'HTTP::Body::OctetStream',
  11     'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
  12     'multipart/form-data'               => 'HTTP::Body::MultiPart',
  13     'multipart/related'                 => 'HTTP::Body::XFormsMultipart',
  14     'application/xml'                   => 'HTTP::Body::XForms'
  15 };
  16
  17 require HTTP::Body::OctetStream;
  18 require HTTP::Body::UrlEncoded;
  19 require HTTP::Body::MultiPart;
  20 require HTTP::Body::XFormsMultipart;
  21 require HTTP::Body::XForms;
  22
  23 use HTTP::Headers;
  24 use HTTP::Message;
  25
  26 =head1 NAME
  27
  28 HTTP::Body - HTTP Body Parser
  29
  30 =head1 SYNOPSIS
  31
  32     use HTTP::Body;
  33
  34     sub handler : method {
  35         my ( $class, $r ) = @_;
  36
  37         my $content_type   = $r->headers_in->get('Content-Type');
  38         my $content_length = $r->headers_in->get('Content-Length');
  39
  40         my $body   = HTTP::Body->new( $content_type, $content_length );
  41         my $length = $content_length;
  42
  43         while ( $length ) {
  44
  45             $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
  46
  47             $length -= length($buffer);
  48
  49             $body->add($buffer);
  50         }
  51
  52         my $uploads = $body->upload; # hashref
  53         my $params  = $body->param;  # hashref
  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/x-www-form-urlencoded, and
  61 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     foreach my $supported ( keys %{$TYPES} ) {
  94         if ( index( lc($content_type), $supported ) >= 0 ) {
  95             $type = $supported;
  96         }
  97     }
  98
  99     my $body = $TYPES->{ $type || 'application/octet-stream' };
 100
 101     my $self = {
 102         cleanup        => 0,
 103         buffer         => '',
 104         chunk_buffer   => '',
 105         body           => undef,
 106         chunked        => !defined $content_length,
 107         content_length => defined $content_length ? $content_length : -1,
 108         content_type   => $content_type,
 109         length         => 0,
 110         param          => {},
 111         state          => 'buffering',
 112         upload         => {},
 113         tmpdir         => File::Spec->tmpdir(),
 114     };
 115
 116     bless( $self, $body );
 117
 118     return $self->init;
 119 }
 120
 121 sub DESTROY {
 122     my $self = shift;
 123
 124     if ( $self->{cleanup} ) {
 125         my @temps = ();
 126         for my $upload ( values %{ $self->{upload} } ) {
 127             push @temps, map { $_->{tempname} || () }
 128                 ( ref $upload eq 'ARRAY' ? @{$upload} : $upload );
 129         }
 130
 131         unlink map { $_ } grep { -e $_ } @temps;
 132     }
 133 }
 134
 135 =item add
 136
 137 Add string to internal buffer. Will call spin unless done. returns
 138 length before adding self.
 139
 140 =cut
 141
 142 sub add {
 143     my $self = shift;
 144
 145     if ( $self->{chunked} ) {
 146         $self->{chunk_buffer} .= $_[0];
 147
 148         while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
 149             my $chunk_len = hex($1);
 150
 151             if ( $chunk_len == 0 ) {
 152                 # Strip chunk len
 153                 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 154
 155                 # End of data, there may be trailing headers
 156                 if (  my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) {
 157                     if ( my $message = HTTP::Message->parse( $headers ) ) {
 158                         $self->{trailing_headers} = $message->headers;
 159                     }
 160                 }
 161
 162                 $self->{chunk_buffer} = '';
 163
 164                 # Set content_length equal to the amount of data we read,
 165                 # so the spin methods can finish up.
 166                 $self->{content_length} = $self->{length};
 167             }
 168             else {
 169                 # Make sure we have the whole chunk in the buffer (+CRLF)
 170                 if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
 171                     # Strip chunk len
 172                     $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 173
 174                     # Pull chunk data out of chunk buffer into real buffer
 175                     $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
 176
 177                     # Strip remaining CRLF
 178                     $self->{chunk_buffer} =~ s/^\x0D\x0A//;
 179
 180                     $self->{length} += $chunk_len;
 181                 }
 182                 else {
 183                     # Not enough data for this chunk, wait for more calls to add()
 184                     return;
 185                 }
 186             }
 187
 188             unless ( $self->{state} eq 'done' ) {
 189                 $self->spin;
 190             }
 191         }
 192
 193         return;
 194     }
 195
 196     my $cl = $self->content_length;
 197
 198     if ( defined $_[0] ) {
 199         $self->{length} += length( $_[0] );
 200
 201         # Don't allow buffer data to exceed content-length
 202         if ( $self->{length} > $cl ) {
 203             $_[0] = substr $_[0], 0, $cl - $self->{length};
 204             $self->{length} = $cl;
 205         }
 206
 207         $self->{buffer} .= $_[0];
 208     }
 209
 210     unless ( $self->state eq 'done' ) {
 211         $self->spin;
 212     }
 213
 214     return ( $self->length - $cl );
 215 }
 216
 217 =item body
 218
 219 accessor for the body.
 220
 221 =cut
 222
 223 sub body {
 224     my $self = shift;
 225     $self->{body} = shift if @_;
 226     return $self->{body};
 227 }
 228
 229 =item chunked
 230
 231 Returns 1 if the request is chunked.
 232
 233 =cut
 234
 235 sub chunked {
 236     return shift->{chunked};
 237 }
 238
 239 =item cleanup
 240
 241 Set to 1 to enable automatic deletion of temporary files at DESTROY-time.
 242
 243 =cut
 244
 245 sub cleanup {
 246     my $self = shift;
 247     $self->{cleanup} = shift if @_;
 248     return $self->{cleanup};
 249 }
 250
 251 =item content_length
 252
 253 Returns the content-length for the body data if known.
 254 Returns -1 if the request is chunked.
 255
 256 =cut
 257
 258 sub content_length {
 259     return shift->{content_length};
 260 }
 261
 262 =item content_type
 263
 264 Returns the content-type of the body data.
 265
 266 =cut
 267
 268 sub content_type {
 269     return shift->{content_type};
 270 }
 271
 272 =item init
 273
 274 return self.
 275
 276 =cut
 277
 278 sub init {
 279     return $_[0];
 280 }
 281
 282 =item length
 283
 284 Returns the total length of data we expect to read if known.
 285 In the case of a chunked request, returns the amount of data
 286 read so far.
 287
 288 =cut
 289
 290 sub length {
 291     return shift->{length};
 292 }
 293
 294 =item trailing_headers
 295
 296 If a chunked request body had trailing headers, trailing_headers will
 297 return an HTTP::Headers object populated with those headers.
 298
 299 =cut
 300
 301 sub trailing_headers {
 302     return shift->{trailing_headers};
 303 }
 304
 305 =item spin
 306
 307 Abstract method to spin the io handle.
 308
 309 =cut
 310
 311 sub spin {
 312     Carp::croak('Define abstract method spin() in implementation');
 313 }
 314
 315 =item state
 316
 317 Returns the current state of the parser.
 318
 319 =cut
 320
 321 sub state {
 322     my $self = shift;
 323     $self->{state} = shift if @_;
 324     return $self->{state};
 325 }
 326
 327 =item param
 328
 329 Get/set body parameters.
 330
 331 =cut
 332
 333 sub param {
 334     my $self = shift;
 335
 336     if ( @_ == 2 ) {
 337
 338         my ( $name, $value ) = @_;
 339
 340         if ( exists $self->{param}->{$name} ) {
 341             for ( $self->{param}->{$name} ) {
 342                 $_ = [$_] unless ref($_) eq "ARRAY";
 343                 push( @$_, $value );
 344             }
 345         }
 346         else {
 347             $self->{param}->{$name} = $value;
 348         }
 349     }
 350
 351     return $self->{param};
 352 }
 353
 354 =item upload
 355
 356 Get/set file uploads.
 357
 358 =cut
 359
 360 sub upload {
 361     my $self = shift;
 362
 363     if ( @_ == 2 ) {
 364
 365         my ( $name, $upload ) = @_;
 366
 367         if ( exists $self->{upload}->{$name} ) {
 368             for ( $self->{upload}->{$name} ) {
 369                 $_ = [$_] unless ref($_) eq "ARRAY";
 370                 push( @$_, $upload );
 371             }
 372         }
 373         else {
 374             $self->{upload}->{$name} = $upload;
 375         }
 376     }
 377
 378     return $self->{upload};
 379 }
 380
 381 =item tmpdir
 382
 383 Specify a different path for temporary files.  Defaults to the system temporary path.
 384
 385 =cut
 386
 387 sub tmpdir {
 388     my $self = shift;
 389     $self->{tmpdir} = shift if @_;
 390     return $self->{tmpdir};
 391 }
 392
 393 =back
 394
 395 =head1 AUTHOR
 396
 397 Christian Hansen, C<ch@ngmedia.com>
 398
 399 Sebastian Riedel, C<sri@cpan.org>
 400
 401 Andy Grundman, C<andy@hybridized.org>
 402
 403 =head1 LICENSE
 404
 405 This library is free software. You can redistribute it and/or modify
 406 it under the same terms as perl itself.
 407
 408 =cut
 409
 410 1;