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