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