lib/HTTP/Body.pm

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