0.4 2005-11-09 01:00:00
- Version bump to 0.4 so CPAN.pm installs the right version.
-0.03 2005-10-27 20:00:00
+0.3 2005-10-27 20:00:00
- removed use of List::Util first due to memory leakage.
http://rt.cpan.org/NoAuth/Bug.html?id=13891
0.2 2005-10-07
- fixed POD
-0.01 2005-09-07
+0.1 2005-09-07
- first release
NAME => 'HTTP::Body',
VERSION_FROM => 'lib/HTTP/Body.pm',
PREREQ_PM => {
- Carp => 0,
- File::Temp => '0.14',
- IO::File => 0,
- YAML => '0.39'
+ 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,
+ YAML => '0.39'
}
);
package HTTP::Body;
use strict;
+use warnings;
+use base 'Class::Accessor::Fast';
-use Carp qw[ ];
+use Params::Validate qw[];
+use HTTP::Body::Context qw[];
+use HTTP::Body::Parser qw[];
-our $VERSION = 0.6;
+__PACKAGE__->mk_accessors( qw[ context parser ] );
-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
-
-HTTP::Body - HTTP Body Parser
-
-=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');
-
- 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> object.
-
-=cut
+our $VERSION = 0.7;
sub new {
- my ( $class, $content_type, $content_length ) = @_;
-
- 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 $class = ref $_[0] ? ref shift : shift;
+
+ # bring in compat for old API <= 0.6
+ if ( @_ == 2 ) {
+ require HTTP::Body::Compat;
+ return HTTP::Body::Compat->new(@_);
}
- my $self = {
- buffer => '',
- body => undef,
- content_length => $content_length,
- content_type => $content_type,
- length => 0,
- param => {},
- state => 'buffering',
- upload => {}
- };
-
- bless( $self, $body );
+ 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"
+ );
- return $self->init;
+ return bless( {}, $class )->initialize($params);
}
-=item add
-
-Add string to internal buffer. Will call spin unless done. returns
-length before adding self.
-
-=cut
+sub initialize {
+ my ( $self, $params ) = @_;
+
+ my $bufsize = delete $params->{bufsize} || 65536;
-sub add {
- my $self = shift;
+ $params->{parser} ||= HTTP::Body::Parser->new(
+ bufsize => $bufsize,
+ context => $params->{context}
+ );
- if ( defined $_[0] ) {
- $self->{buffer} .= $_[0];
- $self->{length} += length( $_[0] );
+ while ( my ( $param, $value ) = each( %{ $params } ) ) {
+ $self->$param($value);
}
- unless ( $self->state eq 'done' ) {
- $self->spin;
- }
-
- return ( $self->length - $self->content_length );
-}
-
-=item body
-
-accessor for the body.
-
-=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
-
-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};
+ return $self;
}
-=item spin
-
-Abstract method to spin the io handle.
-
-=cut
-
-sub spin {
- Carp::croak('Define abstract method spin() in implementation');
+sub eos {
+ return shift->parser->eos;
}
-=item state
-
-accessor for body state.
-
-=cut
-
-sub state {
- my $self = shift;
- $self->{state} = shift if @_;
- return $self->{state};
+sub put {
+ return shift->parser->put(@_);
}
-=item param
-
-accesor for http parameters.
-
-=cut
-
-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 upload
-
-=cut
-
-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>
-
-Sebastian Riedel, C<sri@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::Compat;
+
+use strict;
+use warnings;
+use base 'HTTP::Body';
+
+use Params::Validate qw[];
+use HTTP::Body::Context qw[];
+
+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 } );
+}
+
+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 );
+}
+
+sub body {
+ return $_[0]->context->content;
+}
+
+sub buffer {
+ return '';
+}
+
+sub content_length {
+ return $_[0]->context->content_length;
+}
+
+sub content_type {
+ return $_[0]->context->content_type;
+}
+
+sub length {
+ return $_[0]->{length};
+}
+
+sub state {
+ return 'done';
+}
+
+sub param {
+ my $self = shift;
+
+ if ( @_ == 2 ) {
+ return $self->context->param->add(@_);
+ }
+
+ return scalar $self->context->param->as_hash;
+}
+
+sub upload {
+ my $self = shift;
+
+ if ( @_ == 2 ) {
+ return $self->context->upload->add(@_);
+ }
+
+ return scalar $self->context->upload->as_hash;
+}
+
+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 ] );
+
+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;
+}
+
+sub content_length {
+ return shift->headers->content_length(@_);
+}
+
+sub content_type {
+ return shift->headers->content_type(@_);
+}
+
+sub header {
+ return shift->headers->header(@_);
+}
+
+1;
+
+__END__
+++ /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' );
+
+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;
+}
+
+1;
-package HTTP::Body::MultiPart;
+package HTTP::Body::Parser::MultiPart;
use strict;
-use base 'HTTP::Body';
use bytes;
+use base 'HTTP::Body::Parser';
-use IO::File;
-use File::Temp 0.14;
+use Carp qw[];
+use Errno qw[];
+use File::Temp qw[];
-=head1 NAME
+__PACKAGE__->mk_accessors( qw[ boundary status state ] );
-HTTP::Body::MultiPart - HTTP Body Multipart Parser
+sub initialize {
+ my ( $self, $params ) = @_;
-=head1 SYNOPSIS
+ my $content_type = $params->{context}->header('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'");
+ unless ( $content_type =~ /boundary=\"?([^\";,]+)\"?/ ) {
+ Carp::croak qq/Invalid boundary in content_type: '$content_type'/;
}
- $self->{boundary} = $1;
- $self->{state} = 'preamble';
+ $params->{boundary} = $1;
+ $params->{state} = 'preamble';
- return $self;
+ return $self->SUPER::initialize($params);
}
-=item spin
-
-=cut
-
-sub spin {
+sub parse {
my $self = shift;
+
+ return if $self->state eq 'done';
while (1) {
}
else {
- Carp::croak('Unknown state');
+ Carp::croak qq/Unknown state: '$self->{state}'/;
}
}
}
-=item boundary
-
-=cut
-
-sub boundary {
- return shift->{boundary};
-}
-
-=item boundary_begin
-
-=cut
-
sub boundary_begin {
- return "--" . shift->boundary;
+ return "--" . $_[0]->boundary;
}
-=item boundary_end
-
-=cut
-
sub boundary_end {
- return shift->boundary_begin . "--";
+ return $_[0]->boundary_begin . "--";
}
-=item crlf
-
-=cut
-
sub crlf {
return "\x0d\x0a";
}
-=item delimiter_begin
-
-=cut
-
sub delimiter_begin {
- my $self = shift;
- return $self->crlf . $self->boundary_begin;
+ return $_[0]->crlf . $_[0]->boundary_begin;
}
-=item delimiter_end
-
-=cut
-
sub delimiter_end {
- my $self = shift;
- return $self->crlf . $self->boundary_end;
+ return $_[0]->crlf . $_[0]->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 ( $part->{filename} && ( my $length = length( $part->{data} ) ) ) {
- $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
+ 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->{done} ) {
$part->{fh}->close;
- delete @{$part}{qw[ data done fh ]};
+ delete @{ $part }{qw[ data done fh ]};
- $self->upload( $part->{name}, $part );
+ $self->context->upload->add( $part->{name} => $part );
}
else {
- $self->param( $part->{name}, $part->{data} );
+ $self->context->param->add( $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::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})/;
-
-=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;
-
- 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->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;
projects / catagits/HTTP-Body.git / commitdiff