r27494 - in /trunk/libnet-amazon-s3-perl: ./ bin/ debian/ examples/ lib/Net/Amazon/ lib/Net/Amazon/S3/ lib/Net/Amazon/S3/Client/ lib/Net/Amazon/S3/Request/ t/
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Sun Nov 30 16:03:19 UTC 2008
Author: gregoa
Date: Sun Nov 30 16:03:16 2008
New Revision: 27494
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=27494
Log:
New upstream release.
Added:
trunk/libnet-amazon-s3-perl/bin/
- copied from r27493, branches/upstream/libnet-amazon-s3-perl/current/bin/
trunk/libnet-amazon-s3-perl/examples/
- copied from r27493, branches/upstream/libnet-amazon-s3-perl/current/examples/
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Client/
- copied from r27493, branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Client/
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Client.pm
- copied unchanged from r27493, branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Client.pm
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/HTTPRequest.pm
- copied unchanged from r27493, branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/HTTPRequest.pm
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Request/
- copied from r27493, branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Request/
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Request.pm
- copied unchanged from r27493, branches/upstream/libnet-amazon-s3-perl/current/lib/Net/Amazon/S3/Request.pm
trunk/libnet-amazon-s3-perl/t/02client.t
- copied unchanged from r27493, branches/upstream/libnet-amazon-s3-perl/current/t/02client.t
Modified:
trunk/libnet-amazon-s3-perl/CHANGES
trunk/libnet-amazon-s3-perl/MANIFEST
trunk/libnet-amazon-s3-perl/META.yml
trunk/libnet-amazon-s3-perl/Makefile.PL
trunk/libnet-amazon-s3-perl/README
trunk/libnet-amazon-s3-perl/debian/changelog
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3.pm
trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Bucket.pm
trunk/libnet-amazon-s3-perl/t/01api.t
trunk/libnet-amazon-s3-perl/t/99-pod-coverage.t
Modified: trunk/libnet-amazon-s3-perl/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/CHANGES?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/CHANGES (original)
+++ trunk/libnet-amazon-s3-perl/CHANGES Sun Nov 30 16:03:16 2008
@@ -1,4 +1,10 @@
Revision history for Perl module Net::Amazon::S3:
+
+0.46 Mon Nov 24 08:53:18 GMT 2008
+ - refactor request creation into Net::Amazon::S3::Request
+ and many subclasses
+ - move to Moose
+ - add Net::Amazon::S3::Client and subclasses
0.45 Wed Aug 20 17:06:49 BST 2008
- make add_key, head_key etc. return all the headers, not
Modified: trunk/libnet-amazon-s3-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/MANIFEST?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/MANIFEST (original)
+++ trunk/libnet-amazon-s3-perl/MANIFEST Sun Nov 30 16:03:16 2008
@@ -1,10 +1,30 @@
+bin/s3cl
CHANGES
+examples/backup_cpan.pl
lib/Net/Amazon/S3.pm
lib/Net/Amazon/S3/Bucket.pm
+lib/Net/Amazon/S3/Client.pm
+lib/Net/Amazon/S3/Client/Bucket.pm
+lib/Net/Amazon/S3/Client/Object.pm
+lib/Net/Amazon/S3/HTTPRequest.pm
+lib/Net/Amazon/S3/Request.pm
+lib/Net/Amazon/S3/Request/CreateBucket.pm
+lib/Net/Amazon/S3/Request/DeleteBucket.pm
+lib/Net/Amazon/S3/Request/DeleteObject.pm
+lib/Net/Amazon/S3/Request/GetBucketAccessControl.pm
+lib/Net/Amazon/S3/Request/GetBucketLocationConstraint.pm
+lib/Net/Amazon/S3/Request/GetObject.pm
+lib/Net/Amazon/S3/Request/GetObjectAccessControl.pm
+lib/Net/Amazon/S3/Request/ListAllMyBuckets.pm
+lib/Net/Amazon/S3/Request/ListBucket.pm
+lib/Net/Amazon/S3/Request/PutObject.pm
+lib/Net/Amazon/S3/Request/SetBucketAccessControl.pm
+lib/Net/Amazon/S3/Request/SetObjectAccessControl.pm
Makefile.PL
MANIFEST This list of files
README
t/01api.t
+t/02client.t
t/99-pod-coverage.t
t/99-pod.t
META.yml Module meta-data (added by MakeMaker)
Modified: trunk/libnet-amazon-s3-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/META.yml?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/META.yml (original)
+++ trunk/libnet-amazon-s3-perl/META.yml Sun Nov 30 16:03:16 2008
@@ -1,7 +1,7 @@
--- #YAML:1.0
name: Net-Amazon-S3
-version: 0.45
-abstract: ~
+version: 0.46
+abstract: Use the Amazon S3 - Simple Storage Service
license: perl
author:
- Leon Brocard <acme at astray.com>
@@ -9,12 +9,19 @@
distribution_type: module
requires:
Class::Accessor::Fast: 0
+ Data::Stream::Bulk::Callback: 0
Digest::HMAC_SHA1: 0
+ Digest::MD5: 0
Digest::MD5::File: 0
+ File::stat: 0
HTTP::Date: 0
+ HTTP::Status: 0
IO::File: 1.14
LWP::UserAgent::Determined: 0
MIME::Base64: 0
+ Moose: 0
+ MooseX::StrictConstructor: 0
+ Regexp::Common: 0
Test::More: 0.01
URI::Escape: 0
XML::LibXML: 0
Modified: trunk/libnet-amazon-s3-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/Makefile.PL?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/Makefile.PL (original)
+++ trunk/libnet-amazon-s3-perl/Makefile.PL Sun Nov 30 16:03:16 2008
@@ -6,19 +6,27 @@
NAME => 'Net::Amazon::S3',
VERSION_FROM => 'lib/Net/Amazon/S3.pm',
AUTHOR => 'Leon Brocard <acme at astray.com>',
+ ABSTRACT => 'Use the Amazon S3 - Simple Storage Service',
LICENSE => 'perl',
PREREQ_PM => {
- 'Class::Accessor::Fast' => '0',
- 'Digest::MD5::File' => '0',
- 'Digest::HMAC_SHA1' => '0',
- 'HTTP::Date' => '0',
- 'IO::File' => '1.14',
- 'LWP::UserAgent::Determined' => '0',
- 'MIME::Base64' => '0',
- 'Test::More' => '0.01',
- 'XML::LibXML' => '0',
- 'XML::LibXML::XPathContext' => '0',
- 'URI::Escape' => '0',
+ 'Class::Accessor::Fast' => '0',
+ 'Data::Stream::Bulk::Callback' => '0',
+ 'Digest::HMAC_SHA1' => '0',
+ 'Digest::MD5' => '0',
+ 'Digest::MD5::File' => '0',
+ 'File::stat' => '0',
+ 'HTTP::Date' => '0',
+ 'HTTP::Status' => '0',
+ 'IO::File' => '1.14',
+ 'LWP::UserAgent::Determined' => '0',
+ 'MIME::Base64' => '0',
+ 'Moose' => '0',
+ 'MooseX::StrictConstructor' => '0',
+ 'Test::More' => '0.01',
+ 'Regexp::Common' => '0',
+ 'XML::LibXML' => '0',
+ 'XML::LibXML::XPathContext' => '0',
+ 'URI::Escape' => '0',
}
);
Modified: trunk/libnet-amazon-s3-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/README?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/README (original)
+++ trunk/libnet-amazon-s3-perl/README Sun Nov 30 16:03:16 2008
@@ -9,6 +9,7 @@
my $s3 = Net::Amazon::S3->new(
{ aws_access_key_id => $aws_access_key_id,
aws_secret_access_key => $aws_secret_access_key,
+ retry => 1,
}
);
@@ -88,6 +89,12 @@
stored in values. Values are referenced by keys, and keys are stored in
buckets. Bucket names are global.
+ Note: This is the legacy interface, please check out
+ Net::Amazon::S3::Client instead.
+
+ Development of this code happens here:
+ http://github.com/acme/net-amazon-s3
+
METHODS
new
Create a new S3 client object. Takes some arguments:
@@ -119,7 +126,7 @@
retry
If this library should retry upon errors. This option is
recommended. This uses exponential backoff with retries after 1, 2,
- 4, 8, 16, 32 seconds, as recommended by Amazon.
+ 4, 8, 16, 32 seconds, as recommended by Amazon. Defaults to off.
buckets
Returns undef on error, else hashref of results
@@ -287,7 +294,7 @@
delete_key
DEPRECATED. DO NOT USE
-ABOUT
+LICENSE
This module contains code modified from Amazon that contains the
following notice:
Modified: trunk/libnet-amazon-s3-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/debian/changelog?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/debian/changelog (original)
+++ trunk/libnet-amazon-s3-perl/debian/changelog Sun Nov 30 16:03:16 2008
@@ -1,5 +1,6 @@
-libnet-amazon-s3-perl (0.45-2) UNRELEASED; urgency=low
+libnet-amazon-s3-perl (0.46-1) UNRELEASED; urgency=low
+ * New upstream release.
* debian/control: Changed: Switched Vcs-Browser field to ViewSVN
(source stanza).
Modified: trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3.pm?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3.pm (original)
+++ trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3.pm Sun Nov 30 16:03:16 2008
@@ -1,6 +1,6 @@
package Net::Amazon::S3;
-use strict;
-use warnings;
+use Moose;
+use MooseX::StrictConstructor;
=head1 NAME
@@ -96,26 +96,52 @@
stored in values. Values are referenced by keys, and keys are stored
in buckets. Bucket names are global.
+Note: This is the legacy interface, please check out
+L<Net::Amazon::S3::Client> instead.
+
+Development of this code happens here: http://github.com/acme/net-amazon-s3
+
=cut
use Carp;
use Digest::HMAC_SHA1;
-use HTTP::Date;
-use MIME::Base64 qw(encode_base64);
+
use Net::Amazon::S3::Bucket;
+use Net::Amazon::S3::Client;
+use Net::Amazon::S3::Client::Bucket;
+use Net::Amazon::S3::Client::Object;
+use Net::Amazon::S3::HTTPRequest;
+use Net::Amazon::S3::Request;
+use Net::Amazon::S3::Request::CreateBucket;
+use Net::Amazon::S3::Request::DeleteBucket;
+use Net::Amazon::S3::Request::DeleteObject;
+use Net::Amazon::S3::Request::GetBucketAccessControl;
+use Net::Amazon::S3::Request::GetBucketLocationConstraint;
+use Net::Amazon::S3::Request::GetObject;
+use Net::Amazon::S3::Request::GetObjectAccessControl;
+use Net::Amazon::S3::Request::ListAllMyBuckets;
+use Net::Amazon::S3::Request::ListBucket;
+use Net::Amazon::S3::Request::PutObject;
+use Net::Amazon::S3::Request::SetBucketAccessControl;
+use Net::Amazon::S3::Request::SetObjectAccessControl;
use LWP::UserAgent::Determined;
use URI::Escape qw(uri_escape_utf8);
use XML::LibXML;
use XML::LibXML::XPathContext;
-use base qw(Class::Accessor::Fast);
-__PACKAGE__->mk_accessors(
- qw(libxml aws_access_key_id aws_secret_access_key secure ua err errstr timeout retry)
-);
-our $VERSION = '0.45';
-
-my $AMAZON_HEADER_PREFIX = 'x-amz-';
-my $METADATA_PREFIX = 'x-amz-meta-';
+has 'aws_access_key_id' => ( is => 'ro', isa => 'Str', required => 1 );
+has 'aws_secret_access_key' => ( is => 'ro', isa => 'Str', required => 1 );
+has 'secure' => ( is => 'ro', isa => 'Bool', required => 0, default => 0 );
+has 'timeout' => ( is => 'ro', isa => 'Num', required => 0, default => 30 );
+has 'retry' => ( is => 'ro', isa => 'Bool', required => 0, default => 0 );
+
+has 'libxml' => ( is => 'rw', isa => 'XML::LibXML', required => 0 );
+has 'ua' => ( is => 'rw', isa => 'LWP::UserAgent', required => 0 );
+has 'err' => ( is => 'rw', isa => 'Maybe[Str]', required => 0 );
+has 'errstr' => ( is => 'rw', isa => 'Maybe[Str]', required => 0 );
+
+our $VERSION = '0.46';
+
my $KEEP_ALIVE_CACHESIZE = 10;
=head1 METHODS
@@ -163,15 +189,8 @@
=cut
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- die "No aws_access_key_id" unless $self->aws_access_key_id;
- die "No aws_secret_access_key" unless $self->aws_secret_access_key;
-
- $self->secure(0) if not defined $self->secure;
- $self->timeout(30) if not defined $self->timeout;
+sub BUILD {
+ my $self = shift;
my $ua;
if ( $self->retry ) {
@@ -192,7 +211,6 @@
$self->ua($ua);
$self->libxml( XML::LibXML->new );
- return $self;
}
=head2 buckets
@@ -203,7 +221,14 @@
sub buckets {
my $self = shift;
- my $xpc = $self->_send_request( 'GET', '', {} );
+
+ my $http_request
+ = Net::Amazon::S3::Request::ListAllMyBuckets->new( s3 => $self )
+ ->http_request;
+
+ # die $request->http_request->as_string;
+
+ my $xpc = $self->_send_request($http_request);
return undef unless $xpc && !$self->_remember_errors($xpc);
@@ -257,31 +282,18 @@
sub add_bucket {
my ( $self, $conf ) = @_;
- my $bucket = $conf->{bucket};
- croak 'must specify bucket' unless $bucket;
-
- if ( $conf->{acl_short} ) {
- $self->_validate_acl_short( $conf->{acl_short} );
- }
-
- my $header_ref
- = ( $conf->{acl_short} )
- ? { 'x-amz-acl' => $conf->{acl_short} }
- : {};
-
- my $data = '';
- if ( defined $conf->{location_constraint} ) {
- $data
- = "<CreateBucketConfiguration><LocationConstraint>"
- . $conf->{location_constraint}
- . "</LocationConstraint></CreateBucketConfiguration>";
- }
+
+ my $http_request = Net::Amazon::S3::Request::CreateBucket->new(
+ s3 => $self,
+ bucket => $conf->{bucket},
+ acl_short => $conf->{acl_short},
+ location_constraint => $conf->{location_constraint},
+ )->http_request;
return 0
- unless $self->_send_request_expect_nothing( 'PUT', "$bucket/",
- $header_ref, $data );
-
- return $self->bucket($bucket);
+ unless $self->_send_request_expect_nothing($http_request);
+
+ return $self->bucket( $conf->{bucket} );
}
=head2 bucket BUCKET
@@ -325,7 +337,13 @@
$bucket = $conf->{bucket};
}
croak 'must specify bucket' unless $bucket;
- return $self->_send_request_expect_nothing( 'DELETE', $bucket . "/", {} );
+
+ my $http_request = Net::Amazon::S3::Request::DeleteBucket->new(
+ s3 => $self,
+ bucket => $bucket,
+ )->http_request;
+
+ return $self->_send_request_expect_nothing($http_request);
}
=head2 list_bucket
@@ -466,18 +484,17 @@
sub list_bucket {
my ( $self, $conf ) = @_;
- my $bucket = delete $conf->{bucket};
- croak 'must specify bucket' unless $bucket;
- $conf ||= {};
-
- my $path = $bucket . "/";
- if (%$conf) {
- $path .= "?"
- . join( '&',
- map { $_ . "=" . $self->_urlencode( $conf->{$_} ) } keys %$conf );
- }
-
- my $xpc = $self->_send_request( 'GET', $path, {} );
+
+ my $http_request = Net::Amazon::S3::Request::ListBucket->new(
+ s3 => $self,
+ bucket => $conf->{bucket},
+ delimiter => $conf->{delimiter},
+ max_keys => $conf->{max_keys},
+ marker => $conf->{marker},
+ )->http_request;
+
+ my $xpc = $self->_send_request($http_request);
+
return undef unless $xpc && !$self->_remember_errors($xpc);
my $return = {
@@ -637,69 +654,14 @@
}
}
-# EU buckets must be accessed via their DNS name. This routine figures out if
-# a given bucket name can be safely used as a DNS name.
-sub _is_dns_bucket {
- my $bucketname = $_[0];
-
- if ( length $bucketname > 63 ) {
- return 0;
- }
- if ( length $bucketname < 3 ) {
- return;
- }
- return 0 unless $bucketname =~ m{^[a-z0-9][a-z0-9.-]+$};
- my @components = split /\./, $bucketname;
- for my $c (@components) {
- return 0 if $c =~ m{^-};
- return 0 if $c =~ m{-$};
- return 0 if $c eq '';
- }
- return 1;
-}
-
-# make the HTTP::Request object
-sub _make_request {
- my ( $self, $method, $path, $headers, $data, $metadata ) = @_;
- croak 'must specify method' unless $method;
- croak 'must specify path' unless defined $path;
- $headers ||= {};
- $data = '' if not defined $data;
- $metadata ||= {};
-
- my $http_headers = $self->_merge_meta( $headers, $metadata );
-
- $self->_add_auth_header( $http_headers, $method, $path )
- unless exists $headers->{Authorization};
- my $protocol = $self->secure ? 'https' : 'http';
- my $url = "$protocol://s3.amazonaws.com/$path";
- if ( $path =~ m{^([^/?]+)(.*)} && _is_dns_bucket($1) ) {
- $url = "$protocol://$1.s3.amazonaws.com$2";
- }
-
- my $request = HTTP::Request->new( $method, $url, $http_headers );
- $request->content($data);
-
- # my $req_as = $request->as_string;
- # $req_as =~ s/[^\n\r\x20-\x7f]/?/g;
- # $req_as = substr( $req_as, 0, 1024 ) . "\n\n";
- # warn $req_as;
-
- return $request;
-}
-
# $self->_send_request($HTTP::Request)
# $self->_send_request(@params_to_make_request)
sub _send_request {
- my $self = shift;
- my $request;
- if ( @_ == 1 ) {
- $request = shift;
- } else {
- $request = $self->_make_request(@_);
- }
-
- my $response = $self->_do_http($request);
+ my ( $self, $http_request ) = @_;
+
+ # warn $http_request->as_string;
+
+ my $response = $self->_do_http($http_request);
my $content = $response->content;
return $content unless $response->content_type eq 'application/xml';
@@ -709,19 +671,23 @@
# centralize all HTTP work, for debugging
sub _do_http {
- my ( $self, $request, $filename ) = @_;
+ my ( $self, $http_request, $filename ) = @_;
+
+ confess 'Need HTTP::Request object'
+ if ( ref($http_request) ne 'HTTP::Request' );
# convenient time to reset any error conditions
$self->err(undef);
$self->errstr(undef);
- return $self->ua->request( $request, $filename );
+ return $self->ua->request( $http_request, $filename );
}
sub _send_request_expect_nothing {
- my $self = shift;
- my $request = $self->_make_request(@_);
-
- my $response = $self->_do_http($request);
+ my ( $self, $http_request ) = @_;
+
+ # warn $http_request->as_string;
+
+ my $response = $self->_do_http($http_request);
my $content = $response->content;
return 1 if $response->code =~ /^2\d\d$/;
@@ -739,23 +705,29 @@
# first time we used it. Thus, we need to probe first to find out what's going on,
# before we start sending any actual data.
sub _send_request_expect_nothing_probed {
- my $self = shift;
- my ( $method, $path, $conf, $value ) = @_;
- my $request = $self->_make_request( 'HEAD', $path );
+ my ( $self, $http_request ) = @_;
+
+ my $head = Net::Amazon::S3::HTTPRequest->new(
+ s3 => $self,
+ method => 'HEAD',
+ path => $http_request->uri->path,
+ )->http_request;
+
+ #my $head_request = $self->_make_request( $head );
my $override_uri = undef;
my $old_redirectable = $self->ua->requests_redirectable;
$self->ua->requests_redirectable( [] );
- my $response = $self->_do_http($request);
+ my $response = $self->_do_http($head);
if ( $response->code =~ /^3/ && defined $response->header('Location') ) {
$override_uri = $response->header('Location');
}
- $request = $self->_make_request(@_);
- $request->uri($override_uri) if defined $override_uri;
-
- $response = $self->_do_http($request);
+
+ $http_request->uri($override_uri) if defined $override_uri;
+
+ $response = $self->_do_http($http_request);
$self->ua->requests_redirectable($old_redirectable);
my $content = $response->content;
@@ -781,7 +753,7 @@
my ( $self, $content ) = @_;
my $doc = $self->libxml->parse_string($content);
- #warn $doc->toString(2);
+ # warn $doc->toString(1);
my $xpc = XML::LibXML::XPathContext->new($doc);
$xpc->registerNs( 's3', 'http://s3.amazonaws.com/doc/2006-03-01/' );
@@ -810,114 +782,6 @@
return 0;
}
-sub _add_auth_header {
- my ( $self, $headers, $method, $path ) = @_;
- my $aws_access_key_id = $self->aws_access_key_id;
- my $aws_secret_access_key = $self->aws_secret_access_key;
-
- if ( not $headers->header('Date') ) {
- $headers->header( Date => time2str(time) );
- }
- my $canonical_string
- = $self->_canonical_string( $method, $path, $headers );
- my $encoded_canonical
- = $self->_encode( $aws_secret_access_key, $canonical_string );
- $headers->header(
- Authorization => "AWS $aws_access_key_id:$encoded_canonical" );
-}
-
-# generates an HTTP::Headers objects given one hash that represents http
-# headers to set and another hash that represents an object's metadata.
-sub _merge_meta {
- my ( $self, $headers, $metadata ) = @_;
- $headers ||= {};
- $metadata ||= {};
-
- my $http_header = HTTP::Headers->new;
- while ( my ( $k, $v ) = each %$headers ) {
- $http_header->header( $k => $v );
- }
- while ( my ( $k, $v ) = each %$metadata ) {
- $http_header->header( "$METADATA_PREFIX$k" => $v );
- }
-
- return $http_header;
-}
-
-# generate a canonical string for the given parameters. expires is optional and is
-# only used by query string authentication.
-sub _canonical_string {
- my ( $self, $method, $path, $headers, $expires ) = @_;
- my %interesting_headers = ();
- while ( my ( $key, $value ) = each %$headers ) {
- my $lk = lc $key;
- if ( $lk eq 'content-md5'
- or $lk eq 'content-type'
- or $lk eq 'date'
- or $lk =~ /^$AMAZON_HEADER_PREFIX/ )
- {
- $interesting_headers{$lk} = $self->_trim($value);
- }
- }
-
- # these keys get empty strings if they don't exist
- $interesting_headers{'content-type'} ||= '';
- $interesting_headers{'content-md5'} ||= '';
-
- # just in case someone used this. it's not necessary in this lib.
- $interesting_headers{'date'} = ''
- if $interesting_headers{'x-amz-date'};
-
- # if you're using expires for query string auth, then it trumps date
- # (and x-amz-date)
- $interesting_headers{'date'} = $expires if $expires;
-
- my $buf = "$method\n";
- foreach my $key ( sort keys %interesting_headers ) {
- if ( $key =~ /^$AMAZON_HEADER_PREFIX/ ) {
- $buf .= "$key:$interesting_headers{$key}\n";
- } else {
- $buf .= "$interesting_headers{$key}\n";
- }
- }
-
- # 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;
-}
-
-sub _trim {
- my ( $self, $value ) = @_;
- $value =~ s/^\s+//;
- $value =~ s/\s+$//;
- return $value;
-}
-
-# finds the hmac-sha1 hash of the canonical string and the aws secret access key and then
-# base64 encodes the result (optionally urlencoding after that).
-sub _encode {
- my ( $self, $aws_secret_access_key, $str, $urlencode ) = @_;
- my $hmac = Digest::HMAC_SHA1->new($aws_secret_access_key);
- $hmac->add($str);
- my $b64 = encode_base64( $hmac->digest, '' );
- if ($urlencode) {
- return $self->_urlencode($b64);
- } else {
- return $b64;
- }
-}
-
sub _urlencode {
my ( $self, $unencoded ) = @_;
return uri_escape_utf8( $unencoded, '^A-Za-z0-9_-' );
@@ -927,7 +791,7 @@
__END__
-=head1 ABOUT
+=head1 LICENSE
This module contains code modified from Amazon that contains the
following notice:
Modified: trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Bucket.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Bucket.pm?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Bucket.pm (original)
+++ trunk/libnet-amazon-s3-perl/lib/Net/Amazon/S3/Bucket.pm Sun Nov 30 16:03:16 2008
@@ -1,11 +1,13 @@
package Net::Amazon::S3::Bucket;
-use strict;
-use warnings;
+use Moose;
+use MooseX::StrictConstructor;
use Carp;
use File::stat;
use IO::File;
-use base qw(Class::Accessor::Fast);
-__PACKAGE__->mk_accessors(qw(bucket creation_date account));
+
+has 'account' => ( is => 'ro', isa => 'Net::Amazon::S3', required => 1 );
+has 'bucket' => ( is => 'ro', isa => 'Str', required => 1 );
+has 'creation_date' => ( is => 'ro', isa => 'Maybe[Str]', required => 0 );
=head1 NAME
@@ -74,14 +76,6 @@
=cut
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
- croak "no bucket" unless $self->bucket;
- croak "no account" unless $self->account;
- return $self;
-}
-
sub _uri {
my ( $self, $key ) = @_;
return ($key)
@@ -90,9 +84,9 @@
}
sub _conf_to_headers {
- my ($self, $conf) = @_;
+ my ( $self, $conf ) = @_;
$conf = {} unless defined $conf;
- $conf = { %$conf }; # clone it so as not to clobber the caller's copy
+ $conf = {%$conf}; # clone it so as not to clobber the caller's copy
if ( $conf->{acl_short} ) {
$self->account->_validate_acl_short( $conf->{acl_short} );
@@ -126,8 +120,6 @@
# returns bool
sub add_key {
my ( $self, $key, $value, $conf ) = @_;
- croak 'must specify key' unless defined $key && length $key;
- $conf = $self->_conf_to_headers($conf);
if ( ref($value) eq 'SCALAR' ) {
$conf->{'Content-Length'} ||= -s $$value;
@@ -136,16 +128,29 @@
$conf->{'Content-Length'} ||= length $value;
}
+ my $acl_short;
+ if ( $conf->{acl_short} ) {
+ $acl_short = $conf->{acl_short};
+ delete $conf->{acl_short};
+ }
+
+ my $http_request = Net::Amazon::S3::Request::PutObject->new(
+ s3 => $self->account,
+ bucket => $self->bucket,
+ key => $key,
+ value => $value,
+ acl_short => $acl_short,
+ headers => $conf,
+ )->http_request;
+
# If we're pushing to a bucket that's under DNS flux, we might get a 307
# Since LWP doesn't support actually waiting for a 100 Continue response,
# we'll just send a HEAD first to see what's going on
if ( ref($value) ) {
- return $self->account->_send_request_expect_nothing_probed( 'PUT',
- $self->_uri($key), $conf, $value );
+ return $self->account->_send_request_expect_nothing_probed($http_request);
} else {
- return $self->account->_send_request_expect_nothing( 'PUT',
- $self->_uri($key), $conf, $value );
+ return $self->account->_send_request_expect_nothing($http_request);
}
}
@@ -202,8 +207,12 @@
sub copy_key {
my ( $self, $key, $source, $conf ) = @_;
- if (defined $conf) {
- $conf = $self->_conf_to_headers($conf);
+ my $acl_short;
+ if ( defined $conf ) {
+ if ( $conf->{acl_short} ) {
+ $acl_short = $conf->{acl_short};
+ delete $conf->{acl_short};
+ }
$conf->{'x-amz-metadata-directive'} = 'REPLACE';
} else {
$conf = {};
@@ -211,15 +220,23 @@
$conf->{'x-amz-copy-source'} = $source;
- my $acct = $self->account;
- my $request = $acct->_make_request('PUT', $self->_uri($key), $conf);
- my $response = $acct->_do_http($request);
- my $xpc = $acct->_xpc_of_content($response->content);
-
- if (!$response->is_success || !$xpc || $xpc->findnodes("//Error")) {
- $acct->_remember_errors($response->content);
- return 0;
- }
+ my $acct = $self->account;
+ my $http_request = Net::Amazon::S3::Request::PutObject->new(
+ s3 => $self->account,
+ bucket => $self->bucket,
+ key => $key,
+ value => '',
+ acl_short => $acl_short,
+ headers => $conf,
+ )->http_request;
+
+ my $response = $acct->_do_http( $http_request );
+ my $xpc = $acct->_xpc_of_content( $response->content );
+
+ if ( !$response->is_success || !$xpc || $xpc->findnodes("//Error") ) {
+ $acct->_remember_errors( $response->content );
+ return 0;
+ }
return 1;
}
@@ -243,10 +260,10 @@
=cut
sub edit_metadata {
- my ($self, $key, $conf) = @_;
+ my ( $self, $key, $conf ) = @_;
croak "Need configuration hash" unless defined $conf;
- return $self->copy_key($key, "/".$self->bucket."/".$key, $conf);
+ return $self->copy_key( $key, "/" . $self->bucket . "/" . $key, $conf );
}
=head2 head_key KEY
@@ -278,12 +295,17 @@
sub get_key {
my ( $self, $key, $method, $filename ) = @_;
- $method ||= "GET";
$filename = $$filename if ref $filename;
my $acct = $self->account;
- my $request = $acct->_make_request( $method, $self->_uri($key), {} );
- my $response = $acct->_do_http( $request, $filename );
+ my $http_request = Net::Amazon::S3::Request::GetObject->new(
+ s3 => $acct,
+ bucket => $self->bucket,
+ key => $key,
+ method => $method || 'GET',
+ )->http_request;
+
+ my $response = $acct->_do_http( $http_request, $filename );
if ( $response->code == 404 ) {
return undef;
@@ -343,8 +365,14 @@
sub delete_key {
my ( $self, $key ) = @_;
croak 'must specify key' unless defined $key && length $key;
- return $self->account->_send_request_expect_nothing( 'DELETE',
- $self->_uri($key), {} );
+
+ my $http_request = Net::Amazon::S3::Request::DeleteObject->new(
+ s3 => $self->account,
+ bucket => $self->bucket,
+ key => $key,
+ )->http_request;
+
+ return $self->account->_send_request_expect_nothing($http_request);
}
=head2 delete_bucket
@@ -412,17 +440,29 @@
sub get_acl {
my ( $self, $key ) = @_;
- my $acct = $self->account;
-
- my $request
- = $acct->_make_request( 'GET', $self->_uri($key) . '?acl', {} );
- my $response = $acct->_do_http($request);
+ my $account = $self->account;
+
+ my $http_request;
+ if ($key) {
+ $http_request = Net::Amazon::S3::Request::GetObjectAccessControl->new(
+ s3 => $account,
+ bucket => $self->bucket,
+ key => $key,
+ )->http_request;
+ } else {
+ $http_request = Net::Amazon::S3::Request::GetBucketAccessControl->new(
+ s3 => $account,
+ bucket => $self->bucket,
+ )->http_request;
+ }
+
+ my $response = $account->_do_http($http_request);
if ( $response->code == 404 ) {
return undef;
}
- $acct->_croak_if_response_error($response);
+ $account->_croak_if_response_error($response);
return $response->content;
}
@@ -474,25 +514,27 @@
my ( $self, $conf ) = @_;
$conf ||= {};
- unless ( $conf->{acl_xml} || $conf->{acl_short} ) {
- croak "need either acl_xml or acl_short";
- }
-
- if ( $conf->{acl_xml} && $conf->{acl_short} ) {
- croak "cannot provide both acl_xml and acl_short";
- }
-
- my $path = $self->_uri( $conf->{key} ) . '?acl';
-
- my $hash_ref
- = ( $conf->{acl_short} )
- ? { 'x-amz-acl' => $conf->{acl_short} }
- : {};
-
- my $xml = $conf->{acl_xml} || '';
-
- return $self->account->_send_request_expect_nothing( 'PUT', $path,
- $hash_ref, $xml );
+ my $key = $conf->{key};
+ my $http_request;
+ if ($key) {
+ $http_request = Net::Amazon::S3::Request::SetObjectAccessControl->new(
+ s3 => $self->account,
+ bucket => $self->bucket,
+ key => $key,
+ acl_short => $conf->{acl_short},
+ acl_xml => $conf->{acl_xml},
+ )->http_request;
+ } else {
+ $http_request = Net::Amazon::S3::Request::SetBucketAccessControl->new(
+ s3 => $self->account,
+ bucket => $self->bucket,
+
+ acl_short => $conf->{acl_short},
+ acl_xml => $conf->{acl_xml},
+ )->http_request;
+ }
+
+ return $self->account->_send_request_expect_nothing($http_request);
}
@@ -506,8 +548,12 @@
sub get_location_constraint {
my ($self) = @_;
- my $xpc = $self->account->_send_request( 'GET',
- $self->bucket . '/?location' );
+ my $http_request = Net::Amazon::S3::Request::GetBucketLocationConstraint->new(
+ s3 => $self->account,
+ bucket => $self->bucket,
+ )->http_request;
+
+ my $xpc = $self->account->_send_request($http_request);
return undef unless $xpc && !$self->account->_remember_errors($xpc);
my $lc = $xpc->findvalue("//s3:LocationConstraint");
Modified: trunk/libnet-amazon-s3-perl/t/01api.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/t/01api.t?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/t/01api.t (original)
+++ trunk/libnet-amazon-s3-perl/t/01api.t Sun Nov 30 16:03:16 2008
@@ -1,5 +1,4 @@
-#!/usr/bin/perl -w
-
+#!perl
use warnings;
use strict;
use lib 'lib';
@@ -14,8 +13,6 @@
use_ok('Net::Amazon::S3');
-# this synopsis is presented as a test file
-
use vars qw/$OWNER_ID $OWNER_DISPLAYNAME/;
my $aws_access_key_id = $ENV{'AWS_ACCESS_KEY_ID'};
@@ -39,7 +36,7 @@
like( $response->{owner_id}, qr/^46a801915a1711f/ );
is( $response->{owner_displayname}, '_acme_' );
- is( scalar @{ $response->{buckets} }, 2 );
+ is( scalar @{ $response->{buckets} }, 9 );
}
for my $location ( undef, 'EU' ) {
@@ -49,12 +46,17 @@
# we use the same bucket name for both in order to force one or the other to
# have stale DNS
my $bucketname = 'net-amazon-s3-test-' . lc $aws_access_key_id;
+
+ # for testing
+ # my $bucket = $s3->bucket($bucketname); $bucket->delete_bucket; exit;
+
my $bucket_obj = $s3->add_bucket(
{ bucket => $bucketname,
acl_short => 'public-read',
location_constraint => $location
}
) or die $s3->err . ": " . $s3->errstr;
+
is( ref $bucket_obj, "Net::Amazon::S3::Bucket" );
is( $bucket_obj->get_location_constraint, $location );
@@ -71,6 +73,7 @@
# note prefix, marker, max_keys options can be passed in
$response = $bucket_obj->list
or die $s3->err . ": " . $s3->errstr;
+
is( $response->{bucket}, $bucketname );
is( $response->{prefix}, '' );
is( $response->{marker}, '' );
@@ -211,6 +214,7 @@
# Expect a nonexistent key copy to fail
ok( !$bucket_obj->copy_key( "newkey", "/$bucketname/$keyname2" ),
"Copying a nonexistent key fails" );
+
}
# list keys in the bucket
@@ -248,6 +252,7 @@
'x-amz-meta-colour' => 'orangy',
}
);
+
$response = $bucket_obj->get_key($keyname);
is( $response->{content_type}, 'text/plain' );
like( $response->{value}, qr/and unknown Amazon/ );
@@ -257,6 +262,7 @@
unlink('t/README');
$response = $bucket_obj->get_key_filename( $keyname, undef, 't/README' );
+
is( $response->{content_type}, 'text/plain' );
is( $response->{value}, '' );
is( $response->{etag}, $readme_md5 );
Modified: trunk/libnet-amazon-s3-perl/t/99-pod-coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libnet-amazon-s3-perl/t/99-pod-coverage.t?rev=27494&op=diff
==============================================================================
--- trunk/libnet-amazon-s3-perl/t/99-pod-coverage.t (original)
+++ trunk/libnet-amazon-s3-perl/t/99-pod-coverage.t Sun Nov 30 16:03:16 2008
@@ -1,7 +1,8 @@
use Test::More;
eval "use Test::Pod::Coverage 1.00";
-plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
-all_pod_coverage_ok( );
+plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage"
+ if $@;
+all_pod_coverage_ok( { also_private => [qr/^[A-Z_]+$/] } );
# Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that
# certain "die"s that happen inside evals are not actually inside evals,
More information about the Pkg-perl-cvs-commits
mailing list