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;