10 'application/octet-stream' => 'HTTP::Body::OctetStream',
11 'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
12 'multipart/form-data' => 'HTTP::Body::MultiPart'
15 require HTTP::Body::OctetStream;
16 require HTTP::Body::UrlEncoded;
17 require HTTP::Body::MultiPart;
24 HTTP::Body - HTTP Body Parser
30 sub handler : method {
31 my ( $class, $r ) = @_;
33 my $content_type = $r->headers_in->get('Content-Type');
34 my $content_length = $r->headers_in->get('Content-Length');
36 my $body = HTTP::Body->new( $content_type, $content_length );
37 my $length = $content_length;
41 $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
43 $length -= length($buffer);
48 my $uploads = $body->upload; # hashref
49 my $params = $body->param; # hashref
50 my $body = $body->body; # IO::Handle
55 HTTP::Body parses chunks of HTTP POST data and supports
56 application/octet-stream, application/x-www-form-urlencoded, and
59 Chunked bodies are supported by not passing a length value to new().
61 It is currently used by L<Catalyst> to parse POST bodies.
65 When parsing multipart bodies, temporary files are created to store any
66 uploaded files. You must delete these temporary files yourself after
75 Constructor. Takes content type and content length as parameters,
76 returns a L<HTTP::Body> object.
81 my ( $class, $content_type, $content_length ) = @_;
84 Carp::croak( $class, '->new( $content_type, [ $content_length ] )' );
88 foreach my $supported ( keys %{$TYPES} ) {
89 if ( index( lc($content_type), $supported ) >= 0 ) {
94 my $body = $TYPES->{ $type || 'application/octet-stream' };
106 chunked => !defined $content_length,
107 content_length => defined $content_length ? $content_length : -1,
108 content_type => $content_type,
111 state => 'buffering',
115 bless( $self, $body );
122 Add string to internal buffer. Will call spin unless done. returns
123 length before adding self.
130 if ( $self->{chunked} ) {
131 $self->{chunk_buffer} .= $_[0];
133 while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
134 my $chunk_len = hex($1);
136 if ( $chunk_len == 0 ) {
138 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
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;
147 $self->{chunk_buffer} = '';
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};
154 # Make sure we have the whole chunk in the buffer (+CRLF)
155 if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
157 $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
159 # Pull chunk data out of chunk buffer into real buffer
160 $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
162 # Strip remaining CRLF
163 $self->{chunk_buffer} =~ s/^\x0D\x0A//;
165 $self->{length} += $chunk_len;
168 # Not enough data for this chunk, wait for more calls to add()
173 unless ( $self->{state} eq 'done' ) {
181 my $cl = $self->content_length;
183 if ( defined $_[0] ) {
184 $self->{length} += length( $_[0] );
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;
192 $self->{buffer} .= $_[0];
195 unless ( $self->state eq 'done' ) {
199 return ( $self->length - $cl );
204 accessor for the body.
210 $self->{body} = shift if @_;
211 return $self->{body};
216 Returns 1 if the request is chunked.
221 return shift->{chunked};
226 Returns the content-length for the body data if known.
227 Returns -1 if the request is chunked.
232 return shift->{content_length};
237 Returns the content-type of the body data.
242 return shift->{content_type};
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
264 return shift->{length};
267 =item trailing_headers
269 If a chunked request body had trailing headers, trailing_headers will
270 return an HTTP::Headers object populated with those headers.
274 sub trailing_headers {
275 return shift->{trailing_headers};
280 Abstract method to spin the io handle.
285 Carp::croak('Define abstract method spin() in implementation');
290 Returns the current state of the parser.
296 $self->{state} = shift if @_;
297 return $self->{state};
302 Get/set body parameters.
311 my ( $name, $value ) = @_;
313 if ( exists $self->{param}->{$name} ) {
314 for ( $self->{param}->{$name} ) {
315 $_ = [$_] unless ref($_) eq "ARRAY";
320 $self->{param}->{$name} = $value;
324 return $self->{param};
329 Get/set file uploads.
338 my ( $name, $upload ) = @_;
340 if ( exists $self->{upload}->{$name} ) {
341 for ( $self->{upload}->{$name} ) {
342 $_ = [$_] unless ref($_) eq "ARRAY";
343 push( @$_, $upload );
347 $self->{upload}->{$name} = $upload;
351 return $self->{upload};
358 Christian Hansen, C<ch@ngmedia.com>
360 Sebastian Riedel, C<sri@cpan.org>
362 Andy Grundman, C<andy@hybridized.org>
366 This library is free software. You can redistribute it and/or modify
367 it under the same terms as perl itself.