This file documents the revision history for Perl extension HTTP::Body.
-0.8
- - Major refactor...
+0.9
+ - Small performance tweaks to urlencoded parser.
+
+0.8 2007-03-23 18:40:00
+ - Some browsers such as MSIE send extra data after the body content. We now
+ properly ignore anything beyond Content-Length.
0.7 2007-03-23 10:00:00
- Fixed parsing an empty (zero-length) file using multipart.
--- /dev/null
+Changes
+lib/HTTP/Body.pm
+lib/HTTP/Body/MultiPart.pm
+lib/HTTP/Body/OctetStream.pm
+lib/HTTP/Body/UrlEncoded.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/01use.t
+t/02pod.t
+t/03podcoverage.t
+t/04multipart.t
+t/05urlencoded.t
+t/06octetstream.t
+t/data/multipart/001-content.dat
+t/data/multipart/001-headers.yml
+t/data/multipart/001-results.yml
+t/data/multipart/002-content.dat
+t/data/multipart/002-headers.yml
+t/data/multipart/002-results.yml
+t/data/multipart/003-content.dat
+t/data/multipart/003-headers.yml
+t/data/multipart/003-results.yml
+t/data/multipart/004-content.dat
+t/data/multipart/004-headers.yml
+t/data/multipart/004-results.yml
+t/data/multipart/005-content.dat
+t/data/multipart/005-headers.yml
+t/data/multipart/005-results.yml
+t/data/multipart/006-content.dat
+t/data/multipart/006-headers.yml
+t/data/multipart/006-results.yml
+t/data/multipart/007-content.dat
+t/data/multipart/007-headers.yml
+t/data/multipart/007-results.yml
+t/data/multipart/008-content.dat
+t/data/multipart/008-headers.yml
+t/data/multipart/008-results.yml
+t/data/multipart/009-content.dat
+t/data/multipart/009-headers.yml
+t/data/multipart/009-results.yml
+t/data/multipart/010-content.dat
+t/data/multipart/010-headers.yml
+t/data/multipart/010-results.yml
+t/data/multipart/011-content.dat
+t/data/multipart/011-headers.yml
+t/data/multipart/011-results.yml
+t/data/octetstream/001-content.dat
+t/data/octetstream/001-headers.yml
+t/data/octetstream/001-results.dat
+t/data/octetstream/002-content.dat
+t/data/octetstream/002-headers.yml
+t/data/octetstream/002-results.dat
+t/data/urlencoded/001-content.dat
+t/data/urlencoded/001-headers.yml
+t/data/urlencoded/001-results.yml
+t/data/urlencoded/002-content.dat
+t/data/urlencoded/002-headers.yml
+t/data/urlencoded/002-results.yml
--- /dev/null
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: HTTP-Body
+version: 0.8
+version_from: lib/HTTP/Body.pm
+installdirs: site
+requires:
+ Carp: 0
+ File::Temp: 0.14
+ IO::File: 0
+ YAML: 0.39
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
NAME => 'HTTP::Body',
VERSION_FROM => 'lib/HTTP/Body.pm',
PREREQ_PM => {
- perl => 5.006,
- Carp => 0,
- Class::Accessor => 0,
- Class::Param => 0,
- File::Temp => '0.14',
- HTTP::Headers => 0,
- IO::File => 0,
- Params::Validate => 0,
- Scalar::Util => 0,
+ Carp => 0,
+ File::Temp => '0.14',
+ IO::File => 0,
+ YAML => '0.39'
}
);
package HTTP::Body;
use strict;
-use warnings;
-use base 'Class::Accessor::Fast';
-use Params::Validate qw[];
-use HTTP::Body::Context qw[];
-use HTTP::Body::Parser qw[];
+use Carp qw[ ];
-__PACKAGE__->mk_accessors( qw[ context parser ] );
+our $VERSION = 0.9;
-our $VERSION = 0.8;
+our $TYPES = {
+ 'application/octet-stream' => 'HTTP::Body::OctetStream',
+ 'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
+ 'multipart/form-data' => 'HTTP::Body::MultiPart'
+};
+
+require HTTP::Body::OctetStream;
+require HTTP::Body::UrlEncoded;
+require HTTP::Body::MultiPart;
=head1 NAME
=head1 SYNOPSIS
- use HTTP::Body;
+ use HTTP::Body;
- sub handler : method {
- my ( $class, $r ) = @_;
+ sub handler : method {
+ my ( $class, $r ) = @_;
+
+ my $content_type = $r->headers_in->get('Content-Type');
+ my $content_length = $r->headers_in->get('Content-Length');
+
+ my $body = HTTP::Body->new( $content_type, $content_length );
+ my $length = $content_length;
+
+ while ( $length ) {
+
+ $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
+
+ $length -= length($buffer);
+
+ $body->add($buffer);
+ }
+
+ my $uploads = $body->upload; # hashref
+ my $params = $body->param; # hashref
+ my $body = $body->body; # IO::Handle
+ }
- my $content_type = $r->headers_in->get('Content-Type');
- my $content_length = $r->headers_in->get('Content-Length');
-
- my $body = HTTP::Body->new( $content_type, $content_length );
- my $length = $content_length;
+=head1 DESCRIPTION
- while ( $length ) {
+HTTP::Body parses chunks of HTTP POST data and supports
+application/octet-stream, application/x-www-form-urlencoded, and
+multipart/form-data.
- $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
+It is currently used by L<Catalyst> to parse POST bodies.
- $length -= length($buffer);
-
- $body->add($buffer);
- }
-
- my $uploads = $body->upload; # hashref
- my $params = $body->param; # hashref
- my $body = $body->body; # IO::Handle
- }
+=head1 METHODS
-=head1 DESCRIPTION
+=over 4
-HTTP Body Parser.
+=item new
-=head1 METHODS
+Constructor. Takes content type and content length as parameters,
+returns a L<HTTP::Body> object.
-=over 4
+=cut
+
+sub new {
+ my ( $class, $content_type, $content_length ) = @_;
-=item new($hashref)
+ unless ( @_ == 3 ) {
+ 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 $body = $TYPES->{ $type || 'application/octet-stream' };
+
+ eval "require $body";
+
+ if ($@) {
+ die $@;
+ }
+
+ my $self = {
+ buffer => '',
+ body => undef,
+ content_length => $content_length,
+ content_type => $content_type,
+ length => 0,
+ param => {},
+ state => 'buffering',
+ upload => {}
+ };
+
+ bless( $self, $body );
+
+ return $self->init;
+}
-Constructor taking arugments as a hashref. Requires a C<context> argument which
-isa L<HTTP::Body::Context> object, and optional C<bufsize> (integer) and
-C<parser> (L<HTTP::Body::Parser>) arguments.
+=item add
-If called with two arguments C<($content_type, $content_length),
-L<HTTP::Body::Compat> will be used instead to maintain compatability with
-versions <= 0.6
+Add string to internal buffer. Will call spin unless done. returns
+length before adding self.
=cut
-sub new {
- my $class = ref $_[0] ? ref shift : shift;
+sub add {
+ my $self = shift;
- # bring in compat for old API <= 0.6
- if ( @_ == 2 ) {
- require HTTP::Body::Compat;
- return HTTP::Body::Compat->new(@_);
+ my $cl = $self->content_length;
+
+ if ( defined $_[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];
}
- my $params = Params::Validate::validate_with(
- params => \@_,
- spec => {
- bufsize => {
- type => Params::Validate::SCALAR,
- default => 65536,
- optional => 1
- },
- context => {
- type => Params::Validate::OBJECT,
- isa => 'HTTP::Body::Context',
- optional => 0
- },
- parser => {
- type => Params::Validate::OBJECT,
- isa => 'HTTP::Body::Parser',
- optional => 1
- }
- },
- called => "$class\::new"
- );
+ unless ( $self->state eq 'done' ) {
+ $self->spin;
+ }
- return bless( {}, $class )->initialize($params);
+ return ( $self->length - $cl );
}
-sub initialize {
- my ( $self, $params ) = @_;
-
- my $bufsize = delete $params->{bufsize} || 65536;
+=item body
- $params->{parser} ||= HTTP::Body::Parser->new(
- bufsize => $bufsize,
- context => $params->{context}
- );
+accessor for the body.
- while ( my ( $param, $value ) = each( %{ $params } ) ) {
- $self->$param($value);
- }
+=cut
+
+sub body {
+ my $self = shift;
+ $self->{body} = shift if @_;
+ return $self->{body};
+}
+
+=item buffer
+
+read only accessor for the buffer.
+
+=cut
+
+sub buffer {
+ return shift->{buffer};
+}
+
+=item content_length
+
+read only accessor for content length
+
+=cut
+
+sub content_length {
+ return shift->{content_length};
+}
+
+=item content_type
- return $self;
+ready only accessor for the content type
+
+=cut
+
+sub content_type {
+ return shift->{content_type};
+}
+
+=item init
+
+return self.
+
+=cut
+
+sub init {
+ return $_[0];
+}
+
+=item length
+
+read only accessor for body length.
+
+=cut
+
+sub length {
+ return shift->{length};
+}
+
+=item spin
+
+Abstract method to spin the io handle.
+
+=cut
+
+sub spin {
+ Carp::croak('Define abstract method spin() in implementation');
+}
+
+=item state
+
+accessor for body state.
+
+=cut
+
+sub state {
+ my $self = shift;
+ $self->{state} = shift if @_;
+ return $self->{state};
}
-=item eos
+=item param
+
+accesor for http parameters.
=cut
-sub eos {
- return shift->parser->eos;
+sub param {
+ my $self = shift;
+
+ if ( @_ == 2 ) {
+
+ my ( $name, $value ) = @_;
+
+ if ( exists $self->{param}->{$name} ) {
+ for ( $self->{param}->{$name} ) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push( @$_, $value );
+ }
+ }
+ else {
+ $self->{param}->{$name} = $value;
+ }
+ }
+
+ return $self->{param};
}
-=item put
+=item upload
=cut
-sub put {
- return shift->parser->put(@_);
+sub upload {
+ my $self = shift;
+
+ if ( @_ == 2 ) {
+
+ my ( $name, $upload ) = @_;
+
+ if ( exists $self->{upload}->{$name} ) {
+ for ( $self->{upload}->{$name} ) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push( @$_, $upload );
+ }
+ }
+ else {
+ $self->{upload}->{$name} = $upload;
+ }
+ }
+
+ return $self->{upload};
}
=back
+=head1 BUGS
+
+Chunked requests are currently not supported.
+
=head1 AUTHOR
Christian Hansen, C<ch@ngmedia.com>
-This pod written by Ash Berlin, C<ash@cpan.org>.
+Sebastian Riedel, C<sri@cpan.org>
=head1 LICENSE
+++ /dev/null
-package HTTP::Body::Compat;
-
-use strict;
-use warnings;
-use base 'HTTP::Body';
-
-use Params::Validate qw[];
-use HTTP::Body::Context qw[];
-
-=head1 NAME
-
-HTTP::Body::Compat - Backwards compataible HTTP Body Parser for versions <= 0.6
-
-=head1 SYNOPSIS
-
- use HTTP::Body;
-
- sub handler : method {
- my ( $class, $r ) = @_;
-
- my $content_type = $r->headers_in->get('Content-Type');
- my $content_length = $r->headers_in->get('Content-Length');
-
- # Calling HTTP::Body->new this way will go into pre 0.7 compat mode
- my $body = HTTP::Body->new( $content_type, $content_length );
- my $length = $content_length;
-
- while ( $length ) {
-
- $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
-
- $length -= length($buffer);
-
- $body->add($buffer);
- }
-
- my $uploads = $body->upload; # hashref
- my $params = $body->param; # hashref
- my $body = $body->body; # IO::Handle
- }
-
-=head1 DESCRIPTION
-
-HTTP Body Parser.
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-Constructor. Takes content type and content length as parameters,
-returns a L<HTTP::Body::Compat> object.
-
-=cut
-
-sub new {
- my $class = ref $_[0] ? ref shift : shift;
- my ( $content_type, $content_length ) = Params::Validate::validate_with(
- params => \@_,
- spec => [
- {
- type => Params::Validate::SCALAR,
- optional => 0
- },
- {
- type => Params::Validate::SCALAR,
- optional => 0
- }
- ],
- called => "$class\::new"
- );
-
- my $context = HTTP::Body::Context->new(
- headers => {
- 'Content-Type' => $content_type,
- 'Content-Length' => $content_length
- }
- );
-
- return bless( {}, $class )->initialize( { context => $context } );
-}
-
-=item add
-
-Add string to internal buffer. Returns length before adding string.
-
-=cut
-
-sub add {
- my $self = shift;
-
- if ( defined $_[0] ) {
- $self->{length} += bytes::length $_[0];
- }
-
- $self->put(@_);
-
- if ( $self->length == $self->content_length ) {
- $self->eos;
- return 0;
- }
-
- return ( $self->length - $self->content_length );
-}
-
-=item body
-
-accessor for the body
-
-=cut
-
-sub body {
- return $_[0]->context->content;
-}
-
-sub buffer {
- return '';
-}
-
-=item content_length
-
-Read-only accessor for content legnth
-
-=cut
-
-sub content_length {
- return $_[0]->context->content_length;
-}
-
-=item content_type
-
-Read-only accessor for content type
-
-=cut
-
-sub content_type {
- return $_[0]->context->content_type;
-}
-
-sub length {
- return $_[0]->{length};
-}
-
-sub state {
- return 'done';
-}
-
-=item param
-
-Accessor for HTTP parameters
-
-=cut
-
-sub param {
- my $self = shift;
-
- if ( @_ == 2 ) {
- return $self->context->param->add(@_);
- }
-
- return scalar $self->context->param->as_hash;
-}
-
-=iteam upload
-
-=cut
-
-sub upload {
- my $self = shift;
-
- if ( @_ == 2 ) {
- return $self->context->upload->add(@_);
- }
-
- return scalar $self->context->upload->as_hash;
-}
-
-=back
-
-=head1 AUTHOR
-
-Christian Hansen, C<ch@ngmedia.com>
-
-This pod written by Ash Berlin, C<ash@cpan.org>.
-
-=head1 LICENSE
-
-This library is free software. You can redistribute it and/or modify
-it under the same terms as perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package HTTP::Body::Context;
-
-use strict;
-use warnings;
-use base 'Class::Accessor::Fast';
-
-use Class::Param qw[];
-use HTTP::Headers qw[];
-use Params::Validate qw[];
-use Scalar::Util qw[];
-
-__PACKAGE__->mk_accessors( qw[ content headers param upload ] );
-
-=head1 NAME
-
-HTTP::Body::Context
-
-=head1 METHODS
-
-=over
-
-=item new($hashref)
-
-Constructor. Takes the following arguments in a hashref:
-
-=over
-
-=item headers
-
-HTTP::Headers object, or an array or hashref
-
-=item param (optional)
-
-=item upload (optional)
-
-=back
-
-=cut
-
-sub new {
- my $class = ref $_[0] ? ref shift : shift;
- my $params = Params::Validate::validate_with(
- params => \@_,
- spec => {
- headers => {
- type => Params::Validate::ARRAYREF
- | Params::Validate::HASHREF
- | Params::Validate::OBJECT,
- optional => 0,
- callbacks => {
- 'isa HTTP::Headers instance' => sub {
- return 1 unless Scalar::Util::blessed( $_[0] );
- return $_[0]->isa('HTTP::Headers');
- }
- }
- },
- param => {
- type => Params::Validate::OBJECT,
- isa => 'Class::Param::Base',
- optional => 1
- },
- upload => {
- type => Params::Validate::OBJECT,
- isa => 'Class::Param::Base',
- optional => 1
- }
- },
- called => "$class\::new"
- );
-
- return bless( {}, $class )->initialize($params);
-}
-
-sub initialize {
- my ( $self, $params ) = @_;
-
- if ( ref $params->{headers} eq 'ARRAY' ) {
- $params->{headers} = HTTP::Headers->new( @{ $params->{headers} } );
- }
-
- if ( ref $params->{headers} eq 'HASH' ) {
- $params->{headers} = HTTP::Headers->new( %{ $params->{headers} } );
- }
-
- $params->{param} ||= Class::Param->new;
- $params->{upload} ||= Class::Param->new;
-
- while ( my ( $param, $value ) = each( %{ $params } ) ) {
- $self->$param($value);
- }
-
- return $self;
-}
-
-=item context_length
-
-=cut
-
-sub content_length {
- return shift->headers->content_length(@_);
-}
-
-=item content_type
-
-=cut
-
-sub content_type {
- return shift->headers->content_type(@_);
-}
-
-=item header
-
-=cut
-
-sub header {
- return shift->headers->header(@_);
-}
-
-=back
-
-=head1 AUTHOR
-
-Christian Hansen, C<ch@ngmedia.com>
-
-This pod written by Ash Berlin, C<ash@cpan.org>.
-
-=head1 LICENSE
-
-This library is free software. You can redistribute it and/or modify
-it under the same terms as perl itself.
-
-=cut
-
-1;
-
-__END__
-package HTTP::Body::Parser::MultiPart;
+package HTTP::Body::MultiPart;
use strict;
+use base 'HTTP::Body';
use bytes;
-use base 'HTTP::Body::Parser';
-use Carp qw[];
-use Errno qw[];
-use File::Temp qw[];
+use IO::File;
+use File::Temp 0.14;
-__PACKAGE__->mk_accessors( qw[ boundary status state ] );
+=head1 NAME
-sub initialize {
- my ( $self, $params ) = @_;
+HTTP::Body::MultiPart - HTTP Body Multipart Parser
- my $content_type = $params->{context}->header('Content-Type');
+=head1 SYNOPSIS
- unless ( $content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
- Carp::croak qq/Invalid boundary in content_type: '$content_type'/;
+ use HTTP::Body::Multipart;
+
+=head1 DESCRIPTION
+
+HTTP Body Multipart Parser.
+
+=head1 METHODS
+
+=over 4
+
+=item init
+
+=cut
+
+sub init {
+ my $self = shift;
+
+ unless ( $self->content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
+ my $content_type = $self->content_type;
+ Carp::croak("Invalid boundary in content_type: '$content_type'");
}
- $params->{boundary} = $1;
- $params->{state} = 'preamble';
+ $self->{boundary} = $1;
+ $self->{state} = 'preamble';
- return $self->SUPER::initialize($params);
+ return $self;
}
-sub parse {
+=item spin
+
+=cut
+
+sub spin {
my $self = shift;
-
- return if $self->state eq 'done';
while (1) {
}
else {
- Carp::croak qq/Unknown state: '$self->{state}'/;
+ Carp::croak('Unknown state');
}
}
}
+=item boundary
+
+=cut
+
+sub boundary {
+ return shift->{boundary};
+}
+
+=item boundary_begin
+
+=cut
+
sub boundary_begin {
- return "--" . $_[0]->boundary;
+ return "--" . shift->boundary;
}
+=item boundary_end
+
+=cut
+
sub boundary_end {
- return $_[0]->boundary_begin . "--";
+ return shift->boundary_begin . "--";
}
+=item crlf
+
+=cut
+
sub crlf {
return "\x0d\x0a";
}
+=item delimiter_begin
+
+=cut
+
sub delimiter_begin {
- return $_[0]->crlf . $_[0]->boundary_begin;
+ my $self = shift;
+ return $self->crlf . $self->boundary_begin;
}
+=item delimiter_end
+
+=cut
+
sub delimiter_end {
- return $_[0]->crlf . $_[0]->boundary_end;
+ my $self = shift;
+ return $self->crlf . $self->boundary_end;
}
+=item parse_preamble
+
+=cut
+
sub parse_preamble {
my $self = shift;
return 1;
}
+=item parse_boundary
+
+=cut
+
sub parse_boundary {
my $self = shift;
return 0;
}
+=item parse_header
+
+=cut
+
sub parse_header {
my $self = shift;
return 1;
}
+=item parse_body
+
+=cut
+
sub parse_body {
my $self = shift;
return 1;
}
+=item handler
+
+=cut
+
sub handler {
my ( $self, $part ) = @_;
if ($filename) {
- my $fh = File::Temp->new( UNLINK => 0,
- (defined $self->{tmpdir} ? ( DIR => $self->{tmpdir} ) : ())
- );
+ my $fh = File::Temp->new( UNLINK => 0 );
$part->{fh} = $fh;
$part->{tempname} = $fh->filename;
}
}
- if ( $part->{filename} && length $part->{data} ) {
-
- if ( $part->{done} || length $part->{data} >= $self->bufsize ) {
-
- my ( $r, $w, $s ) = ( length $part->{data}, 0, 0 );
-
- for ( $w = 0; $w < $r; $w += $s || 0 ) {
-
- $s = $part->{fh}->syswrite( $part->{data}, $r - $w, $w );
-
- Carp::croak qq/Failed to syswrite buffer to temporary file. Reason: $!./
- unless defined $s || $! == Errno::EINTR;
- }
-
- $part->{data} = '';
- }
+ if ( $part->{filename} && ( my $length = length( $part->{data} ) ) ) {
+ $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
}
if ( $part->{done} ) {
$part->{fh}->close;
- delete @{ $part }{qw[ data done fh ]};
+ delete @{$part}{qw[ data done fh ]};
- $self->context->upload->add( $part->{name} => $part );
+ $self->upload( $part->{name}, $part );
}
else {
- $self->context->param->add( $part->{name} => $part->{data} );
+ $self->param( $part->{name}, $part->{data} );
}
}
}
+=back
+
+=head1 AUTHOR
+
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify
+it under the same terms as perl itself.
+
+=cut
+
1;
--- /dev/null
+package HTTP::Body::OctetStream;
+
+use strict;
+use base 'HTTP::Body';
+use bytes;
+
+use File::Temp 0.14;
+
+=head1 NAME
+
+HTTP::Body::OctetStream - HTTP Body OctetStream Parser
+
+=head1 SYNOPSIS
+
+ use HTTP::Body::OctetStream;
+
+=head1 DESCRIPTION
+
+HTTP Body OctetStream Parser.
+
+=head1 METHODS
+
+=over 4
+
+=item spin
+
+=cut
+
+sub spin {
+ my $self = shift;
+
+ unless ( $self->body ) {
+ $self->body( File::Temp->new );
+ }
+
+ if ( my $length = length( $self->{buffer} ) ) {
+ $self->body->write( substr( $self->{buffer}, 0, $length, '' ), $length );
+ }
+
+ if ( $self->length == $self->content_length ) {
+ seek( $self->body, 0, 0 );
+ $self->state('done');
+ }
+}
+
+=back
+
+=head1 AUTHOR
+
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify
+it under the same terms as perl itself.
+
+=cut
+
+1;
+++ /dev/null
-package HTTP::Body::Parser;
-
-use strict;
-use warnings;
-use bytes;
-use base 'Class::Accessor::Fast';
-
-use Carp qw[];
-use Class::Param qw[];
-use HTTP::Headers qw[];
-use Params::Validate qw[];
-
-__PACKAGE__->mk_accessors( qw[ bufsize context seen_eos ] );
-
-our $PARSERS = { };
-
-sub register_parser {
- my ( $content_type, $parser ) = ( @_ == 2 ) ? @_[ 1, 0 ] : @_[ 1, 2 ];
-
- $PARSERS->{ $content_type } = $parser;
-
- eval "use prefork '$parser';";
-}
-
-__PACKAGE__->register_parser( 'application/octet-stream' => 'HTTP::Body::Parser::OctetStream' );
-__PACKAGE__->register_parser( 'application/x-www-form-urlencoded' => 'HTTP::Body::Parser::UrlEncoded' );
-__PACKAGE__->register_parser( 'multipart/form-data' => 'HTTP::Body::Parser::MultiPart' );
-
-=head1 NAME
-
-HTTP::Body::Parser
-
-=head1 METHODS
-
-=over 4
-
-=item new($hashref)
-
-Constructor.
-
-=cut
-
-sub new {
- my $class = ref $_[0] ? ref shift : shift;
- my $params = Params::Validate::validate_with(
- params => \@_,
- spec => {
- bufsize => {
- type => Params::Validate::SCALAR,
- default => 65536,
- optional => 1
- },
- context => {
- type => Params::Validate::OBJECT,
- isa => 'HTTP::Body::Context',
- optional => 0
- }
- },
- called => "$class\::new"
- );
-
- # subclass
- if ( $class ne __PACKAGE__ ) {
- return bless( {}, $class )->initialize($params);
- }
-
- # factory
- my $content_type = $params->{context}->content_type;
-
- Carp::croak qq/Mandatory header 'Content-Type' is missing from headers in context./
- unless defined $content_type;
-
- my $parser = $PARSERS->{ lc $content_type } || $PARSERS->{ 'application/octet-stream' };
-
- eval "require $parser;"
- or Carp::croak qq/Failed to load parser '$parser' for Content-Type '$content_type'. Reason '$@'/;
-
- return $parser->new($params);
-}
-
-sub initialize {
- my ( $self, $params ) = @_;
-
- $params->{buffer} = '';
- $params->{length} = 0;
- $params->{seen_eos} = 0;
-
- while ( my ( $param, $value ) = each( %{ $params } ) ) {
- $self->$param($value);
- }
-
- return $self;
-}
-
-sub buffer : lvalue {
- my $self = shift;
-
- if ( @_ ) {
- $self->{buffer} = $_[0];
- }
-
- $self->{buffer};
-}
-
-sub length : lvalue {
- my $self = shift;
-
- if ( @_ ) {
- $self->{length} = $_[0];
- }
-
- $self->{length};
-}
-
-sub eos {
- my $self = shift;
-
- $self->seen_eos(1);
-
- if ( $self->context->content_length ) {
-
- my $expected = $self->context->content_length;
- my $length = $self->length;
-
- if ( $length < $expected ) {
- Carp::croak qq/Truncated body. Expected $expected bytes, but only got $length bytes./;
- }
- }
-
- return $self->parse;
-}
-
-sub put {
- my $self = shift;
-
- if ( defined $_[0] ) {
- $self->length += bytes::length $_[0];
- $self->buffer .= $_[0];
- }
-
- return $self->parse;
-}
-
-=back
-
-=head1 AUTHOR
-
-Christian Hansen, C<ch@ngmedia.com>
-
-This pod written by Ash Berlin, C<ash@cpan.org>.
-
-=head1 LICENSE
-
-This library is free software. You can redistribute it and/or modify
-it under the same terms as perl itself.
-
-=cut
-
-1;
+++ /dev/null
-package HTTP::Body::Parser::OctetStream;
-
-use strict;
-use bytes;
-use base 'HTTP::Body::Parser';
-
-use Carp qw[];
-use Errno qw[];
-use File::Temp qw[];
-
-sub parse {
- my $self = shift;
-
- if ( $self->seen_eos && length $self->buffer || length $self->buffer >= $self->bufsize ) {
-
- unless ( $self->context->content ) {
- $self->context->content( File::Temp->new );
- }
-
- my ( $r, $w, $s ) = ( length $self->buffer, 0, 0 );
-
- for ( $w = 0; $w < $r; $w += $s || 0 ) {
-
- $s = $self->context->content->syswrite( $self->buffer, $r - $w, $w );
-
- Carp::croak qq/Failed to syswrite buffer to temporary file. Reason: $!./
- unless defined $s || $! == Errno::EINTR;
- }
-
- $self->buffer = '';
- }
-
- if ( $self->seen_eos && $self->context->content ) {
-
- sysseek( $self->context->content, 0, 0 )
- or Carp::croak qq/Failed to sysseek temporary handle./;
- }
-}
-
-1;
+++ /dev/null
-package HTTP::Body::Parser::UrlEncoded;
-
-use strict;
-use bytes;
-use base 'HTTP::Body::Parser';
-
-our $DECODE = qr/%([0-9a-fA-F]{2})/;
-
-sub parse {
- my $self = shift;
-
- return unless $self->seen_eos;
-
- for my $pair ( split( /[&;]/, $self->buffer ) ) {
-
- my ( $name, $value ) = split( /=/, $pair );
-
- next unless defined $name;
- next unless defined $value;
-
- $name =~ tr/+/ /;
- $name =~ s/$DECODE/chr(hex($1))/eg;
- $value =~ tr/+/ /;
- $value =~ s/$DECODE/chr(hex($1))/eg;
-
- $self->context->param->add( $name => $value );
- }
-
- $self->buffer = '';
-}
-
-1;
--- /dev/null
+package HTTP::Body::UrlEncoded;
+
+use strict;
+use base 'HTTP::Body';
+use bytes;
+
+our $DECODE = qr/%([0-9a-fA-F]{2})/;
+
+our %hex_chr;
+
+BEGIN {
+ for my $num ( 0 .. 255 ) {
+ my $h = sprintf "%02X", $num;
+ $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num;
+ }
+}
+
+=head1 NAME
+
+HTTP::Body::UrlEncoded - HTTP Body UrlEncoded Parser
+
+=head1 SYNOPSIS
+
+ use HTTP::Body::UrlEncoded;
+
+=head1 DESCRIPTION
+
+HTTP Body UrlEncoded Parser.
+
+=head1 METHODS
+
+=over 4
+
+=item spin
+
+=cut
+
+sub spin {
+ my $self = shift;
+
+ return unless $self->length == $self->content_length;
+
+ $self->{buffer} =~ tr/+/ /;
+
+ for my $pair ( split( /[&;]/, $self->{buffer} ) ) {
+
+ my ( $name, $value ) = split( /=/, $pair );
+
+ next unless defined $name;
+ next unless defined $value;
+
+ $name =~ s/$DECODE/$hex_chr{$1}/gs;
+ $value =~ s/$DECODE/$hex_chr{$1}/gs;
+
+ $self->param( $name, $value );
+ }
+
+ $self->{buffer} = '';
+ $self->{state} = 'done';
+}
+
+=back
+
+=head1 AUTHOR
+
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify
+it under the same terms as perl itself.
+
+=cut
+
+1;
use strict;
use warnings;
-use Test::More;
-
-eval { require YAML; import YAML 'LoadFile'; };
-if ($@) {
- eval { require YAML::Syck; import YAML::Syck 'LoadFile'; }
-}
-
-plan skip_all => 'Tests need YAML or YAML::Syck' if $@;
-
-plan tests => 55;
+use Test::More tests => 55;
use Cwd;
use HTTP::Body;
use File::Spec::Functions;
use IO::File;
+use YAML;
my $path = catdir( getcwd(), 't', 'data', 'multipart' );
for ( my $i = 1; $i <= 11; $i++ ) {
my $test = sprintf( "%.3d", $i );
- my $headers = LoadFile( catfile( $path, "$test-headers.yml" ) );
- my $results = LoadFile( catfile( $path, "$test-results.yml" ) );
+ my $headers = YAML::LoadFile( catfile( $path, "$test-headers.yml" ) );
+ my $results = YAML::LoadFile( catfile( $path, "$test-results.yml" ) );
my $content = IO::File->new( catfile( $path, "$test-content.dat" ) );
my $body = HTTP::Body->new( $headers->{'Content-Type'}, $headers->{'Content-Length'} );
use strict;
use warnings;
-use Test::More
-
-eval { require YAML; import YAML 'LoadFile'; };
-if ($@) {
- eval { require YAML::Syck; import YAML::Syck 'LoadFile'; }
-}
-
-plan skip_all => 'Tests need YAML or YAML::Syck' if $@;
-
-plan tests => 5;
+use Test::More tests => 10;
use Cwd;
use HTTP::Body;
use File::Spec::Functions;
use IO::File;
+use YAML;
my $path = catdir( getcwd(), 't', 'data', 'urlencoded' );
-for ( my $i = 1; $i <= 1; $i++ ) {
+for ( my $i = 1; $i <= 2; $i++ ) {
my $test = sprintf( "%.3d", $i );
my $headers = YAML::LoadFile( catfile( $path, "$test-headers.yml" ) );
use strict;
use warnings;
-use Test::More;
-
-eval { require YAML; import YAML 'LoadFile'; };
-if ($@) {
- eval { require YAML::Syck; import YAML::Syck 'LoadFile'; }
-}
-
-plan skip_all => 'Tests need YAML or YAML::Syck' if $@;
-
-plan tests => 8;
+use Test::More tests => 8;
use Cwd;
use HTTP::Body;
use File::Spec::Functions;
use IO::File;
+use YAML;
my $path = catdir( getcwd(), 't', 'data', 'octetstream' );
-text1=Ratione+accusamus+aspernatur+aliquam&text2=%C3%A5%C3%A4%C3%B6%C3%A5%C3%A4%C3%B6&select=A&select=B&textarea=Voluptatem+cumque+voluptate+sit+recusandae+at.+Et+quas+facere+rerum+unde+esse.+Sit+est+et+voluptatem.+Vel+temporibus+velit+neque+odio+non.%0D%0A%0D%0AMolestias+rerum+ut+sapiente+facere+repellendus+illo.+Eum+nulla+quis+aut.+Quidem+voluptas+vitae+ipsam+officia+voluptatibus+eveniet.+Aspernatur+cupiditate+ratione+aliquam+quidem+corrupti.+Eos+sunt+rerum+non+optio+culpa.
\ No newline at end of file
+text1=Ratione+accusamus+aspernatur+aliquam&text2=%C3%A5%C3%A4%C3%B6%C3%A5%C3%A4%C3%B6&select=A&select=B&textarea=Voluptatem+cumque+voluptate+sit+recusandae+at.+Et+quas+facere+rerum+unde+esse.+Sit+est+et+voluptatem.+Vel+temporibus+velit+neque+odio+non.%0D%0A%0D%0AMolestias+rerum+ut+sapiente+facere+repellendus+illo.+Eum+nulla+quis+aut.+Quidem+voluptas+vitae+ipsam+officia+voluptatibus+eveniet.+Aspernatur+cupiditate+ratione+aliquam+quidem+corrupti.+Eos+sunt+rerum+non+optio+culpa.&encoding=foo%3Dbar
\ No newline at end of file
---
-Content-Length: 480
+Content-Length: 499
Content-Type: application/x-www-form-urlencoded
User-Agent: 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en) AppleWebKit/312.1 (KHTML, like Gecko) Safari/312'
text1: Ratione accusamus aspernatur aliquam
text2: åäöåäö
textarea: "Voluptatem cumque voluptate sit recusandae at. Et quas facere rerum unde esse. Sit est et voluptatem. Vel temporibus velit neque odio non.\r\n\r\nMolestias rerum ut sapiente facere repellendus illo. Eum nulla quis aut. Quidem voluptas vitae ipsam officia voluptatibus eveniet. Aspernatur cupiditate ratione aliquam quidem corrupti. Eos sunt rerum non optio culpa."
+ encoding: foo=bar
upload: {}
--- /dev/null
+one=foo&two=bar\r
--- /dev/null
+---
+Content-Length: 15
+Content-Type: application/x-www-form-urlencoded
+User-Agent: 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; .NET CLR 1.1.4322)'
--- /dev/null
+---
+body: ~
+param:
+ one: foo
+ two: bar
+upload: {}
projects / catagits/HTTP-Body.git / commitdiff