lib/HTTP/Body.pm

   1 package HTTP::Body;
   2
   3 use strict;
   4
   5 use Carp       qw[ ];
   6
   7 our $VERSION = '1.04';
   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.
  72
  73 =head1 METHODS
  74
  75 =over 4
  76
  77 =item new
  78
  79 Constructor. Takes content type and content length as parameters,
  80 returns a L<HTTP::Body> object.
  81
  82 =cut
  83
  84 sub new {
  85     my ( $class, $content_type, $content_length ) = @_;
  86
  87     unless ( @_ >= 2 ) {
  88         Carp::croak( $class, '->new( $content_type, [ $content_length ] )' );
  89     }
  90
  91     my $type;
  92     foreach my $supported ( keys %{$TYPES} ) {
  93         if ( index( lc($content_type), $supported ) >= 0 ) {
  94             $type = $supported;
  95         }
  96     }
  97
  98     my $body = $TYPES->{ $type || 'application/octet-stream' };
  99
 100     eval "require $body";
 101
 102     if ($@) {
 103         die $@;
 104     }
 105
 106     my $self = {
 107         buffer         => '',
 108         chunk_buffer   => '',
 109         body           => undef,
 110         chunked        => !defined $content_length,
 111         content_length => defined $content_length ? $content_length : -1,
 112         content_type   => $content_type,
 113         length         => 0,
 114         param          => {},
 115         state          => 'buffering',
 116         upload         => {},
 117         tmpdir         => File::Spec->tmpdir(),
 118     };
 119
 120     bless( $self, $body );
 121
 122     return $self->init;
 123 }
 124
 125 =item add
 126
 127 Add string to internal buffer. Will call spin unless done. returns
 128 length before adding self.
 129
 130 =cut
 131
 132 sub add {
 133     my $self = shift;
 134
 135     if ( $self->{chunked} ) {
 136         $self->{chunk_buffer} .= $_[0];
 137
 138         while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
 139             my $chunk_len = hex($1);
 140
 141             if ( $chunk_len == 0 ) {
 142                 # Strip chunk len
 143                 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 144
 145                 # End of data, there may be trailing headers
 146                 if (  my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) {
 147                     if ( my $message = HTTP::Message->parse( $headers ) ) {
 148                         $self->{trailing_headers} = $message->headers;
 149                     }
 150                 }
 151
 152                 $self->{chunk_buffer} = '';
 153
 154                 # Set content_length equal to the amount of data we read,
 155                 # so the spin methods can finish up.
 156                 $self->{content_length} = $self->{length};
 157             }
 158             else {
 159                 # Make sure we have the whole chunk in the buffer (+CRLF)
 160                 if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
 161                     # Strip chunk len
 162                     $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
 163
 164                     # Pull chunk data out of chunk buffer into real buffer
 165                     $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
 166
 167                     # Strip remaining CRLF
 168                     $self->{chunk_buffer} =~ s/^\x0D\x0A//;
 169
 170                     $self->{length} += $chunk_len;
 171                 }
 172                 else {
 173                     # Not enough data for this chunk, wait for more calls to add()
 174                     return;
 175                 }
 176             }
 177
 178             unless ( $self->{state} eq 'done' ) {
 179                 $self->spin;
 180             }
 181         }
 182
 183         return;
 184     }
 185
 186     my $cl = $self->content_length;
 187
 188     if ( defined $_[0] ) {
 189         $self->{length} += length( $_[0] );
 190
 191         # Don't allow buffer data to exceed content-length
 192         if ( $self->{length} > $cl ) {
 193             $_[0] = substr $_[0], 0, $cl - $self->{length};
 194             $self->{length} = $cl;
 195         }
 196
 197         $self->{buffer} .= $_[0];
 198     }
 199
 200     unless ( $self->state eq 'done' ) {
 201         $self->spin;
 202     }
 203
 204     return ( $self->length - $cl );
 205 }
 206
 207 =item body
 208
 209 accessor for the body.
 210
 211 =cut
 212
 213 sub body {
 214     my $self = shift;
 215     $self->{body} = shift if @_;
 216     return $self->{body};
 217 }
 218
 219 =item chunked
 220
 221 Returns 1 if the request is chunked.
 222
 223 =cut
 224
 225 sub chunked {
 226     return shift->{chunked};
 227 }
 228
 229 =item content_length
 230
 231 Returns the content-length for the body data if known.
 232 Returns -1 if the request is chunked.
 233
 234 =cut
 235
 236 sub content_length {
 237     return shift->{content_length};
 238 }
 239
 240 =item content_type
 241
 242 Returns the content-type of the body data.
 243
 244 =cut
 245
 246 sub content_type {
 247     return shift->{content_type};
 248 }
 249
 250 =item init
 251
 252 return self.
 253
 254 =cut
 255
 256 sub init {
 257     return $_[0];
 258 }
 259
 260 =item length
 261
 262 Returns the total length of data we expect to read if known.
 263 In the case of a chunked request, returns the amount of data
 264 read so far.
 265
 266 =cut
 267
 268 sub length {
 269     return shift->{length};
 270 }
 271
 272 =item trailing_headers
 273
 274 If a chunked request body had trailing headers, trailing_headers will
 275 return an HTTP::Headers object populated with those headers.
 276
 277 =cut
 278
 279 sub trailing_headers {
 280     return shift->{trailing_headers};
 281 }
 282
 283 =item spin
 284
 285 Abstract method to spin the io handle.
 286
 287 =cut
 288
 289 sub spin {
 290     Carp::croak('Define abstract method spin() in implementation');
 291 }
 292
 293 =item state
 294
 295 Returns the current state of the parser.
 296
 297 =cut
 298
 299 sub state {
 300     my $self = shift;
 301     $self->{state} = shift if @_;
 302     return $self->{state};
 303 }
 304
 305 =item param
 306
 307 Get/set body parameters.
 308
 309 =cut
 310
 311 sub param {
 312     my $self = shift;
 313
 314     if ( @_ == 2 ) {
 315
 316         my ( $name, $value ) = @_;
 317
 318         if ( exists $self->{param}->{$name} ) {
 319             for ( $self->{param}->{$name} ) {
 320                 $_ = [$_] unless ref($_) eq "ARRAY";
 321                 push( @$_, $value );
 322             }
 323         }
 324         else {
 325             $self->{param}->{$name} = $value;
 326         }
 327     }
 328
 329     return $self->{param};
 330 }
 331
 332 =item upload
 333
 334 Get/set file uploads.
 335
 336 =cut
 337
 338 sub upload {
 339     my $self = shift;
 340
 341     if ( @_ == 2 ) {
 342
 343         my ( $name, $upload ) = @_;
 344
 345         if ( exists $self->{upload}->{$name} ) {
 346             for ( $self->{upload}->{$name} ) {
 347                 $_ = [$_] unless ref($_) eq "ARRAY";
 348                 push( @$_, $upload );
 349             }
 350         }
 351         else {
 352             $self->{upload}->{$name} = $upload;
 353         }
 354     }
 355
 356     return $self->{upload};
 357 }
 358
 359 =item tmpdir
 360
 361 Specify a different path for temporary files.  Defaults to the system temporary path.
 362
 363 =cut
 364
 365 sub tmpdir {
 366     my $self = shift;
 367     $self->{tmpdir} = shift if @_;
 368     return $self->{tmpdir};
 369 }
 370
 371 =back
 372
 373 =head1 AUTHOR
 374
 375 Christian Hansen, C<ch@ngmedia.com>
 376
 377 Sebastian Riedel, C<sri@cpan.org>
 378
 379 Andy Grundman, C<andy@hybridized.org>
 380
 381 =head1 LICENSE
 382
 383 This library is free software. You can redistribute it and/or modify
 384 it under the same terms as perl itself.
 385
 386 =cut
 387
 388 1;