1.00
- Added support for chunked requests if no $length value is passed to new().
+ - Added support for XForms submissions. (Daniel Ruoso)
- Fixed urlencoded parser to handle spaces after semicolons and equal signs
in the value. (Tom Heady, http://rt.cpan.org/Ticket/Display.html?id=31055)
- Fixed multipart test to properly clean up temporary files.
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;
if ( exists $part->{filename} ) {
if ( $part->{filename} ne "" ) {
- $part->{fh}->close;
+ $part->{fh}->close if defined $part->{fh};
delete @{$part}{qw[ data done fh ]};
--- /dev/null
+package HTTP::Body::XForms;
+
+use strict;
+use base 'HTTP::Body';
+use bytes;
+
+use File::Temp 0.14;
+
+=head1 NAME
+
+HTTP::Body::XForms - HTTP Body XForms Parser
+
+=head1 SYNOPSIS
+
+ use HTTP::Body::XForms;
+
+=head1 DESCRIPTION
+
+HTTP Body XForms Parser. This module parses single part XForms
+submissions, which are identifiable by the content-type
+application/xml. The XML is stored unparsed on the parameter
+XForms:Model.
+
+=head1 METHODS
+
+=over 4
+
+=item spin
+
+This method is overwrited to set the param XForms:Model with
+the buffer content.
+
+=cut
+
+sub spin {
+ my $self = shift;
+
+ $self->param( 'XForms:Model', $self->{buffer} );
+
+ $self->{buffer} = '';
+ $self->{state} = 'done';
+
+ return $self->SUPER::init();
+}
+
+=back
+
+=head1 AUTHOR
+
+Daniel Ruoso, C<daniel@ruoso.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::XFormsMultipart;
+
+use strict;
+use base 'HTTP::Body::MultiPart';
+use bytes;
+
+use IO::File;
+use File::Temp 0.14;
+
+=head1 NAME
+
+HTTP::Body::XFormsMultipart - HTTP Body XForms multipart/related submission Parser
+
+=head1 SYNOPSIS
+
+ use HTTP::Body::XForms;
+
+=head1 DESCRIPTION
+
+HTTP Body XForms submission Parser. Inherits HTTP::Body::MultiPart.
+
+This body type is used to parse XForms submission. In this case, the
+XML part that contains the model is indicated by the start attribute
+in the content-type. The XML content is stored unparsed on the
+parameter XForms:Model.
+
+=head1 METHODS
+
+=over 4
+
+=item init
+
+This function is overrided to detect the start part of the
+multipart/related post.
+
+=cut
+
+sub init {
+ my $self = shift;
+ $self->SUPER::init(@_);
+ unless ( $self->content_type =~ /start=\"?\<?([^\"\>;,]+)\>?\"?/ ) {
+ my $content_type = $self->content_type;
+ Carp::croak( "Invalid boundary in content_type: '$content_type'" );
+ }
+
+ $self->{start} = $1;
+
+ return $self;
+}
+
+=item start
+
+Defines the start part of the multipart/related body.
+
+=cut
+
+sub start {
+ return shift->{start};
+}
+
+=item handler
+
+This function is overrided to differ the start part, which should be
+set as the XForms:Model param if its content type is application/xml.
+
+=cut
+
+sub handler {
+ my ( $self, $part ) = @_;
+
+ my $contentid = $part->{headers}{'Content-ID'};
+ $contentid =~ s/^.*[\<\"]//;
+ $contentid =~ s/[\>\"].*$//;
+
+ if ( $contentid eq $self->start ) {
+ $part->{name} = 'XForms:Model';
+ }
+ elsif ( defined $contentid ) {
+ $part->{name} = $contentid;
+ $part->{filename} = $contentid;
+ }
+
+ return $self->SUPER::handler($part);
+}
+
+=back
+
+=head1 AUTHOR
+
+Daniel Ruoso C<daniel@ruoso.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
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+use Cwd;
+use HTTP::Body;
+use File::Spec::Functions;
+use IO::File;
+use YAML;
+
+my $path = catdir( getcwd(), 't', 'data', 'xforms' );
+
+for ( my $i = 1; $i <= 2; $i++ ) {
+
+ my $test = sprintf( "%.3d", $i );
+ 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'} );
+
+ binmode $content, ':raw';
+
+ while ( $content->read( my $buffer, 1024 ) ) {
+ $body->add($buffer);
+ }
+
+ # Save tempnames for later deletion
+ my @temps;
+
+ for my $field ( keys %{ $body->upload } ) {
+
+ my $value = $body->upload->{$field};
+
+ for ( ( ref($value) eq 'ARRAY' ) ? @{$value} : $value ) {
+ push @temps, delete $_->{tempname};
+ }
+ }
+
+ is_deeply( $body->body, $results->{body}, "$test XForms body" );
+ is_deeply( $body->param, $results->{param}, "$test XForms param" );
+ is_deeply( $body->upload, $results->{upload}, "$test XForms upload" );
+ if ( $body->isa('HTTP::Body::XFormsMultipart') ) {
+ cmp_ok( $body->start, 'eq', $results->{start}, "$test XForms start" );
+ }
+ else {
+ ok( 1, "$test XForms start" );
+ }
+ cmp_ok( $body->state, 'eq', 'done', "$test XForms state" );
+ cmp_ok( $body->length, '==', $headers->{'Content-Length'}, "$test XForms length" );
+
+ # Clean up temp files created
+ unlink map { $_ } grep { defined $_ && -e $_ } @temps;
+}
--- /dev/null
+------------0xKhTmLbOuNdArY\r
+Content-ID: <asdfg@asdfg.com>\r
+\r
+<model><data1>asdfg</data1><data2>asdfg</data2></model>\r
+------------0xKhTmLbOuNdArY\r
+Content-ID: <qwert@qwerty.com>\r
+\r
+Attachment file 1\r
+------------0xKhTmLbOuNdArY\r
+Content-ID: <zxcvb@zxcvb.com>\r
+\r
+Attachment file 2\r
+------------0xKhTmLbOuNdArY--\r
--- /dev/null
+---
+Content-Length: 313
+Content-Type: multipart/related; boundary=----------0xKhTmLbOuNdArY; start=<asdfg@asdfg.com>
+User-Agent: 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en) AppleWebKit/312.1 (KHTML, like Gecko) Safari/312'
--- /dev/null
+---
+body: ~
+start: asdfg@asdfg.com
+param:
+ XForms:Model: <model><data1>asdfg</data1><data2>asdfg</data2></model>
+upload:
+ qwert@qwerty.com:
+ filename: qwert@qwerty.com
+ headers:
+ Content-ID: <qwert@qwerty.com>
+ name: qwert@qwerty.com
+ size: 17
+ zxcvb@zxcvb.com:
+ filename: zxcvb@zxcvb.com
+ headers:
+ Content-ID: <zxcvb@zxcvb.com>
+ name: zxcvb@zxcvb.com
+ size: 17
--- /dev/null
+<model><data1>asdfg</data1><data2>asdfg</data2></model>
\ No newline at end of file
--- /dev/null
+---
+Content-Length: 55
+Content-Type: application/xml
+User-Agent: 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en) AppleWebKit/312.1 (KHTML, like Gecko) Safari/312'
--- /dev/null
+---
+body: ~
+param:
+ XForms:Model: <model><data1>asdfg</data1><data2>asdfg</data2></model>
+upload: {}