X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHTTP%2FBody.pm;h=12216d62118d61f633c1dc9c8238c08ac22ee934;hb=3debb7c03ca0bf95876fec1b62ec76026cce434a;hp=f0a75e109c8e3c49c49b405339c439bcf9e02f9f;hpb=17c3e9b317b5796dd437d5c2f8771db7365ec7b6;p=catagits%2FHTTP-Body.git diff --git a/lib/HTTP/Body.pm b/lib/HTTP/Body.pm index f0a75e1..12216d6 100644 --- a/lib/HTTP/Body.pm +++ b/lib/HTTP/Body.pm @@ -3,16 +3,26 @@ package HTTP::Body; use strict; use Carp qw[ ]; -use List::Util qw[ first ]; -our $VERSION = '0.01'; +our $VERSION = '1.04'; our $TYPES = { 'application/octet-stream' => 'HTTP::Body::OctetStream', 'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded', - 'multipart/form-data' => 'HTTP::Body::MultiPart' + 'multipart/form-data' => 'HTTP::Body::MultiPart', + 'multipart/related' => 'HTTP::Body::XFormsMultipart', + 'application/xml' => 'HTTP::Body::XForms' }; +require HTTP::Body::OctetStream; +require HTTP::Body::UrlEncoded; +require HTTP::Body::MultiPart; +require HTTP::Body::XFormsMultipart; +require HTTP::Body::XForms; + +use HTTP::Headers; +use HTTP::Message; + =head1 NAME HTTP::Body - HTTP Body Parser @@ -46,22 +56,45 @@ HTTP::Body - HTTP Body Parser =head1 DESCRIPTION -HTTP Body Parser. +HTTP::Body parses chunks of HTTP POST data and supports +application/octet-stream, application/x-www-form-urlencoded, and +multipart/form-data. + +Chunked bodies are supported by not passing a length value to new(). + +It is currently used by L to parse POST bodies. + +=head1 NOTES + +When parsing multipart bodies, temporary files are created to store any +uploaded files. You must delete these temporary files yourself after +processing them. =head1 METHODS -=over 4 +=over 4 + +=item new + +Constructor. Takes content type and content length as parameters, +returns a L object. =cut sub new { my ( $class, $content_type, $content_length ) = @_; - unless ( @_ == 3 ) { - Carp::croak( $class, '->new( $content_type, $content_length )' ); + unless ( @_ >= 2 ) { + Carp::croak( $class, '->new( $content_type, [ $content_length ] )' ); + } + + my $type; + foreach my $supported ( keys %{$TYPES} ) { + if ( index( lc($content_type), $supported ) >= 0 ) { + $type = $supported; + } } - my $type = first { index( lc($content_type), $_ ) >= 0 } keys %{$TYPES}; my $body = $TYPES->{ $type || 'application/octet-stream' }; eval "require $body"; @@ -72,13 +105,16 @@ sub new { my $self = { buffer => '', + chunk_buffer => '', body => undef, - content_length => $content_length, + chunked => !defined $content_length, + content_length => defined $content_length ? $content_length : -1, content_type => $content_type, length => 0, param => {}, state => 'buffering', - upload => {} + upload => {}, + tmpdir => File::Spec->tmpdir(), }; bless( $self, $body ); @@ -88,25 +124,90 @@ sub new { =item add +Add string to internal buffer. Will call spin unless done. returns +length before adding self. + =cut sub add { my $self = shift; + + if ( $self->{chunked} ) { + $self->{chunk_buffer} .= $_[0]; + + while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) { + my $chunk_len = hex($1); + + if ( $chunk_len == 0 ) { + # Strip chunk len + $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//; + + # End of data, there may be trailing headers + if ( my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) { + if ( my $message = HTTP::Message->parse( $headers ) ) { + $self->{trailing_headers} = $message->headers; + } + } + + $self->{chunk_buffer} = ''; + + # Set content_length equal to the amount of data we read, + # so the spin methods can finish up. + $self->{content_length} = $self->{length}; + } + else { + # Make sure we have the whole chunk in the buffer (+CRLF) + if ( length( $self->{chunk_buffer} ) >= $chunk_len ) { + # Strip chunk len + $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//; + + # Pull chunk data out of chunk buffer into real buffer + $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, ''; + + # Strip remaining CRLF + $self->{chunk_buffer} =~ s/^\x0D\x0A//; + + $self->{length} += $chunk_len; + } + else { + # Not enough data for this chunk, wait for more calls to add() + return; + } + } + + unless ( $self->{state} eq 'done' ) { + $self->spin; + } + } + + return; + } + + my $cl = $self->content_length; if ( defined $_[0] ) { - $self->{buffer} .= $_[0]; $self->{length} += length( $_[0] ); + + # Don't allow buffer data to exceed content-length + if ( $self->{length} > $cl ) { + $_[0] = substr $_[0], 0, $cl - $self->{length}; + $self->{length} = $cl; + } + + $self->{buffer} .= $_[0]; } unless ( $self->state eq 'done' ) { $self->spin; } - return ( $self->length - $self->content_length ); + return ( $self->length - $cl ); } =item body +accessor for the body. + =cut sub body { @@ -115,16 +216,21 @@ sub body { return $self->{body}; } -=item buffer +=item chunked + +Returns 1 if the request is chunked. =cut -sub buffer { - return shift->{buffer}; +sub chunked { + return shift->{chunked}; } =item content_length +Returns the content-length for the body data if known. +Returns -1 if the request is chunked. + =cut sub content_length { @@ -133,6 +239,8 @@ sub content_length { =item content_type +Returns the content-type of the body data. + =cut sub content_type { @@ -141,6 +249,8 @@ sub content_type { =item init +return self. + =cut sub init { @@ -149,14 +259,31 @@ sub init { =item length +Returns the total length of data we expect to read if known. +In the case of a chunked request, returns the amount of data +read so far. + =cut sub length { return shift->{length}; } +=item trailing_headers + +If a chunked request body had trailing headers, trailing_headers will +return an HTTP::Headers object populated with those headers. + +=cut + +sub trailing_headers { + return shift->{trailing_headers}; +} + =item spin +Abstract method to spin the io handle. + =cut sub spin { @@ -165,6 +292,8 @@ sub spin { =item state +Returns the current state of the parser. + =cut sub state { @@ -175,6 +304,8 @@ sub state { =item param +Get/set body parameters. + =cut sub param { @@ -200,6 +331,8 @@ sub param { =item upload +Get/set file uploads. + =cut sub upload { @@ -223,6 +356,18 @@ sub upload { return $self->{upload}; } +=item tmpdir + +Specify a different path for temporary files. Defaults to the system temporary path. + +=cut + +sub tmpdir { + my $self = shift; + $self->{tmpdir} = shift if @_; + return $self->{tmpdir}; +} + =back =head1 AUTHOR @@ -231,6 +376,8 @@ Christian Hansen, C Sebastian Riedel, C +Andy Grundman, C + =head1 LICENSE This library is free software. You can redistribute it and/or modify