Package: libnet-amazon-s3-perl
Version: 0.53-1
Severity: minor
Tags: patch
As seems to often be the case, attempts to use a library beyond its stated
capabilities results in discoveries of incomplete coding.
I do recognize there is a newer version of this library, however looking over
it appears to indicate similar business rules in this area.
Proposed feature changes to HTTPRequest.pm:
Methods
Old rule: permits DELETE, GET, HEAD, PUT
New rule: permits DELETE, GET, HEAD, PUT, POST
Sub-resources
Old rule: permits one of acl, torrent, location
New rule: permits one each of acl, lifecycle, location, logging, notification,
partNumber, policy, requestPayment, torrent, uploadId, uploads, versionId,
versioning, versions, website
Sample code:
sub initiateMultipartUpload
{
my $path = shift;
my $newUpload = Net::Amazon::S3::HTTPRequest->new({
s3 => $s3,
method => 'POST',
# $s3->_urlescape escapes dots and slashes, uri_escape_utf8 escapes
slashes. Why?
path => $config->path . uri_escape_utf8($path, '^A-Za-z0-9\-\._~\x2f') .
'?uploads'
});
my $newUploadReq = $newUpload->http_request;
#die $newUploadReq->as_string;
my $xpc = $s3->_send_request($newUploadReq);
# Amazon isn't returning a Content-Type for this request, so it likely won't
be parsed for us
$xpc = $s3->_xpc_of_content($xpc) if ( $xpc && !ref($xpc) );
return undef unless $xpc && !$s3->_remember_errors($xpc);
my $bucket = $xpc->findvalue("//s3:Bucket");
my $key = $xpc->findvalue("//s3:Key");
my $uploadID = $xpc->findvalue("//s3:UploadId");
return {
bucket => $bucket,
key => $key,
upload_id => $uploadID
};
}
Please note that perl is not my first language, I would be very suprised if
there were not issues with style or not doing things "the perl way"
-- System Information:
Debian Release: 6.0.6
APT prefers stable
APT policy: (500, 'stable')
Architecture: i386 (i686)
Kernel: Linux 2.6.21.7-2.fc8xen (SMP w/1 CPU core)
Locale: LANG=en_US.UTF-8, LC_CTYPE=en_US.UTF-8 (charmap=UTF-8)
Shell: /bin/sh linked to /bin/dash
Versions of packages libnet-amazon-s3-perl depends on:
ii libclass-accessor-perl 0.34-1 Perl module that automatically gen
ii libdata-stream-bulk-pe 0.07-1 N at a time iteration API
ii libdatetime-format-htt 0.39-1 Perl module for date conversion wi
ii libdatetime-format-iso 0.06-2 Perl module to parse ISO8601 date
ii libdigest-hmac-perl 1.02+dfsg-1 module for creating standard messa
ii libdigest-md5-file-per 0.07-1 Perl extension for getting MD5 sum
ii liblwp-useragent-deter 1.04-1 LWP useragent that retries errors
ii libmoose-perl 1.09-2 modern Perl object system framewor
ii libmoosex-strictconstr 0.10-1 Make your object constructors blow
ii libmoosex-types-dateti 0.03-1 Perl DateTime related constraints
ii libregexp-common-perl 2010010201-1 module with common regular express
ii liburi-perl 1.54-2 module to manipulate and access UR
ii libwww-perl 5.836-1 Perl HTTP/WWW client/server librar
ii libxml-libxml-perl 1.70.ds-1 Perl interface to the libxml2 libr
ii perl 5.10.1-17squeeze3 Larry Wall's Practical Extraction
libnet-amazon-s3-perl recommends no packages.
libnet-amazon-s3-perl suggests no packages.
-- no debconf information
*** /usr/share/perl5/Net/Amazon/S3/HTTPRequest-old.pm 2012-11-02 01:04:25.000000000 -0700
--- /usr/share/perl5/Net/Amazon/S3/HTTPRequest.pm 2012-11-02 18:17:15.000000000 -0700
***************
*** 10,16 ****
my $METADATA_PREFIX = 'x-amz-meta-';
my $AMAZON_HEADER_PREFIX = 'x-amz-';
! enum 'HTTPMethod' => qw(DELETE GET HEAD PUT);
has 's3' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 );
has 'method' => ( is => 'ro', isa => 'HTTPMethod', required => 1 );
--- 10,16 ----
my $METADATA_PREFIX = 'x-amz-meta-';
my $AMAZON_HEADER_PREFIX = 'x-amz-';
! enum 'HTTPMethod' => qw(DELETE GET HEAD PUT POST);
has 's3' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 );
has 'method' => ( is => 'ro', isa => 'HTTPMethod', required => 1 );
***************
*** 24,29 ****
--- 24,48 ----
__PACKAGE__->meta->make_immutable;
+ # list of sub-resources that must be included (if they are specified) in any cannonical string
+ %__PACKAGE__::sub_resources = (
+ 'acl' => 1,
+ 'lifecycle' => 1,
+ 'location' => 1,
+ 'logging' => 1,
+ 'notification' => 1,
+ 'partNumber' => 1,
+ 'policy' => 1,
+ 'requestPayment' => 1,
+ 'torrent' => 1,
+ 'uploadId' => 1,
+ 'uploads' => 1,
+ 'versionId' => 1,
+ 'versioning' => 1,
+ 'versions' => 1,
+ 'website' => 1
+ );
+
# make the HTTP::Request object
sub http_request {
my $self = shift;
***************
*** 134,150 ****
}
}
! # don't include anything after the first ? in the resource...
! $path =~ /^([^?]*)/;
$buf .= "/$1";
! # ...unless there is an acl or torrent parameter
! if ( $path =~ /[&?]acl($|=|&)/ ) {
! $buf .= '?acl';
! } elsif ( $path =~ /[&?]torrent($|=|&)/ ) {
! $buf .= '?torrent';
! } elsif ( $path =~ /[&?]location($|=|&)/ ) {
! $buf .= '?location';
}
return $buf;
--- 153,176 ----
}
}
! # include anything before the first ? in the resource by default
! $path =~ /^([^?]*)(\?(.*))?$/;
$buf .= "/$1";
! # any keys after the first ? must be checked in the "list of valid subresources",
! # then sorted before being added on to the location
! if ( $3 )
! {
! my %interesting_subresources = ();
! foreach my $subResr ( split(/&/, $3) ) {
! $subResr =~ /^([^=]+)(=|$)/;
! $interesting_subresources{$1} = $subResr if ( $__PACKAGE__::sub_resources{$1} );
! }
! my @subresource = ();
! foreach my $key ( sort keys %interesting_subresources ) {
! push(@subresource, $interesting_subresources{$key});
! }
! $buf .= '?' . join('&',@subresource) unless !@subresource;
}
return $buf;
