Amazon-S3-0.65/ 0000755 0001750 0001750 00000000000 14531467536 013046 5 ustar rclauer rclauer Amazon-S3-0.65/t/ 0000755 0001750 0001750 00000000000 14531467536 013311 5 ustar rclauer rclauer Amazon-S3-0.65/t/01-api.t 0000644 0001750 0001750 00000045150 14531467536 014472 0 ustar rclauer rclauer #!/usr/bin/env perl -w
use warnings;
use strict;
use lib qw( . lib);
use Data::Dumper;
use Digest::MD5::File qw(file_md5_hex);
use English qw{-no_match_vars};
use File::Temp qw{ tempfile };
use List::Util qw(any);
use Test::More;
use S3TestUtils qw(:constants :subs);
our @REGIONS = (undef);
if ( $ENV{AMAZON_S3_REGIONS} ) {
push @REGIONS, split /\s*,\s*/xsm, $ENV{AMAZON_S3_REGIONS};
}
my $host = set_s3_host();
my $bucket_name = make_bucket_name();
if ( !$ENV{AMAZON_S3_EXPENSIVE_TESTS} ) {
plan skip_all => 'Testing this module for real costs money.';
}
else {
plan tests => 85 * scalar(@REGIONS) + 2;
}
########################################################################
# BEGIN TESTS
########################################################################
use_ok('Amazon::S3');
use_ok('Amazon::S3::Bucket');
my $s3 = get_s3_service($host);
if ( !$s3 || $EVAL_ERROR ) {
BAIL_OUT( 'could not initialize s3 object: ' . $EVAL_ERROR );
}
# bail if test bucket already exists
our ( $OWNER_ID, $OWNER_DISPLAYNAME ) = check_test_bucket($s3);
for my $location (@REGIONS) {
# this test formerly used the same bucket name for both regions,
# however when you delete a bucket it may take up to an hour for
# that bucket name to be available again when using AWS as the host.
# To test the bucket constraint policy below then we need to use a
# different bucket name. The old comment here was...
#
# > create a bucket
# > make sure it's a valid hostname for EU testing
# > we use the same bucket name for both in order to force one or the
# > other to have stale DNS
$s3->region($location);
$host = $s3->host;
my $bucket_name_raw;
my $bucket_name;
my $bucket_obj;
my $bucket_suffix;
while ($TRUE) {
$bucket_name_raw = make_bucket_name();
$bucket_name = $SLASH . $bucket_name_raw;
$bucket_obj = eval {
$s3->add_bucket(
{ bucket => $bucket_name,
acl_short => 'public-read',
location_constraint => $location
}
);
};
if ( $EVAL_ERROR || !$bucket_obj ) {
diag( Dumper( [ $EVAL_ERROR, $s3->err, $s3->errstr, $s3->error ] ) );
}
last if $bucket_obj;
# 409 indicates bucket name not yet available...
if ( $s3->last_response->code ne $HTTP_CONFLICT ) {
BAIL_OUT("could not create $bucket_name");
}
$bucket_suffix = '-2';
}
is(
ref $bucket_obj,
'Amazon::S3::Bucket', sprintf 'create bucket (%s) in %s ',
$bucket_name, $location // 'DEFAULT_REGION'
) or BAIL_OUT("could not create bucket $bucket_name");
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST} ) {
skip 'No region constraints', 1;
}
is( $bucket_obj->get_location_constraint, $location );
}
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_ACLS} || !$bucket_obj ) {
skip 'ACLs only for Amazon S3', 3;
}
like_acl_allusers_read($bucket_obj);
my $rsp = $bucket_obj->set_acl( { acl_short => 'private' } );
ok( $rsp, 'set_acl - private' )
or diag(
Dumper( [ response => $rsp, $s3->err, $s3->errstr, $s3->error ] ) );
unlike_acl_allusers_read($bucket_obj);
}
# another way to get a bucket object (does no network I/O,
# assumes it already exists). Read Amazon::S3::Bucket.
$bucket_obj = $s3->bucket($bucket_name);
is( ref $bucket_obj, 'Amazon::S3::Bucket' );
# fetch contents of the bucket
# note prefix, marker, max_keys options can be passed in
my $response = $bucket_obj->list();
if ( !$response ) {
BAIL_OUT( sprintf 'could not list bucket: %s', $bucket_name );
}
SKIP: {
if ( !$response ) {
skip 'invalid response to "list"';
}
is( $response->{bucket}, $bucket_name_raw )
or BAIL_OUT( Dumper [$response] );
ok( !$response->{prefix} );
ok( !$response->{marker}, );
is( $response->{max_keys}, 1_000 )
or BAIL_OUT( Dumper [$response] );
is( $response->{is_truncated}, 0 );
is_deeply( $response->{keys}, [] )
or diag( Dumper( [$response] ) );
is( undef, $bucket_obj->get_key('non-existing-key') );
}
my $keyname = 'testing.txt';
{
# Create a publicly readable key, then turn it private with a short acl.
# This key will persist past the end of the block.
my $value = 'T';
$bucket_obj->add_key(
$keyname, $value,
{ content_type => 'text/plain',
'x-amz-meta-colour' => 'orange',
acl_short => 'public-read',
}
);
my $url
= $s3->dns_bucket_names
? "http://$bucket_name_raw.$host/$keyname"
: "http://$host/$bucket_name/$keyname";
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_ACLS} ) {
skip 'ACLs only for Amazon S3', 3;
}
is_request_response_code( $url, $HTTP_OK,
'can access the publicly readable key' );
like_acl_allusers_read( $bucket_obj, $keyname );
ok(
$bucket_obj->set_acl(
{ key => $keyname,
acl_short => 'private'
}
)
);
}
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_PERMISSIONS} ) {
skip 'Mocking service does not enforce ACLs', 1;
}
is_request_response_code( $url, $HTTP_FORBIDDEN,
'cannot access the private key' );
}
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_ACLS} ) {
skip 'ACLs only for Amazon S3', 5;
}
unlike_acl_allusers_read( $bucket_obj, $keyname );
ok(
$bucket_obj->set_acl(
{ key => $keyname,
acl_xml => acl_xml_from_acl_short('public-read')
}
)
);
is_request_response_code( $url,
$HTTP_OK, 'can access the publicly readable key after acl_xml set' );
like_acl_allusers_read( $bucket_obj, $keyname );
ok(
$bucket_obj->set_acl(
{ key => $keyname,
acl_xml => acl_xml_from_acl_short('private')
}
)
);
}
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_PERMISSIONS} ) {
skip 'Mocking service does not enforce ACLs', 2;
}
is_request_response_code( $url,
$HTTP_FORBIDDEN, 'cannot access the private key after acl_xml set' );
unlike_acl_allusers_read( $bucket_obj, $keyname );
}
}
{
# Create a private key, then make it publicly readable with a short
# acl. Delete it at the end so we're back to having a single key in
# the bucket.
my $keyname2 = 'testing2.txt';
my $value = 'T2';
$bucket_obj->add_key(
$keyname2,
$value,
{ content_type => 'text/plain',
'x-amz-meta-colour' => 'blue',
acl_short => 'private',
}
);
my $url
= $s3->dns_bucket_names
? "http://$bucket_name_raw.$host/$keyname2"
: "http://$host/$bucket_name/$keyname2";
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_PERMISSIONS} ) {
skip 'Mocking service does not enforce ACLs', 1;
}
is_request_response_code( $url, $HTTP_FORBIDDEN,
'cannot access the private key' );
}
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_ACLS} ) {
skip 'ACLs only for Amazon S3', 4;
}
unlike_acl_allusers_read( $bucket_obj, $keyname2 );
ok(
$bucket_obj->set_acl(
{ key => $keyname2,
acl_short => 'public-read'
}
)
);
is_request_response_code( $url,
$HTTP_OK, 'can access the publicly readable key' );
like_acl_allusers_read( $bucket_obj, $keyname2 );
}
$bucket_obj->delete_key($keyname2);
}
# list keys in the bucket
foreach my $v ( 1 .. 2 ) {
if ( $v eq '2' ) {
$response = $bucket_obj->list_v2( { 'fetch-owner' => 'true' } );
}
else {
$response = $bucket_obj->list;
}
if ( !$response ) {
BAIL_OUT( $s3->err . ': ' . $s3->errstr );
}
is( $response->{bucket}, $bucket_name_raw, sprintf 'list(%s) - %s',
$v, $bucket_name );
ok( !$response->{prefix}, "list($v) - prefix empty" )
or diag( Dumper [$response] );
ok( !$response->{marker}, "list($v) - marker empty" );
is( $response->{max_keys}, 1_000, "list($v) - max keys 1000 " );
is( $response->{is_truncated}, 0, "list($v) - is_truncated 0" )
or diag( Dumper [$response] );
my @keys = @{ $response->{keys} };
is( @keys, 1, "list($v) - keys == 1 " )
or diag( Dumper \@keys );
my $key = $keys[0];
is( $key->{key}, $keyname, "list($v) - keyname" );
# the etag is the MD5 of the value
is( $key->{etag}, 'b9ece18c950afbfa6b0fdbfa4ff731d3', "list($v) - etag" );
is( $key->{size}, 1, "list($v) - size == 1" );
SKIP: {
if ( $ENV{AMAZON_S3_SKIP_OWNER_ID_TEST} ) {
skip 'mocking service has different owner for bucket', 1;
}
is( $key->{owner_id}, $OWNER_ID, "list($v) - owner id " )
or diag( Dumper [$key] );
}
is( $key->{owner_displayname},
$OWNER_DISPLAYNAME, "list($v) - owner display name" );
}
# You can't delete a bucket with things in it
ok( !$bucket_obj->delete_bucket(), 'delete bucket' );
$bucket_obj->delete_key($keyname);
# now play with the file methods
my ( $fh, $lorem_ipsum ) = tempfile();
print {$fh} <<'EOT';
Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do
eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad
minim veniam, quis nostrud exercitation ullamco laboris nisi ut
aliquip ex ea commodo consequat. Duis aute irure dolor in
reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla
pariatur. Excepteur sint occaecat cupidatat non proident, sunt in
culpa qui officia deserunt mollit anim id est laborum.
EOT
close $fh;
my $lorem_ipsum_md5 = file_md5_hex($lorem_ipsum);
my $lorem_ipsum_size = -s $lorem_ipsum;
$keyname .= '2';
$bucket_obj->add_key_filename(
$keyname,
$lorem_ipsum,
{ content_type => 'text/plain',
'x-amz-meta-colour' => 'orangy',
}
);
$response = $bucket_obj->get_key($keyname);
is( $response->{content_type}, 'text/plain', 'get_key - content_type' );
like( $response->{value}, qr/Lorem\sipsum/xsm, 'get_key - Lorem ipsum' );
is( $response->{etag}, $lorem_ipsum_md5, 'get_key - etag' )
or diag( Dumper [$response] );
is( $response->{'x-amz-meta-colour'}, 'orangy', 'get_key - metadata' );
is( $response->{content_length},
$lorem_ipsum_size, 'get_key - content_type' );
eval { unlink $lorem_ipsum };
$response = $bucket_obj->get_key_filename( $keyname, undef, $lorem_ipsum );
is( $response->{content_type},
'text/plain', 'get_key_filename - content_type' );
is( $response->{value}, $EMPTY, 'get_key_filename - value empty' );
is( $response->{etag}, $lorem_ipsum_md5, 'get_key_filename - etag == md5' );
is( file_md5_hex($lorem_ipsum),
$lorem_ipsum_md5, 'get_key_filename - file md5' );
is( $response->{'x-amz-meta-colour'},
'orangy', 'get_key_filename - metadata' );
is( $response->{content_length},
$lorem_ipsum_size, 'get_key_filename - content_length' );
# before we delete this key...
my $copy_result = $bucket_obj->copy_object(
key => "$keyname.bak",
source => "$keyname",
);
isa_ok( $copy_result, 'HASH', 'copy_object returns a hash reference' );
$response = $bucket_obj->list;
ok( ( grep {"$keyname.bak"} @{ $response->{keys} } ), 'found the copy' );
if ( !$ENV{AMAZON_S3_KEEP_BUCKET} ) {
$bucket_obj->delete_key($keyname);
$bucket_obj->delete_key("$keyname.bak");
}
# try empty files
$keyname .= '3';
$bucket_obj->add_key( $keyname, $EMPTY );
$response = $bucket_obj->get_key($keyname);
is( $response->{value}, $EMPTY, 'empty object - value empty' );
is(
$response->{etag},
'd41d8cd98f00b204e9800998ecf8427e',
'empty object - etag'
);
is( $response->{content_type},
'binary/octet-stream', 'empty object - content_type' );
is( $response->{content_length}, 0, 'empty object - content_length == 0' );
$bucket_obj->delete_key($keyname);
# fetch contents of the bucket
# note prefix, marker, max_keys options can be passed in
$response = $bucket_obj->list
or die $s3->err . ': ' . $s3->errstr;
$bucket_name =~ s/^\///xsm;
is( $response->{bucket}, $bucket_name,
'delete key from bucket - ' . $bucket_name );
ok( !$response->{prefix}, 'delete key from bucket - prefix empty' );
ok( !$response->{marker}, 'delete key from bucket - marker empty' );
is( $response->{max_keys}, 1_000,
'delete key from bucket - max keys 1000' );
is( $response->{is_truncated},
0, 'delete key from bucket - is_truncated 0' );
is_deeply( $response->{keys}, [],
'delete key from bucket - empty list of keys' );
######################################################################
# delete multiple keys from bucket
# TODO: test deleting specific versions
#
SKIP: {
if ( $ENV{AMAZON_S3_KEEP_BUCKET} ) {
skip 'keeping bucket', 9;
}
$keyname = 'foo-';
for ( 1 .. 8 ) {
$bucket_obj->add_key( "$keyname$_", $EMPTY );
}
$response = $bucket_obj->list
or die $s3->err . ': ' . $s3->errstr;
my @key_list = @{ $response->{keys} };
is( 8, scalar @key_list, 'wrote 8 keys for delete_keys() test' );
######################################################################
# quietly delete version keys - first two
######################################################################
my $delete_rsp = $bucket_obj->delete_keys(
{ quiet => 1,
keys => [ map { $_->{key} } @key_list[ ( 0, 1 ) ] ]
}
);
ok( !$delete_rsp, 'delete_keys() quiet response - empty' )
or BAIL_OUT(
'could not delete quietly '
. Dumper(
[ response => $delete_rsp,
last_request => $s3->get_last_request,
last_response => $s3->get_last_response,
]
)
);
$response = $bucket_obj->list
or die $s3->err . ': ' . $s3->errstr;
is(
scalar @{ $response->{keys} },
-2 + scalar(@key_list),
'delete versioned keys'
);
shift @key_list;
shift @key_list;
######################################################################
# delete list of keys - next two keys
######################################################################
$delete_rsp
= $bucket_obj->delete_keys( map { $_->{key} } @key_list[ ( 0, 1 ) ] );
ok( $delete_rsp, 'delete_keys() response' );
$response = $bucket_obj->list
or die $s3->err . ': ' . $s3->errstr;
is(
scalar @{ $response->{keys} },
-2 + scalar(@key_list),
'delete list of keys'
);
shift @key_list;
shift @key_list;
######################################################################
# delete array of keys - next two keys
#####################################################################
$delete_rsp
= $bucket_obj->delete_keys( map { $_->{key} } @key_list[ ( 0, 1 ) ] );
ok( $delete_rsp, 'delete_keys() response' );
$response = $bucket_obj->list
or die $s3->err . ': ' . $s3->errstr;
is(
scalar @{ $response->{keys} },
-2 + scalar(@key_list),
'delete array of keys'
);
shift @key_list;
shift @key_list;
######################################################################
# callback - last two keys
######################################################################
$delete_rsp = $bucket_obj->delete_keys(
sub {
my $key = shift @key_list;
return ( $key->{key} );
}
);
ok( $delete_rsp, 'delete_keys() response' );
$response = $bucket_obj->list
or die $s3->err . ': ' . $s3->errstr;
is( scalar @{ $response->{keys} }, 0, 'delete keys from callback' )
or diag( Dumper( [ response => $response, key_list => \@key_list ] ) );
#
# delete multiple keys from bucket
######################################################################
}
SKIP: {
if ( $ENV{AMAZON_S3_KEEP_BUCKET} ) {
skip 'keeping bucket', 1;
}
ok( $bucket_obj->delete_bucket(), 'delete bucket' );
}
}
# see more docs in Amazon::S3::Bucket
# local test methods
########################################################################
sub is_request_response_code {
########################################################################
my ( $url, $code, $message ) = @_;
my $request = HTTP::Request->new( 'GET', $url );
my $response = $s3->ua->request($request);
is( $response->code, $code, $message )
or diag( Dumper( [ response_code => $response ] ) );
return;
}
########################################################################
sub like_acl_allusers_read {
########################################################################
my ( $bucket_obj, $keyname ) = @_;
my $message = acl_allusers_read_message( 'like', $bucket_obj, $keyname );
my $acl = $bucket_obj->get_acl($keyname);
like( $acl, qr/AllUsers.+READ/xsm, $message )
or diag( Dumper( [ acl => $acl ] ) );
return;
}
########################################################################
sub unlike_acl_allusers_read {
########################################################################
my ( $bucket_obj, $keyname ) = @_;
my $message = acl_allusers_read_message( 'unlike', $bucket_obj, $keyname );
my $acl = $bucket_obj->get_acl($keyname);
unlike( $bucket_obj->get_acl($keyname), qr/AllUsers.+READ/xsm, $message )
or diag( Dumper( [ acl => $acl ] ) );
return;
}
########################################################################
sub acl_allusers_read_message {
########################################################################
my ( $like_or_unlike, $bucket_obj, $keyname ) = @_;
my $message = sprintf '%s_acl_allusers_read: %s', $like_or_unlike,
$bucket_obj->bucket;
if ($keyname) {
$message .= " - $keyname";
}
return $message;
}
########################################################################
sub acl_xml_from_acl_short {
########################################################################
my ($acl_short) = @_;
$acl_short //= 'private';
my $public_read
= $acl_short eq 'public-read' ? $PUBLIC_READ_POLICY : $EMPTY;
my $policy = <<"END_OF_POLICY";
$OWNER_ID
$OWNER_DISPLAYNAME
$OWNER_ID
$OWNER_DISPLAYNAME
FULL_CONTROL
$public_read
END_OF_POLICY
return $policy;
}
1;
Amazon-S3-0.65/t/04-list-buckets.t 0000644 0001750 0001750 00000014012 14531467536 016326 0 ustar rclauer rclauer #!/usr/bin/perl -w
## no critic
use warnings;
use strict;
use lib qw(. lib);
use English qw{-no_match_vars};
use S3TestUtils qw(:constants :subs);
use Test::More;
use Data::Dumper;
my $host = set_s3_host();
if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) {
plan skip_all => 'Testing this module for real costs money.';
}
else {
plan tests => 11;
}
########################################################################
# BEGIN TESTS
########################################################################
use_ok('Amazon::S3');
use_ok('Amazon::S3::Bucket');
my $s3 = get_s3_service($host);
my $bucket_name = make_bucket_name();
my $bucket_obj = create_bucket( $s3, $bucket_name );
ok( ref $bucket_obj, 'created bucket - ' . $bucket_name );
if ( $EVAL_ERROR || !$bucket_obj ) {
BAIL_OUT( $s3->err . ": " . $s3->errstr );
}
my $bad_bucket = $s3->bucket( { bucket => 'does-not-exists' } );
my $response = $bad_bucket->list( { bucket => $bad_bucket } );
ok( !defined $response, 'undef returned on non-existent bucket' );
like( $bad_bucket->errstr, qr/does\snot\sexist/xsm, 'errstr populated' )
or diag(
Dumper(
[ response => $response,
errstr => $bad_bucket->errstr,
err => $bad_bucket->err,
]
)
);
my $max_keys = 25;
########################################################################
subtest 'list (check response elements)' => sub {
########################################################################
my $response = $bucket_obj->list
or BAIL_OUT( $s3->err . ": " . $s3->errstr );
is( $response->{bucket}, $bucket_name, 'no bucket name in list response' )
or do {
diag( Dumper( [$response] ) );
BAIL_OUT( Dumper [$response] );
};
ok( !$response->{prefix}, 'no prefix in list response' );
ok( !$response->{marker}, 'no marker in list response' );
is( $response->{max_keys}, 1_000, 'max keys default = 1000' )
or BAIL_OUT( Dumper [$response] );
is( $response->{is_truncated}, 0, 'is_truncated 0' );
is_deeply( $response->{keys}, [], 'no keys in bucket yet' )
or BAIL_OUT( Dumper( [$response] ) );
};
########################################################################
subtest 'list_all' => sub {
########################################################################
add_keys( $bucket_obj, $max_keys );
my $response = $bucket_obj->list_all;
is( ref $response, 'HASH', 'response isa HASH' )
or diag( Dumper( [$response] ) );
is( ref $response->{keys}, 'ARRAY', 'keys element is an ARRAY' )
or diag( Dumper( [$response] ) );
is( @{ $response->{keys} }, $max_keys, $max_keys . ' keys returned' )
or diag( Dumper( [$response] ) );
foreach my $key ( @{ $response->{keys} } ) {
is( ref $key, 'HASH', 'array element isa HASH' )
or diag( Dumper( [$key] ) );
like( $key->{key}, qr/testing-\d{2}[.]txt/xsm, 'keyname' )
or diag( Dumper( [$key] ) );
}
};
########################################################################
subtest 'list' => sub {
########################################################################
my $marker = '';
my $iter = 0; # so we don't loop forever if this is busted
my @key_list;
my $page_size = int $max_keys / 2;
while ( $marker || !$iter ) {
last if $iter++ > $max_keys;
my $response = $bucket_obj->list(
{ 'max-keys' => $page_size,
marker => $marker,
delimiter => '/',
}
);
if ( !$response ) {
BAIL_OUT( $s3->err . ": " . $s3->errstr );
}
is( $response->{bucket}, $bucket_name, 'no bucket name' );
ok( !$response->{prefix}, 'no prefix' )
or diag( Dumper [$response] );
is( $response->{max_keys}, $page_size, 'max-keys ' . $page_size );
is( ref $response->{keys}, 'ARRAY' )
or BAIL_OUT( Dumper( [$response] ) );
push @key_list, @{ $response->{keys} };
$marker = $response->{next_marker};
last if !$marker;
}
is( @key_list, $max_keys, $max_keys . ' returned' )
or diag( Dumper( [ key_list => \@key_list ] ) );
};
########################################################################
subtest 'list_v2' => sub {
########################################################################
my $marker = '';
my $iter = 0; # so we don't loop forever if this is busted
my @key_list;
my $page_size = int $max_keys / 2;
while ( $marker || !$iter ) {
last if $iter++ > $max_keys;
my $response = $bucket_obj->list_v2(
{ 'max-keys' => $page_size,
$marker ? ( 'marker' => $marker ) : (),
delimiter => '/',
}
);
if ( !$response ) {
BAIL_OUT( $s3->err . ": " . $s3->errstr );
}
is( $response->{bucket}, $bucket_name, 'no bucket name' );
ok( !$response->{prefix}, 'no prefix' )
or diag( Dumper [$response] );
is( $response->{max_keys}, $page_size, 'max-keys ' . $page_size );
is( ref $response->{keys}, 'ARRAY' )
or BAIL_OUT( Dumper( [$response] ) );
push @key_list, @{ $response->{keys} };
$marker = $response->{next_marker};
last if !$marker;
}
is( @key_list, $max_keys, $max_keys . ' returned' )
or diag( Dumper( \@key_list ) );
};
########################################################################
subtest 'list_bucket_all' => sub {
########################################################################
$max_keys += add_keys( $bucket_obj, $max_keys, 'foo/' );
my $response = $s3->list_bucket_all( { bucket => $bucket_name } );
is( ref $response, 'HASH', 'list_bucket_all response is a HASH' );
is( @{ $response->{keys} }, $max_keys, $max_keys . ' returned' );
};
########################################################################
subtest 'list_bucket_all_v2' => sub {
########################################################################
my $response = $s3->list_bucket_all_v2( { bucket => $bucket_name } );
is( ref $response, 'HASH', 'list_bucket_all_v2 response is a HASH' );
is( @{ $response->{keys} }, $max_keys, $max_keys . ' returned' );
foreach ( @{ $response->{keys} } ) {
$bucket_obj->delete_key( $_->{key} );
}
};
$bucket_obj->delete_bucket;
1;
Amazon-S3-0.65/t/05-multipart-upload.t 0000644 0001750 0001750 00000007567 14531467536 017242 0 ustar rclauer rclauer #!/usr/bin/perl -w
## no critic
use warnings;
use strict;
use lib qw( . lib);
use Carp;
use Data::Dumper;
use Digest::MD5::File qw(file_md5_hex);
use English qw{-no_match_vars};
use File::Temp qw{ tempfile };
use Test::More;
use S3TestUtils qw(:constants :subs);
my $host = set_s3_host();
if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) {
plan skip_all => 'Testing this module for real costs money.';
}
else {
plan tests => 7;
}
use_ok('Amazon::S3');
use_ok('Amazon::S3::Bucket');
my $s3 = get_s3_service($host);
if ( !$s3 ) {
BAIL_OUT('could not initialize s3 object');
}
my $bucket_name = make_bucket_name();
my $bucket_obj = create_bucket( $s3, $bucket_name );
ok( ref $bucket_obj, 'created bucket - ' . $bucket_name );
if ( $EVAL_ERROR || !$bucket_obj ) {
BAIL_OUT( $s3->err . ": " . $s3->errstr );
} ## end if ( $EVAL_ERROR || !$bucket_obj)
########################################################################
subtest 'multipart-manual' => sub {
########################################################################
my $key = 'big-object-1';
my $id = $bucket_obj->initiate_multipart_upload($key);
my $part_list = {};
my $part = 0;
my $data = 'x' x ( 1024 * 1024 * 5 ); # 5 MB part
my $etag
= $bucket_obj->upload_part_of_multipart_upload( $key, $id, ++$part, $data,
length $data );
$part_list->{$part} = $etag;
$bucket_obj->complete_multipart_upload( $key, $id, $part_list );
my $head = $bucket_obj->head_key($key);
ok( $head, 'uploaded file' );
ok( $head->{content_length} == 5 * 1024 * 1024, 'uploaded 1 part' )
or diag( Dumper( [$head] ) );
ok( $bucket_obj->delete_key($key) );
};
########################################################################
subtest 'multipart-file' => sub {
########################################################################
my ( $fh, $file ) = tempfile();
my $buffer = 'x' x ( 1024 * 1024 );
# 11MB
foreach ( 0 .. 10 ) {
$fh->syswrite($buffer);
}
$fh->close;
if ( !open( $fh, '<', $file ) ) {
carp "could not open $file after writing";
return;
}
my $key = 'big-object-2';
$bucket_obj->upload_multipart_object( fh => $fh, key => $key );
close $fh;
my $head = $bucket_obj->head_key($key);
ok( $head, 'uploaded file' );
isa_ok( $head, 'HASH', 'head is a hash' );
ok( $head->{content_length} == 11 * 1024 * 1024, 'uploaded all parts' );
$bucket_obj->delete_key($key);
unlink $file;
};
########################################################################
subtest 'multipart-2-parts' => sub {
########################################################################
my $length = 1024 * 1024 * 7;
my $data = 'x' x $length;
my $key = 'big-object-3';
$bucket_obj->upload_multipart_object(
key => $key,
data => $data
);
my $head = $bucket_obj->head_key($key);
isa_ok( $head, 'HASH', 'head is a hash' );
ok( $head, 'uploaded data' );
ok( $head->{content_length} == $length, 'uploaded all parts' );
$bucket_obj->delete_key($key);
};
########################################################################
subtest 'multipart-callback' => sub {
########################################################################
my $key = 'big-object-4';
my @part = ( 5, 5, 5, 1 );
my $size;
$bucket_obj->upload_multipart_object(
key => $key,
callback => sub {
return ( q{}, 0 ) unless @part;
my $length = shift @part;
$length *= 1024 * 1024;
$size += $length;
my $data = 'x' x $length;
return ( \$data, $length );
}
);
my $head = $bucket_obj->head_key($key);
isa_ok( $head, 'HASH', 'head is a hash' );
ok( $head, 'uploaded data' );
ok( $head->{content_length} == $size, 'uploaded all parts' );
$bucket_obj->delete_key($key);
};
########################################################################
$bucket_obj->delete_bucket()
or diag( $s3->errstr );
1;
Amazon-S3-0.65/t/02-logger.t 0000644 0001750 0001750 00000004527 14531467536 015204 0 ustar rclauer rclauer #!/usr/bin/perl -w
## no critic
use warnings;
use strict;
use lib qw(lib);
use English qw{-no_match_vars};
use Test::More;
use Test::Output;
plan tests => 12;
use_ok('Amazon::S3');
########################################################################
sub test_levels {
########################################################################
my ($s3) = @_;
print {*STDERR} "\n---[" . $s3->level . "]---\n";
$s3->get_logger->trace("test trace\n");
$s3->get_logger->debug("test debug\n");
$s3->get_logger->info("test info\n");
$s3->get_logger->warn("test warn\n");
$s3->get_logger->error("test error\n");
$s3->get_logger->fatal("test fatal\n");
return;
} ## end sub test_levels
########################################################################
sub test_all_levels {
########################################################################
my ($s3) = @_;
$s3->level('trace');
stderr_like( sub { test_levels($s3); },
qr/trace\n.*debug\n.*info\n.*warn\n.*error\n.*fatal\n/xsm, 'trace' );
$s3->level('debug');
stderr_like( sub { test_levels($s3); },
qr/debug\n.*info\n.*warn\n.*error\n.*fatal\n/xsm, 'debug' );
stderr_unlike( sub { test_levels($s3); },
qr/trace/, 'debug - not like trace' );
$s3->level('info');
stderr_like( sub { test_levels($s3); },
qr/info\n.*warn\n.*error\n.*fatal\n/xsm, 'info' );
stderr_unlike( sub { test_levels($s3); },
qr/trace|debug/, 'info - not like trace, debug' );
$s3->level('warn');
stderr_like( sub { test_levels($s3); },
qr/warn\n.*error\n.*fatal\n/xsm, 'warn' );
stderr_unlike( sub { test_levels($s3); },
qr/trace|debug|info/, 'warn - not like trace, debug, info' );
$s3->level('error');
stderr_like( sub { test_levels($s3); }, qr/error\n.*fatal\n/xsm, 'error' );
stderr_unlike( sub { test_levels($s3); },
qr/trace|debug|info|warn/, 'error - not like trace, debug, info, warn' );
$s3->level('fatal');
stderr_like( sub { test_levels($s3); }, qr/fatal\n/xsm, 'fatal' );
stderr_unlike(
sub { test_levels($s3); },
qr/trace|debug|info|warn|error/,
'fatal - not like trace, debug, info, warn, error'
);
} ## end sub test_all_levels
########################################################################
my $s3 = Amazon::S3->new(
{ aws_access_key_id => 'test',
aws_secret_access_key => 'test',
}
);
test_all_levels($s3);
Amazon-S3-0.65/t/03-region.t 0000644 0001750 0001750 00000001721 14531467536 015202 0 ustar rclauer rclauer #!/usr/bin/perl -w
## no critic
use warnings;
use strict;
use lib qw(lib);
use English qw{-no_match_vars};
use Test::More;
plan tests => 7;
use_ok('Amazon::S3');
my $s3 = Amazon::S3->new(
{ aws_access_key_id => 'test',
aws_secret_access_key => 'test',
log_level => $ENV{DEBUG} ? 'debug' : undef,
}
);
ok( $s3->region, 'us-east-1' );
is( $s3->host, 's3.us-east-1.amazonaws.com',
'default host is s3.us-east-1.amazonaws.com' );
$s3 = Amazon::S3->new(
{ aws_access_key_id => 'test',
aws_secret_access_key => 'test',
region => 'us-west-2',
log_level => $ENV{DEBUG} ? 'debug' : undef,
}
);
is( $s3->region, 'us-west-2', 'region is set' );
is( $s3->host, 's3.us-west-2.amazonaws.com',
'host is modified during creation' );
$s3->region('us-east-1');
is( $s3->region, 'us-east-1', 'region is set' );
is( $s3->host, 's3.us-east-1.amazonaws.com',
'host is modified when region changes' );
Amazon-S3-0.65/t/06-list-multipart-uploads.t 0000644 0001750 0001750 00000007352 14531467536 020367 0 ustar rclauer rclauer #!/usr/bin/perl -w
## no critic
use warnings;
use strict;
use lib qw(. lib);
use Carp;
use Data::Dumper;
use Digest::MD5::File qw(file_md5_hex);
use English qw(-no_match_vars);
use File::Temp qw( tempfile );
use S3TestUtils qw(:constants :subs);
use Test::More;
use XML::Simple qw{XMLin};
my $host = set_s3_host();
if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) {
plan skip_all => 'Testing this module for real costs money.';
} ## end if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'...})
else {
plan tests => 6;
}
use_ok('Amazon::S3');
use_ok('Amazon::S3::Bucket');
my $s3 = get_s3_service($host);
my $bucket_name = make_bucket_name();
my $bucket_obj = create_bucket( $s3, $bucket_name );
ok( ref $bucket_obj, 'created bucket - ' . $bucket_name );
if ( $EVAL_ERROR || !$bucket_obj ) {
BAIL_OUT( $s3->err . ": " . $s3->errstr );
} ## end if ( $EVAL_ERROR || !$bucket_obj)
my $id;
my $key = 'big-object-1';
########################################################################
subtest 'list-multipart-uploads' => sub {
########################################################################
my $upload_list = list_multipart_uploads($bucket_obj);
ok( !defined $upload_list, 'no in-progress uploads' )
or diag( Dumper( [$upload_list] ) );
$id = partial_upload( $key, $bucket_obj );
$upload_list = list_multipart_uploads($bucket_obj);
ok( $upload_list->{UploadId} eq $id, 'UploadId eq $id' );
};
########################################################################
subtest 'abort-multipart-upload' => sub {
########################################################################
$bucket_obj->abort_multipart_upload( $key, $id );
my $upload_list = list_multipart_uploads($bucket_obj);
ok( !defined $upload_list, 'aborted upload' );
};
########################################################################
subtest 'abort-on-error' => sub {
########################################################################
my $id = $bucket_obj->initiate_multipart_upload($key);
my $part_list = {};
my $part = 0;
my $data = 'x' x ( 1024 * 1024 * 1 ); # should be too small
# do this twice...
foreach ( 0 .. 1 ) {
my $etag
= $bucket_obj->upload_part_of_multipart_upload( $key, $id, ++$part,
$data, length $data );
$part_list->{$part} = $etag;
}
eval { $bucket_obj->complete_multipart_upload( $key, $id, $part_list ); };
ok( $EVAL_ERROR =~ /Bad Request/, 'abort-on-error successful' )
or diag( Dumper( [ $EVAL_ERROR, $id ] ) );
$bucket_obj->abort_multipart_upload( $key, $id );
};
########################################################################
$bucket_obj->delete_bucket()
or diag( $s3->errstr );
########################################################################
sub partial_upload {
########################################################################
my ( $key, $bucket_obj, $size_in_mb ) = @_;
my $id = $bucket_obj->initiate_multipart_upload($key);
my $length = ( $size_in_mb || 5 ) * 1024 * 1024;
my $data = 'x' x $length;
my $etag
= $bucket_obj->upload_part_of_multipart_upload( $key, $id, 1, $data,
$length );
return $id;
}
########################################################################
sub list_multipart_uploads {
########################################################################
my ($bucket_obj) = @_;
my $xml = $bucket_obj->list_multipart_uploads;
ok( $xml =~ /^ $TRUE );
isa_ok( $uploads, 'HASH', 'made a hash object' )
or diag($uploads);
ok( defined $uploads->{ListMultipartUploadsResult},
'looks like a results object' )
or diag($xml);
my $upload_list = $uploads->{ListMultipartUploadsResult}->{Upload};
return $upload_list;
}
1;
Amazon-S3-0.65/README.md 0000644 0001750 0001750 00000076333 14531467536 014341 0 ustar rclauer rclauer # NAME
Amazon::S3 - A portable client library for working with and
managing Amazon S3 buckets and keys.
# SYNOPSIS
use Amazon::S3;
my $aws_access_key_id = "Fill me in!";
my $aws_secret_access_key = "Fill me in too!";
my $s3 = Amazon::S3->new(
{ aws_access_key_id => $aws_access_key_id,
aws_secret_access_key => $aws_secret_access_key,
retry => 1
}
);
my $response = $s3->buckets;
# create a bucket
my $bucket_name = $aws_access_key_id . '-net-amazon-s3-test';
my $bucket = $s3->add_bucket( { bucket => $bucket_name } )
or die $s3->err . ": " . $s3->errstr;
# store a key with a content-type and some optional metadata
my $keyname = 'testing.txt';
my $value = 'T';
$bucket->add_key(
$keyname, $value,
{ content_type => 'text/plain',
'x-amz-meta-colour' => 'orange',
}
);
# copy an object
$bucket->copy_object(
source => $source,
key => $new_keyname
);
# list keys in the bucket
$response = $bucket->list
or die $s3->err . ": " . $s3->errstr;
print $response->{bucket}."\n";
for my $key (@{ $response->{keys} }) {
print "\t".$key->{key}."\n";
}
# delete key from bucket
$bucket->delete_key($keyname);
# delete multiple keys from bucket
$bucket->delete_keys([$key1, $key2, $key3]);
# delete bucket
$bucket->delete_bucket;
# DESCRIPTION
This documentation refers to version 0.65.
`Amazon::S3` provides a portable client interface to Amazon Simple
Storage System (S3).
This module is rather dated, however with some help from a few
contributors it has had some recent updates. Recent changes include
implementations of:
- ListObjectsV2
- CopyObject
- DeleteObjects
Additionally, this module now implements Signature Version 4 signing,
unit tests have been updated and more documentation has been added or
corrected. Credentials are encrypted if you have encryption modules installed.
## Comparison to Other Perl S3 Modules
Other implementations for accessing Amazon's S3 service include
`Net::Amazon::S3` and the `Paws` project. `Amazon::S3` ostensibly
was intended to be a drop-in replacement for `Net:Amazon::S3` that
"traded some performance in return for portability". That statement is
no longer accurate as `Amazon::S3` may have changed the interface in
ways that might break your applications if you are relying on
compatibility with `Net::Amazon::S3`.
However, `Net::Amazon::S3` and `Paws::S3` today, are dependent on
`Moose` which may in fact level the playing field in terms of
performance penalties that may have been introduced by recent updates
to `Amazon::S3`. Changes to `Amazon::S3` include the use of more
Perl modules in lieu of raw Perl code to increase maintainability and
stability as well as some refactoring. `Amazon::S3` also strives now
to adhere to best practices as much as possible.
`Paws::S3` may be a much more robust implementation of
a Perl S3 interface, however this module may still appeal to
those that favor simplicity of the interface and a lower number of
dependencies. Below is the original description of the module.
> Amazon S3 is storage for the Internet. It is designed to
> make web-scale computing easier for developers. Amazon S3
> provides a simple web services interface that can be used to
> store and retrieve any amount of data, at any time, from
> anywhere on the web. It gives any developer access to the
> same highly scalable, reliable, fast, inexpensive data
> storage infrastructure that Amazon uses to run its own
> global network of web sites. The service aims to maximize
> benefits of scale and to pass those benefits on to
> developers.
>
> To sign up for an Amazon Web Services account, required to
> use this library and the S3 service, please visit the Amazon
> Web Services web site at http://www.amazonaws.com/.
>
> You will be billed accordingly by Amazon when you use this
> module and must be responsible for these costs.
>
> To learn more about Amazon's S3 service, please visit:
> http://s3.amazonaws.com/.
>
> The need for this module arose from some work that needed
> to work with S3 and would be distributed, installed and used
> on many various environments where compiled dependencies may
> not be an option. [Net::Amazon::S3](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3AS3) used [XML::LibXML](https://metacpan.org/pod/XML%3A%3ALibXML)
> tying it to that specific and often difficult to install
> option. In order to remove this potential barrier to entry,
> this module is forked and then modified to use [XML::SAX](https://metacpan.org/pod/XML%3A%3ASAX)
> via [XML::Simple](https://metacpan.org/pod/XML%3A%3ASimple).
# LIMITATIONS AND DIFFERENCES WITH EARLIER VERSIONS
As noted, this module is no longer a _drop-in_ replacement for
`Net::Amazon::S3` and has limitations and differences that may impact
the use of this module in your applications. Additionally, one of the
original intents of this fork of `Net::Amazon::S3` was to reduce the
number of dependencies and make it _easy to install_. Recent changes
to this module have introduced new dependencies in order to improve
the maintainability and provide additional features. Installing CPAN
modules is never easy, especially when the dependencies of the
dependencies are impossible to control and include XS modules.
- MINIMUM PERL
Technically, this module should run on versions 5.10 and above,
however some of the dependencies may require higher versions of
`perl` or some lower versions of the dependencies due to conflicts
with other versions of dependencies...it's a crapshoot when dealing
with older `perl` versions and CPAN modules.
You may however, be able to build this module by installing older
versions of those dependencies and take your chances that those older
versions provide enough working features to support `Amazon::S3`. It
is likely they do...and this module has recently been tested on
version 5.10.0 `perl` using some older CPAN modules to resolve
dependency issues.
To build this module on an earlier version of `perl` you may need to
downgrade some modules. In particular I have found this recipe to
work for building and testing on 5.10.0.
In this order install:
HTML::HeadParser 2.14
LWP 6.13
Amazon::S3
...other versions _may_ work...YMMV.
- API Signing
Making calls to AWS APIs requires that the calls be signed. Amazon
has added a new signing method (Signature Version 4) to increase
security around their APIs. This module no longer utilizes Signature
Version V2.
**New regions after January 30, 2014 will only support Signature Version 4.**
See ["Signature Version V4"](#signature-version-v4) below for important details.
- Signature Version 4
[https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html](https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html)
_IMPORTANT NOTE:_
Unlike Signature Version 2, Version 4 requires a regional
parameter. This implies that you need to supply the bucket's region
when signing requests for any API call that involves a specific
bucket. Starting with version 0.55 of this module,
`Amazon::S3::Bucket` provides a new method (`region()`) and accepts
in the constructor a `region` parameter. If a region is not
supplied, the region for the bucket will be set to the region set in
the `account` object (`Amazon::S3`) that you passed to the bucket's
new constructor. Alternatively, you can request that the bucket's new
constructor determine the bucket's region for you by calling the
`get_location_constraint()` method.
When signing API calls, the region for the specific bucket will be
used. For calls that are not regional (`buckets()`, e.g.) the default
region ('us-east-1') will be used.
- Signature Version 2
[https://docs.aws.amazon.com/AmazonS3/latest/userguide/RESTAuthentication.html](https://docs.aws.amazon.com/AmazonS3/latest/userguide/RESTAuthentication.html)
- New APIs
This module does not support some of the newer API method calls
for S3 added after the initial creation of this interface.
- Multipart Upload Support
There are some recently added unit tests for multipart uploads that
seem to indicate this feature is working as expected. Please report
any deviation from expected results if you are using those methods.
For more information regarding multipart uploads visit the link below.
[https://docs.aws.amazon.com/AmazonS3/latest/API/API\_CreateMultipartUpload.html](https://docs.aws.amazon.com/AmazonS3/latest/API/API_CreateMultipartUpload.html)
# METHODS AND SUBROUTINES
## new
Create a new S3 client object. Takes some arguments:
- credentials (optional)
Reference to a class (like `Amazon::Credentials`) that can provide
credentials via the methods:
get_aws_access_key_id()
get_aws_secret_access_key()
get_token()
If you do not provide a credential class you must provide the keys
when you instantiate the object. See below.
_You are strongly encourage to use a class that provides getters. If
you choose to provide your credentials to this class then they will be
stored in this object. If you dump the class you will likely expose
those credentials._
- aws\_access\_key\_id
Use your Access Key ID as the value of the AWSAccessKeyId parameter
in requests you send to Amazon Web Services (when required). Your
Access Key ID identifies you as the party responsible for the
request.
- aws\_secret\_access\_key
Since your Access Key ID is not encrypted in requests to AWS, it
could be discovered and used by anyone. Services that are not free
require you to provide additional information, a request signature,
to verify that a request containing your unique Access Key ID could
only have come from you.
**DO NOT INCLUDE THIS IN SCRIPTS OR APPLICATIONS YOU
DISTRIBUTE. YOU'LL BE SORRY.**
_Consider using a credential class as described above to provide
credentials, otherwise this class will store your credentials for
signing the requests. If you dump this object to logs your credentials
could be discovered._
- token
An optional temporary token that will be inserted in the request along
with your access and secret key. A token is used in conjunction with
temporary credentials when your EC2 instance has
assumed a role and you've scraped the temporary credentials from
_http://169.254.169.254/latest/meta-data/iam/security-credentials_
- secure
Set this to a true value if you want to use SSL-encrypted connections
when connecting to S3. Starting in version 0.49, the default is true.
default: true
- timeout
Defines the time, in seconds, your script should wait or a
response before bailing.
default: 30s
- retry
Enables or disables the library to retry upon errors. This
uses exponential backoff with retries after 1, 2, 4, 8, 16,
32 seconds, as recommended by Amazon.
default: off
- host
Defines the S3 host endpoint to use.
default: s3.amazonaws.com
Note that requests are made to domain buckets when possible. You can
prevent that behavior if either the bucket name does not conform to
DNS bucket naming conventions or you preface the bucket name with '/'.
If you set a region then the host name will be modified accordingly if
it is an Amazon endpoint.
- region
The AWS region you where your bucket is located.
default: us-east-1
- buffer\_size
The default buffer size when reading or writing files.
default: 4096
## signer
Sets or retrieves the signer object. API calls must be signed using
your AWS credentials. By default, starting with version 0.54 the
module will use [Net::Amazon::Signature::V4](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3ASignature%3A%3AV4) as the signer and
instantiate a signer object in the constructor. Note however, that
signers need your credentials and they _will_ get stored by that
class, making them susceptible to inadvertant exfiltration. You have a
few options here:
- 1. Use your own signer.
You may have noticed that you can also provide your own credentials
object forcing this module to use your object for retrieving
credentials. Likewise, you can use your own signer so that this
module's signer never sees or stores those credentials.
- 2. Pass the credentials object and set `cache_signer` to a
false value.
If you pass a credentials object and set `cache_signer` to a false
value, the module will use the credentials object to retrieve
credentials and create a new signer each time an API call is made that
requires signing. This prevents your credentials from being stored
inside of the signer class.
_Note that using your own credentials object that stores your
credentials in plaintext is also going to expose your credentials when
someone dumps the class._
- 3. Pass credentials, set `cache_signer` to a false value.
Unfortunately, while this will prevent [Net::Amazon::Signature::V4](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3ASignature%3A%3AV4)
from hanging on to your credentials, you credentials will be stored in
the `Amazon::S3` object.
Starting with version 0.55 of this module, if you have installed
[Crypt::CBC](https://metacpan.org/pod/Crypt%3A%3ACBC) and [Crypt::Blowfish](https://metacpan.org/pod/Crypt%3A%3ABlowfish), your credentials will be
encrypted using a random key created when the class is
instantiated. While this is more secure than leaving them in
plaintext, if the key is discovered (the key however is not stored in
the object's hash) and the object is dumped, your _encrypted_
credentials can be exposed.
- 4. Use very granular credentials for bucket access only.
Use credentials that only allow access to a bucket or portions of a
bucket required for your application. This will at least limit the
_blast radius_ of any potential security breach.
- 5. Do nothing...send the credentials, use the default signer.
In this case, both the `Amazon::S3` class and the
[Net::Amazon::Signature::V4](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3ASignature%3A%3AV4) have your credentials. Caveat Emptor.
See also [Amazon::Credentials](https://metacpan.org/pod/Amazon%3A%3ACredentials) for more information about safely
storing your credentials and preventing exfiltration.
## region
Sets the region for the API calls. This will also be the
default when instantiating the bucket object unless you pass the
region parameter in the `bucket` method or use the `verify_region`
flag that will _always_ verify the region of the bucket using the
`get_location_constraint` method.
default: us-east-1
## buckets
buckets([verify-region])
- verify-region (optional)
`verify-region` is a boolean value that indicates if the
bucket's region should be verified when the bucket object is
instantiated.
If set to true, this method will call the `bucket` method with
`verify_region` set to true causing the constructor to call the
`get_location_constraint` for each bucket to set the bucket's
region. This will cause a significant decrease in the peformance of
the `buckets()` method. Setting the region for each bucket is
necessary since API operations on buckets require the region of the
bucket when signing API requests. If all of your buckets are in the
same region and you have passed a region parameter to your S3 object,
then that region will be used when calling the constructor of your
bucket objects.
default: false
Returns a reference to a hash containing the metadata for all of the
buckets owned by the accout or (see below) or `undef` on error.
- owner\_id
The owner ID of the bucket's owner.
- owner\_display\_name
The name of the owner account.
- buckets
An array of [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) objects for the account. Returns
`undef` if there are not buckets or an error occurs.
## add\_bucket
add_bucket(bucket-configuration)
`bucket-configuration` is a reference to a hash with bucket configuration
parameters.
- bucket
The name of the bucket. See [Bucket name
rules](https://docs.aws.amazon.com/AmazonS3/latest/userguide/bucketnamingrules.html)
for more details on bucket naming rules.
- acl\_short (optional)
See the set\_acl subroutine for documenation on the acl\_short options
- location\_constraint
- region
The region the bucket is to be created in.
Returns a [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) object on success or `undef` on failure.
## bucket
bucket(bucket, [region])
bucket({ bucket => bucket-name, verify_region => boolean, region => region });
Takes a scalar argument or refernce to a hash of arguments.
You can pass the region or set `verify_region` indicating that
you want the bucket constructor to detemine the bucket region.
If you do not pass the region or set the `verify_region` value, the
region will be set to the default region set in your `Amazon::S3`
object.
See [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) for a complete description of the `bucket`
method.
## delete\_bucket
Takes either a [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) object or a reference to a hash
containing:
- bucket
The name of the bucket to remove
- region
Region the bucket is located in. If not provided, the method will
determine the bucket's region by calling `get_bucket_location`.
Returns a boolean indicating the success or failure of the API
call. Check `err` or `errstr` for error messages.
Note from the [Amazon's documentation](https://docs.aws.amazon.com/AmazonS3/latest/userguide/BucketRestrictions.html)
> If a bucket is empty, you can delete it. After a bucket is deleted,
> the name becomes available for reuse. However, after you delete the
> bucket, you might not be able to reuse the name for various reasons.
>
> For example, when you delete the bucket and the name becomes available
> for reuse, another AWS account might create a bucket with that
> name. In addition, **some time might pass before you can reuse the name
> of a deleted bucket**. If you want to use the same bucket name, we
> recommend that you don't delete the bucket.
## dns\_bucket\_names
Set or get a boolean that indicates whether to use DNS bucket
names.
default: true
## list\_bucket, list\_bucket\_v2
List all keys in this bucket.
Takes a reference to a hash of arguments:
- bucket (required)
The name of the bucket you want to list keys on.
- prefix
Restricts the response to only contain results that begin with the
specified prefix. If you omit this optional argument, the value of
prefix for your query will be the empty string. In other words, the
results will be not be restricted by prefix.
- delimiter
If this optional, Unicode string parameter is included with your
request, then keys that contain the same string between the prefix
and the first occurrence of the delimiter will be rolled up into a
single result element in the CommonPrefixes collection. These
rolled-up keys are not returned elsewhere in the response. For
example, with prefix="USA/" and delimiter="/", the matching keys
"USA/Oregon/Salem" and "USA/Oregon/Portland" would be summarized
in the response as a single "USA/Oregon" element in the CommonPrefixes
collection. If an otherwise matching key does not contain the
delimiter after the prefix, it appears in the Contents collection.
Each element in the CommonPrefixes collection counts as one against
the MaxKeys limit. The rolled-up keys represented by each CommonPrefixes
element do not. If the Delimiter parameter is not present in your
request, keys in the result set will not be rolled-up and neither
the CommonPrefixes collection nor the NextMarker element will be
present in the response.
NOTE: CommonPrefixes isn't currently supported by Amazon::S3.
- max-keys
This optional argument limits the number of results returned in
response to your query. Amazon S3 will return no more than this
number of results, but possibly less. Even if max-keys is not
specified, Amazon S3 will limit the number of results in the response.
Check the IsTruncated flag to see if your results are incomplete.
If so, use the Marker parameter to request the next page of results.
For the purpose of counting max-keys, a 'result' is either a key
in the 'Contents' collection, or a delimited prefix in the
'CommonPrefixes' collection. So for delimiter requests, max-keys
limits the total number of list results, not just the number of
keys.
- marker
This optional parameter enables pagination of large result sets.
`marker` specifies where in the result set to resume listing. It
restricts the response to only contain results that occur alphabetically
after the value of marker. To retrieve the next page of results,
use the last key from the current page of results as the marker in
your next request.
See also `next_marker`, below.
If `marker` is omitted,the first page of results is returned.
Returns `undef` on error and a reference to a hash of data on success:
The return value looks like this:
{
bucket => $bucket_name,
prefix => $bucket_prefix,
marker => $bucket_marker,
next_marker => $bucket_next_available_marker,
max_keys => $bucket_max_keys,
is_truncated => $bucket_is_truncated_boolean
keys => [$key1,$key2,...]
}
- is\_truncated
Boolean flag that indicates whether or not all results of your query were
returned in this response. If your results were truncated, you can
make a follow-up paginated request using the Marker parameter to
retrieve the rest of the results.
- next\_marker
A convenience element, useful when paginating with delimiters. The
value of `next_marker`, if present, is the largest (alphabetically)
of all key names and all CommonPrefixes prefixes in the response.
If the `is_truncated` flag is set, request the next page of results
by setting `marker` to the value of `next_marker`. This element
is only present in the response if the `delimiter` parameter was
sent with the request.
Each key is a reference to a hash that looks like this:
{
key => $key,
last_modified => $last_mod_date,
etag => $etag, # An MD5 sum of the stored content.
size => $size, # Bytes
storage_class => $storage_class # Doc?
owner_id => $owner_id,
owner_displayname => $owner_name
}
## get\_bucket\_location
get_bucket_location(bucket-name)
get_bucket_locaiton(bucket-obj)
This is a convenience routines for the `get_location_constraint()` of
the bucket object. This method will return the default
region of 'us-east-1' when `get_location_constraint()` returns a null
value.
my $region = $s3->get_bucket_location('my-bucket');
Starting with version 0.55, `Amazon::S3::Bucket` will call this
`get_location_constraint()` to determine the region for the
bucket. You can get the region for the bucket by using the `region()`
method of the bucket object.
my $bucket = $s3->bucket('my-bucket');
my $bucket_region = $bucket->region;
## get\_logger
Returns the logger object. If you did not set a logger when you
created the object then an instance of `Amazon::S3::Logger` is
returned. You can log to STDERR using this logger. For example:
$s3->get_logger->debug('this is a debug message');
$s3->get_logger->trace(sub { return Dumper([$response]) });
## list\_bucket\_all, list\_bucket\_all\_v2
List all keys in this bucket without having to worry about
'marker'. This is a convenience method, but may make multiple requests
to S3 under the hood.
Takes the same arguments as `list_bucket`.
_You are encouraged to use the newer `list_bucket_all_v2` method._
## err
The S3 error code for the last error encountered.
## errstr
A human readable error string for the last error encountered.
## error
The decoded XML string as a hash object of the last error.
## last\_response
Returns the last [HTTP::Response](https://metacpan.org/pod/HTTP%3A%3AResponse) object.
## last\_request
Returns the last [HTTP::Request](https://metacpan.org/pod/HTTP%3A%3ARequest) object.
## level
Set the logging level.
default: error
## turn\_on\_special\_retry
Called to add extra retry codes if retry has been set
## turn\_off\_special\_retry
Called to turn off special retry codes when we are deliberately triggering them
# ABOUT
This module contains code modified from Amazon that contains the
following notice:
# This software code is made available "AS IS" without warranties of any
# kind. You may copy, display, modify and redistribute the software
# code either by itself or as incorporated into your code; provided that
# you do not remove any proprietary notices. Your use of this software
# code is at your own risk and you waive any claim against Amazon
# Digital Services, Inc. or its affiliates with respect to your use of
# this software code. (c) 2006 Amazon Digital Services, Inc. or its
# affiliates.
# TESTING
Testing S3 is a tricky thing. Amazon wants to charge you a bit of
money each time you use their service. And yes, testing counts as using.
Because of this, the application's test suite skips anything approaching
a real test unless you set these environment variables:
For more on testing this module see [README-TESTING.md](https://github.com/rlauer6/perl-amazon-s3/blob/master/README-TESTING.md)
- AMAZON\_S3\_EXPENSIVE\_TESTS
Doesn't matter what you set it to. Just has to be set
- AMAZON\_S3\_HOST
Sets the host to use for the API service.
default: s3.amazonaws.com
Note that if this value is set, DNS bucket name usage will be disabled
for testing. Most likely, if you set this variable, you are using a
mocking service and your bucket names are probably not resolvable. You
can override this behavior by setting `AWS_S3_DNS_BUCKET_NAMES` to any
value.
- AWS\_S3\_DSN\_BUCKET\_NAMES
Set this to any value to override the default behavior of disabling
DNS bucket names during testing.
- AWS\_ACCESS\_KEY\_ID
Your AWS access key
- AWS\_SECRET\_ACCESS\_KEY
Your AWS sekkr1t passkey. Be forewarned that setting this environment variable
on a shared system might leak that information to another user. Be careful.
- AMAZON\_S3\_SKIP\_ACL\_TESTS
Doesn't matter what you set it to. Just has to be set if you want
to skip ACLs tests.
- AMAZON\_S3\_SKIP\_PERMISSIONS
Skip tests that check for enforcement of ACLs...as of this version,
LocalStack for example does not support enforcement of ACLs.
- AMAZON\_S3\_SKIP\_REGION\_CONSTRAINT\_TEST
Doesn't matter what you set it to. Just has to be set if you want
to skip region constraint test.
- AMAZON\_S3\_MINIO
Doesn't matter what you set it to. Just has to be set if you want
to skip tests that would fail on minio.
- AMAZON\_S3\_LOCALSTACK
Doesn't matter what you set it to. Just has to be set if you want
to skip tests that would fail on LocalStack.
- AMAZON\_S3\_REGIONS
A comma delimited list of regions to use for testing. The default will
only test creating a bucket in the local region.
_Consider using an S3 mocking service like `minio` or `LocalStack`
if you want to create real tests for your applications or this module._
Here's bash script for testing using LocalStack
#!/bin/bash
# -*- mode: sh; -*-
BUCKET=net-amazon-s3-test-test
ENDPOINT_URL=s3.localhost.localstack.cloud:4566
AMAZON_S3_EXPENSIVE_TESTS=1 \
AMAZON_S3_HOST=$ENDPOINT_URL \
AMAZON_S3_LOCALSTACK=1 \
AWS_ACCESS_KEY_ID=test \
AWS_ACCESS_SECRET_KEY=test \
AMAZON_S3_DOMAIN_BUCKET_NAMES=1 make test 2>&1 | tee test.log
To run the tests...clone the project and build the software.
cd src/main/perl
./test.localstack
# ADDITIONAL INFORMATION
## LOGGING AND DEBUGGING
Additional debugging information can be output to STDERR by setting
the `level` option when you instantiate the `Amazon::S3`
object. Levels are represented as a string. The valid levels are:
fatal
error
warn
info
debug
trace
You can set an optionally pass in a logger that implements a subset of
the `Log::Log4perl` interface. Your logger should support at least
these method calls. If you do not supply a logger the default logger
(`Amazon::S3::Logger`) will be used.
get_logger()
fatal()
error()
warn()
info()
debug()
trace()
level()
At the `trace` level, every HTTP request and response will be output
to STDERR. At the `debug` level information regarding the higher
level methods will be output to STDERR. There currently is no
additional information logged at lower levels.
## S3 LINKS OF INTEREST
- [Bucket restrictions and limitations](https://docs.aws.amazon.com/AmazonS3/latest/userguide/BucketRestrictions.html)
- [Bucket naming rules](https://docs.aws.amazon.com/AmazonS3/latest/userguide/bucketnamingrules.html)
- [Amazon S3 REST API](https://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html)
- [Authenticating Requests (AWS Signature Version 4)](https://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-authenticating-requests.html)
- [Authenticating Requests (AWS Signature Version 2)](https://docs.aws.amazon.com/AmazonS3/latest/userguide/RESTAuthentication.html)
- [LocalStack](https://localstack.io)
# SUPPORT
Bugs should be reported via the CPAN bug tracker at
[http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Amazon-S3](http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Amazon-S3)
For other issues, contact the author.
# REPOSITORY
[https://github.com/rlauer6/perl-amazon-s3](https://github.com/rlauer6/perl-amazon-s3)
# AUTHOR
Original author: Timothy Appnel
Current maintainer: Rob Lauer
# SEE ALSO
[Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket), [Net::Amazon::S3](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3AS3)
# COPYRIGHT AND LICENCE
This module was initially based on [Net::Amazon::S3](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3AS3) 0.41, by
Leon Brocard. Net::Amazon::S3 was based on example code from
Amazon with this notice:
_This software code is made available "AS IS" without warranties of any
kind. You may copy, display, modify and redistribute the software
code either by itself or as incorporated into your code; provided that
you do not remove any proprietary notices. Your use of this software
code is at your own risk and you waive any claim against Amazon
Digital Services, Inc. or its affiliates with respect to your use of
this software code. (c) 2006 Amazon Digital Services, Inc. or its
affiliates._
The software is released under the Artistic License. The
terms of the Artistic License are described at
http://www.perl.com/language/misc/Artistic.html. Except
where otherwise noted, `Amazon::S3` is Copyright 2008, Timothy
Appnel, tima@cpan.org. All rights reserved.
Amazon-S3-0.65/lib/ 0000755 0001750 0001750 00000000000 14531467536 013614 5 ustar rclauer rclauer Amazon-S3-0.65/lib/Amazon/ 0000755 0001750 0001750 00000000000 14531467536 015041 5 ustar rclauer rclauer Amazon-S3-0.65/lib/Amazon/S3/ 0000755 0001750 0001750 00000000000 14531467536 015326 5 ustar rclauer rclauer Amazon-S3-0.65/lib/Amazon/S3/Signature/ 0000755 0001750 0001750 00000000000 14531467536 017267 5 ustar rclauer rclauer Amazon-S3-0.65/lib/Amazon/S3/Signature/V4.pm 0000644 0001750 0001750 00000001540 14531467536 020116 0 ustar rclauer rclauer package Amazon::S3::Signature::V4;
use strict;
use warnings;
use parent qw{Net::Amazon::Signature::V4};
########################################################################
sub new {
########################################################################
my ( $class, @args ) = @_;
my %options;
if ( !ref $args[0] ) {
@options{qw{access_key_id secret endpoint service}} = @args;
}
else {
%options = %{ $args[0] };
}
my $region = delete $options{region};
$options{endpoint} //= $region;
my $self = $class->SUPER::new( \%options );
return $self;
}
########################################################################
sub region {
########################################################################
my ( $self, @args ) = @_;
if (@args) {
$self->{endpoint} = $args[0];
}
return $self->{endpoint};
}
1;
Amazon-S3-0.65/lib/Amazon/S3/Logger.pm 0000644 0001750 0001750 00000003623 14531467536 017107 0 ustar rclauer rclauer package Amazon::S3::Logger;
use strict;
use warnings;
use Amazon::S3::Constants qw{ :chars };
use English qw{-no_match_vars};
use POSIX;
use Readonly;
use Scalar::Util qw{ reftype };
our $VERSION = '0.65'; ## no critic (RequireInterpolationOfMetachars)
Readonly::Hash our %LOG_LEVELS => (
trace => 5,
debug => 4,
info => 3,
warn => 2,
error => 1,
fatal => 0,
);
{
no strict 'refs'; ## no critic (ProhibitNoStrict)
foreach my $level (qw{fatal error warn info debug trace}) {
*{ __PACKAGE__ . $DOUBLE_COLON . $level } = sub {
my ( $self, @message ) = @_;
$self->_log_message( $level, @message );
};
}
}
########################################################################
sub new {
########################################################################
my ( $class, @args ) = @_;
my $options = ref $args[0] ? $args[0] : {@args};
return bless $options, $class;
}
########################################################################
sub level {
########################################################################
my ( $self, @args ) = @_;
if (@args) {
$self->{log_level} = $args[0];
}
return $self->{log_level};
}
########################################################################
sub _log_message {
########################################################################
my ( $self, $level, @message ) = @_;
return if $LOG_LEVELS{ lc $level } > $LOG_LEVELS{ lc $self->{log_level} };
return if !@message;
my $log_message;
if ( defined $message[0]
&& ref $message[0]
&& reftype( $message[0] ) eq 'CODE' ) {
$log_message = $message[0]->();
}
else {
$log_message = join $EMPTY, @message;
}
chomp $log_message;
my @tm = localtime time;
my $timestamp = POSIX::strftime '%Y/%m/%d %H:%M:%S', @tm;
return print {*STDERR} sprintf qq{%s: %s %s %s\n}, uc $level, $timestamp,
$PROCESS_ID, $log_message;
}
1;
Amazon-S3-0.65/lib/Amazon/S3/Constants.pm 0000644 0001750 0001750 00000006711 14531467536 017645 0 ustar rclauer rclauer package Amazon::S3::Constants;
use strict;
use warnings;
use parent qw(Exporter);
use Readonly;
our $VERSION = '0.65'; ## no critic (RequireInterpolation)
# defaults
Readonly our $AMAZON_HEADER_PREFIX => 'x-amz-';
Readonly our $DEFAULT_BUFFER_SIZE => 4 * 1024;
Readonly our $DEFAULT_HOST => 's3.amazonaws.com';
Readonly our $DEFAULT_TIMEOUT => 30;
Readonly our $KEEP_ALIVE_CACHESIZE => 0;
Readonly our $METADATA_PREFIX => 'x-amz-meta-';
Readonly our $MAX_BUCKET_NAME_LENGTH => 64;
Readonly our $MIN_BUCKET_NAME_LENGTH => 3;
Readonly our $MIN_MULTIPART_UPLOAD_CHUNK_SIZE => 5 * 1024 * 1024;
Readonly our $DEFAULT_LOG_LEVEL => 'error';
Readonly our $MAX_DELETE_KEYS => 1000;
Readonly our $MAX_RETRIES => 5;
Readonly our $DEFAULT_REGION => 'us-east-1';
Readonly our $XMLDECL => '';
Readonly our $S3_XMLNS => 'http://s3.amazonaws.com/doc/2006-03-01/';
Readonly::Hash our %LOG_LEVELS => (
trace => 5,
debug => 4,
info => 3,
warn => 2,
error => 1,
fatal => 0,
);
Readonly::Hash our %LIST_OBJECT_MARKERS => (
'2' => [qw(ContinuationToken NextContinuationToken continuation-token)],
'1' => [qw(Marker NextMarker marker)],
);
# booleans
Readonly our $TRUE => 1;
Readonly our $FALSE => 0;
# chars
Readonly our $COMMA => q{,};
Readonly our $COLON => q{:};
Readonly our $DOT => q{.};
Readonly our $DOUBLE_COLON => q{::};
Readonly our $EMPTY => q{};
Readonly our $SLASH => q{/};
Readonly our $QUESTION_MARK => q{?};
Readonly our $AMPERSAND => q{&};
Readonly our $EQUAL_SIGN => q{=};
# HTTP codes
Readonly our $HTTP_BAD_REQUEST => 400;
Readonly our $HTTP_UNAUTHORIZED => 401;
Readonly our $HTTP_PAYMENT_RQUIRED => 402;
Readonly our $HTTP_FORBIDDEN => 403;
Readonly our $HTTP_NOT_FOUND => 404;
Readonly our $HTTP_CONFLICT => 409;
Readonly our $HTTP_MOVED_PERMANENTLY => 301;
Readonly our $HTTP_FOUND => 302;
Readonly our $HTTP_SEE_OTHER => 303;
Readonly our $HTTP_NOT_MODIFIED => 304;
our %EXPORT_TAGS = (
chars => [
qw(
$AMPERSAND
$COLON
$DOUBLE_COLON
$DOT
$COMMA
$EMPTY
$EQUAL_SIGN
$QUESTION_MARK
$SLASH
)
],
booleans => [
qw(
$TRUE
$FALSE
)
],
defaults => [
qw(
$AMAZON_HEADER_PREFIX
$METADATA_PREFIX
$KEEP_ALIVE_CACHESIZE
$DEFAULT_TIMEOUT
$DEFAULT_BUFFER_SIZE
$DEFAULT_LOG_LEVEL
$DEFAULT_HOST
$DEFAULT_REGION
$MAX_BUCKET_NAME_LENGTH
$MAX_DELETE_KEYS
$MIN_BUCKET_NAME_LENGTH
$MIN_MULTIPART_UPLOAD_CHUNK_SIZE
$MAX_RETRIES
)
],
misc => [
qw(
$S3_XMLNS
$XMLDECL
%LIST_OBJECT_MARKERS
%LOG_LEVELS
$NOT_FOUND
)
],
http => [
qw(
$HTTP_BAD_REQUEST
$HTTP_CONFLICT
$HTTP_UNAUTHORIZED
$HTTP_PAYMENT_RQUIRED
$HTTP_FORBIDDEN
$HTTP_NOT_FOUND
$HTTP_MOVED_PERMANENTLY
$HTTP_FOUND
$HTTP_SEE_OTHER
$HTTP_NOT_MODIFIED
)
],
);
our @EXPORT_OK = map { @{ $EXPORT_TAGS{$_} } } keys %EXPORT_TAGS;
$EXPORT_TAGS{all} = [@EXPORT_OK];
1;
## no critic (RequirePodSections)
__END__
=pod
=head1 NAME
Amazon::S3::Constants - constants and defaults for Amazon::S3
=head1 AUTHOR
Rob Lauer -
=cut
Amazon-S3-0.65/lib/Amazon/S3/Bucket.pm 0000644 0001750 0001750 00000127542 14531467536 017114 0 ustar rclauer rclauer package Amazon::S3::Bucket;
use strict;
use warnings;
use Amazon::S3::Constants qw(:all);
use Carp;
use Data::Dumper;
use Digest::MD5 qw(md5 md5_hex);
use Digest::MD5::File qw(file_md5 file_md5_hex);
use English qw(-no_match_vars);
use File::stat;
use IO::File;
use IO::Scalar;
use MIME::Base64;
use Scalar::Util qw(reftype);
use URI;
use XML::Simple; ## no critic (DiscouragedModules)
use parent qw(Class::Accessor::Fast);
our $VERSION = '0.65'; ## no critic (RequireInterpolation)
__PACKAGE__->mk_accessors(
qw(
bucket
creation_date
account
buffer_size
region
logger
verify_region
),
);
########################################################################
sub new {
########################################################################
my ( $class, @args ) = @_;
my %options = ref $args[0] ? %{ $args[0] } : @args;
$options{buffer_size} ||= $DEFAULT_BUFFER_SIZE;
my $self = $class->SUPER::new( \%options );
croak 'no bucket'
if !$self->bucket;
croak 'no account'
if !$self->account;
if ( !$self->logger ) {
$self->logger( $self->account->get_logger );
}
# now each bucket maintains its own region
if ( !$self->region && $self->verify_region ) {
my $region;
if ( !$self->account->err ) {
$region = $self->get_location_constraint() // 'us-east-1';
}
$self->logger->debug( sprintf "bucket: %s region: %s\n",
$self->bucket, ( $region // $EMPTY ) );
$self->region($region);
}
elsif ( !$self->region ) {
$self->region( $self->account->region );
}
return $self;
}
########################################################################
sub _uri {
########################################################################
my ( $self, $key ) = @_;
if ($key) {
$key =~ s/^\///xsm;
}
my $account = $self->account;
my $uri
= ($key)
? $self->bucket . $SLASH . $account->_urlencode($key)
: $self->bucket . $SLASH;
if ( $account->dns_bucket_names ) {
$uri =~ s/^\///xsm;
}
return $uri;
}
########################################################################
sub add_key {
########################################################################
my ( $self, $key, $value, $conf ) = @_;
croak 'must specify key'
if !$key || !length $key;
my $account = $self->account;
if ( $conf->{acl_short} ) {
$account->_validate_acl_short( $conf->{acl_short} );
$conf->{'x-amz-acl'} = $conf->{acl_short};
delete $conf->{acl_short};
}
if ( ref($value) && reftype($value) eq 'SCALAR' ) {
my $md5_hex = file_md5_hex( ${$value} );
my $md5 = pack 'H*', $md5_hex;
my $md5_base64 = encode_base64($md5);
chomp $md5_base64;
$conf->{'Content-MD5'} = $md5_base64;
$conf->{'Content-Length'} ||= -s ${$value};
$value = _content_sub( ${$value}, $self->buffer_size );
$conf->{'x-amz-content-sha256'} = 'UNSIGNED-PAYLOAD';
}
else {
$conf->{'Content-Length'} ||= length $value;
my $md5 = md5($value);
my $md5_hex = unpack 'H*', $md5;
my $md5_base64 = encode_base64($md5);
$conf->{'Content-MD5'} = $md5_base64;
}
# 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
my $retval = eval {
return $self->_add_key(
{ headers => $conf,
data => $value,
key => $key,
},
);
};
# one more try? if someone specified the wrong region, we'll get a
# 301 and you'll only know the region of redirection - no location
# header provided...
if ($EVAL_ERROR) {
my $rsp = $account->last_response;
if ( $rsp->code eq $HTTP_MOVED_PERMANENTLY ) {
$self->region( $rsp->headers->{'x-amz-bucket-region'} );
}
$retval = $self->_add_key(
{ headers => $conf,
data => $value,
key => $key,
},
);
}
return $retval;
}
########################################################################
sub _add_key {
########################################################################
my ( $self, @args ) = @_;
my ( $data, $headers, $key ) = @{ $args[0] }{qw{data headers key}};
my $account = $self->account;
if ( ref $data ) {
return $account->_send_request_expect_nothing_probed(
{ method => 'PUT',
path => $self->_uri($key),
headers => $headers,
data => $data,
region => $self->region,
},
);
}
else {
return $account->_send_request_expect_nothing(
{ method => 'PUT',
path => $self->_uri($key),
headers => $headers,
data => $data,
region => $self->region,
},
);
}
}
########################################################################
sub add_key_filename {
########################################################################
my ( $self, $key, $value, $conf ) = @_;
return $self->add_key( $key, \$value, $conf );
}
########################################################################
sub upload_multipart_object {
########################################################################
my ( $self, @args ) = @_;
my $logger = $self->logger;
my %parameters;
if ( @args == 1 && reftype( $args[0] ) eq 'HASH' ) {
%parameters = %{ $args[0] };
}
else {
%parameters = @args;
}
croak 'no key!'
if !$parameters{key};
croak 'either data, callback or fh must be set!'
if !$parameters{data} && !$parameters{callback} && !$parameters{fh};
croak 'callback must be a reference to a subroutine!'
if $parameters{callback} && reftype( $parameters{callback} ) ne 'CODE';
$parameters{abort_on_error} //= $TRUE;
$parameters{chunk_size} //= $MIN_MULTIPART_UPLOAD_CHUNK_SIZE;
if ( !$parameters{callback} && !$parameters{fh} ) {
#...but really nobody should be passing a >5MB scalar
my $data = ref $parameters{data} ? $parameters{data} : \$parameters{data};
$parameters{fh} = IO::Scalar->new($data);
}
# ...having a file handle implies, we use this callback
if ( $parameters{fh} ) {
my $fh = $parameters{fh};
$fh->seek( 0, 2 );
my $length = $fh->tell;
$fh->seek( 0, 0 );
$logger->trace( sub { return sprintf 'length of object: %s', $length; } );
croak 'length of the object must be >= '
. $MIN_MULTIPART_UPLOAD_CHUNK_SIZE
if $length < $MIN_MULTIPART_UPLOAD_CHUNK_SIZE;
my $chunk_size
= ( $parameters{chunk_size} && $parameters{chunk_size} )
> $MIN_MULTIPART_UPLOAD_CHUNK_SIZE
? $parameters{chunk_size}
: $MIN_MULTIPART_UPLOAD_CHUNK_SIZE;
$parameters{callback} = sub {
return
if !$length;
my $bytes_read = 0;
my $n = $length >= $chunk_size ? $chunk_size : $length;
$logger->trace( sprintf 'reading %d bytes', $n );
my $buffer;
my $bytes = $fh->read( $buffer, $n, $bytes_read );
$logger->trace( sprintf 'read %d bytes', $bytes );
$bytes_read += $bytes;
$length -= $bytes;
$logger->trace( sprintf '%s bytes left to read', $length );
return ( \$buffer, $bytes );
};
}
my $headers = $parameters{headers} || {};
my $id = $self->initiate_multipart_upload( $parameters{key}, $headers );
$logger->trace( sprintf 'multipart id: %s', $id );
my $part = 1;
my %parts;
my $key = $parameters{key};
my $retval = eval {
while (1) {
my ( $buffer, $length ) = $parameters{callback}->();
last if !$buffer;
my $etag = $self->upload_part_of_multipart_upload(
{ id => $id,
key => $key,
data => $buffer,
part => $part,
},
);
$parts{ $part++ } = $etag;
}
$self->complete_multipart_upload( $parameters{key}, $id, \%parts );
};
if ( $EVAL_ERROR && $parameters{abort_on_error} ) {
$self->abort_multipart_upload( $key, $id );
%parts = ();
}
return \%parts;
}
# Initiates a multipart upload operation. This is necessary for uploading
# files > 5Gb to Amazon S3
#
# returns: upload ID assigned by Amazon (used to identify this
# particular upload in other operations)
########################################################################
sub initiate_multipart_upload {
########################################################################
my ( $self, $key, $conf ) = @_;
croak 'Object key is required'
if !$key;
my $acct = $self->account;
my $request = $acct->_make_request(
{ region => $self->region,
method => 'POST',
path => $self->_uri($key) . '?uploads=',
headers => $conf,
},
);
my $response = $acct->_do_http($request);
$acct->_croak_if_response_error($response);
my $r = $acct->_xpc_of_content( $response->content );
return $r->{UploadId};
}
#
# Upload a part of a file as part of a multipart upload operation
# Each part must be at least 5mb (except for the last piece).
# This returns the Amazon-generated eTag for the uploaded file segment.
# It is necessary to keep track of the eTag for each part number
# The complete operation will want a sequential list of all the part
# numbers along with their eTags.
#
########################################################################
sub upload_part_of_multipart_upload {
########################################################################
my ( $self, @args ) = @_;
my ( $key, $upload_id, $part_number, $data, $length );
if ( @args == 1 ) {
if ( reftype( $args[0] ) eq 'HASH' ) {
( $key, $upload_id, $part_number, $data, $length )
= @{ $args[0] }{qw{ key id part data length}};
}
elsif ( reftype( $args[0] ) eq 'ARRAY' ) {
( $key, $upload_id, $part_number, $data, $length ) = @{ $args[0] };
}
}
else {
( $key, $upload_id, $part_number, $data, $length ) = @args;
}
# argh...wish we didn't have to do this!
if ( ref $data ) {
$data = ${$data};
}
$length = $length || length $data;
croak 'Object key is required'
if !$key;
croak 'Upload id is required'
if !$upload_id;
croak 'Part Number is required'
if !$part_number;
my $conf = {};
my $acct = $self->account;
# Make sure length and md5 are set
my $md5 = md5($data);
my $md5_hex = unpack 'H*', $md5;
my $md5_base64 = encode_base64($md5);
$conf->{'Content-MD5'} = $md5_base64;
$conf->{'Content-Length'} = $length;
my $params = "?partNumber=${part_number}&uploadId=${upload_id}";
$self->logger->debug( 'uploading ' . sprintf 'part: %s length: %s',
$part_number, length $data );
my $request = $acct->_make_request(
{ region => $self->region,
method => 'PUT',
path => $self->_uri($key) . $params,
headers => $conf,
data => $data,
},
);
my $response = $acct->_do_http($request);
$acct->_croak_if_response_error($response);
# We'll need to save the etag for later when completing the transaction
my $etag = $response->header('ETag');
if ($etag) {
$etag =~ s/^"//xsm;
$etag =~ s/"$//xsm;
}
return $etag;
}
########################################################################
sub make_xml_document_simple {
########################################################################
my ($parts_hr) = @_;
my $xml = q{};
my $xml_template
= '%s%s';
my @parts;
foreach my $part_num ( sort { $a <=> $b } keys %{$parts_hr} ) {
push @parts, sprintf $xml_template, $part_num, $parts_hr->{$part_num};
}
$xml .= sprintf "\n%s\n",
join q{}, @parts;
return $xml;
}
#
# Inform Amazon that the multipart upload has been completed
# You must supply a hash of part Numbers => eTags
# For amazon to use to put the file together on their servers.
#
########################################################################
sub complete_multipart_upload {
########################################################################
my ( $self, $key, $upload_id, $parts_hr ) = @_;
$self->logger->debug( Dumper( [ $key, $upload_id, $parts_hr ] ) );
croak 'Object key is required'
if !$key;
croak 'Upload id is required'
if !$upload_id;
croak 'Part number => etag hashref is required'
if ref $parts_hr ne 'HASH';
# The complete command requires sending a block of xml containing all
# the part numbers and their associated etags (returned from the upload)
# build XML doc
my $content = make_xml_document_simple($parts_hr);
$self->logger->debug("content: \n$content");
my $md5 = md5($content);
my $md5_base64 = encode_base64($md5);
chomp $md5_base64;
my $conf = {
'Content-MD5' => $md5_base64,
'Content-Length' => length $content,
'Content-Type' => 'application/xml',
};
my $acct = $self->account;
my $params = "?uploadId=${upload_id}";
my $request = $acct->_make_request(
{ region => $self->region,
method => 'POST',
path => $self->_uri($key) . $params,
headers => $conf,
data => $content,
},
);
my $response = $acct->_do_http($request);
if ( $response->code !~ /\A2\d\d\z/xsm ) {
$acct->_remember_errors( $response->content, 1 );
croak $response->status_line;
}
return $TRUE;
}
#
# Stop a multipart upload
#
########################################################################
sub abort_multipart_upload {
########################################################################
my ( $self, $key, $upload_id ) = @_;
croak 'Object key is required'
if !$key;
croak 'Upload id is required'
if !$upload_id;
my $acct = $self->account;
my $params = "?uploadId=${upload_id}";
my $request = $acct->_make_request(
{ region => $self->region,
method => 'DELETE',
path => $self->_uri($key) . $params,
},
);
my $response = $acct->_do_http($request);
$acct->_croak_if_response_error($response);
return $TRUE;
}
#
# List all the uploaded parts for an ongoing multipart upload
# It returns the block of XML returned from Amazon
#
########################################################################
sub list_multipart_upload_parts {
########################################################################
my ( $self, $key, $upload_id, $conf ) = @_;
croak 'Object key is required'
if !$key;
croak 'Upload id is required'
if !$upload_id;
my $acct = $self->account;
my $params = "?uploadId=${upload_id}";
my $request = $acct->_make_request(
{ region => $self->region,
method => 'GET',
path => $self->_uri($key) . $params,
headers => $conf,
},
);
my $response = $acct->_do_http($request);
$acct->_croak_if_response_error($response);
# Just return the XML, let the caller figure out what to do with it
return $response->content;
}
#
# List all the currently active multipart upload operations
# Returns the block of XML returned from Amazon
#
########################################################################
sub list_multipart_uploads {
########################################################################
my ( $self, $conf ) = @_;
my $acct = $self->account;
my $request = $acct->_make_request(
{ region => $self->region,
method => 'GET',
path => $self->_uri() . '?uploads',
headers => $conf,
},
);
my $response = $acct->_do_http($request);
$acct->_croak_if_response_error($response);
# Just return the XML, let the caller figure out what to do with it
return $response->content;
}
########################################################################
sub head_key {
########################################################################
my ( $self, $key ) = @_;
return $self->get_key( $key, 'HEAD' );
}
########################################################################
sub get_key {
########################################################################
my ( $self, $key, $method, $filename ) = @_;
$method ||= 'GET';
if ( ref $filename ) {
$filename = ${$filename};
}
my $acct = $self->account;
my $uri = $self->_uri($key);
my $request = $acct->_make_request(
{ region => $self->region,
method => $method,
path => $uri,
headers => {},
},
);
my $retval;
my $response = $acct->_do_http( $request, $filename );
return $retval
if $response->code eq $HTTP_NOT_FOUND;
$acct->_croak_if_response_error($response);
my $etag = $response->header('ETag');
if ($etag) {
$etag =~ s/^"//xsm;
$etag =~ s/"$//xsm;
}
$retval = {
content_length => $response->content_length || 0,
content_type => $response->content_type,
etag => $etag,
value => $response->content,
};
# Validate against data corruption by verifying the MD5
if ( $method eq 'GET' ) {
my $md5
= ( $filename and -f $filename )
? file_md5_hex($filename)
: md5_hex( $retval->{value} );
# Some S3-compatible providers return an all-caps MD5 value in the
# etag so it should be lc'd for comparison.
croak "Computed and Response MD5's do not match: $md5 : $etag"
if $md5 ne lc $etag;
}
foreach my $header ( $response->headers->header_field_names ) {
next if $header !~ /x-amz-meta-/ixsm;
$retval->{ lc $header } = $response->header($header);
}
return $retval;
}
########################################################################
sub get_key_filename {
########################################################################
my ( $self, $key, $method, $filename ) = @_;
if ( !defined $filename ) {
$filename = $key;
}
return $self->get_key( $key, $method, \$filename );
}
########################################################################
# See: https://docs.aws.amazon.com/AmazonS3/latest/API/API_CopyObject.html
#
# Note that in this request the bucket object is the destination you
# specify the source bucket in the key (bucket-name/source-key) or the
# header x-amz-copy-source
########################################################################
sub copy_object {
########################################################################
my ( $self, %parameters ) = @_;
my ( $source, $key, $bucket, $headers_in )
= @parameters{qw(source key bucket headers)};
$headers_in //= {};
my %request_headers;
if ( reftype($headers_in) eq 'ARRAY' ) {
%request_headers = @{$headers_in};
}
elsif ( reftype($headers_in) eq 'HASH' ) {
%request_headers = %{$headers_in};
}
else {
croak 'headers must be hash or array'
if !ref($headers_in) || reftype($headers_in) ne 'HASH';
}
croak 'source or x-amz-copy-source must be specified'
if !$source && !exists $request_headers{'x-amz-copy-source'};
croak 'no key'
if !$key;
my $acct = $self->account;
if ( !$request_headers{'x-amz-copy-source'} ) {
$request_headers{'x-amz-copy-source'} = sprintf '%s/%s',
$bucket // $self->{bucket},
$acct->_urlencode($source);
}
$request_headers{'x-amz-tagging-directive'} //= 'COPY';
$key = $self->_uri($key);
my $request = $acct->_make_request( 'PUT', $key, \%request_headers, );
my $response = $acct->_do_http($request);
if ( $response->code !~ /\A2\d\d\z/xsm ) {
$acct->_remember_errors( $response->content, 1 );
croak $response->status_line;
}
return $acct->_xpc_of_content( $response->content );
}
########################################################################
sub delete_key {
########################################################################
my ( $self, $key ) = @_;
croak 'must specify key'
if !$key && length $key;
my $account = $self->account;
return $account->_send_request_expect_nothing(
{ method => 'DELETE',
region => $self->region,
path => $self->_uri($key),
headers => {},
},
);
}
########################################################################
sub _format_delete_keys {
########################################################################
my (@args) = @_;
my @keys;
if ( ref $args[0] ) {
if ( reftype( $args[0] ) eq 'ARRAY' ) { # list of keys, no version ids
foreach my $key ( @{ $args[0] } ) {
if ( ref($key) && reftype($key) eq 'HASH' ) {
push @keys,
{
Key => [ $key->{Key} ],
defined $key->{VersionId}
? ( VersionId => [ $key->{VersionId} ] )
: (),
};
}
else { # array of keys
push @keys, { Key => [$key], };
}
}
}
elsif ( reftype( $args[0] ) eq 'CODE' ) { # sub that returns key, version id
while ( my (@object) = $args[0]->() ) {
last if !@object || !defined $object[0];
push @keys,
{
Key => [ $object[0] ],
defined $object[1] ? ( VersionId => [ $object[1] ] ) : (),
};
}
}
else { # list of keys
croak 'argument must be array or list';
}
}
elsif (@args) {
@keys = map { { Key => [$_] } } @args;
}
else {
croak 'must specify keys';
}
croak 'must not exceed ' . $MAX_DELETE_KEYS . ' keys'
if @keys > $MAX_DELETE_KEYS;
return \@keys;
}
# @args => list of keys
# $args[0] => array of hashes (Key, [VersionId]) VersionId is optional
# $args[0] => array of scalars (keys)
# $args[0] => code reference that returns key, version id or empty
# $args[0] => hash ({ quiet => 1, keys => $keys})
# Throws exception if no keys or in wrong format...
########################################################################
sub delete_keys {
########################################################################
my ( $self, @args ) = @_;
my ( $keys, $quiet_mode );
if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) {
( $keys, $quiet_mode ) = @{ $args[0] }{qw(keys quiet)};
$keys = _format_delete_keys($keys);
}
else {
$keys = _format_delete_keys(@args);
}
if ( defined $quiet_mode ) {
$quiet_mode = $quiet_mode ? 'true' : 'false';
}
else {
$quiet_mode = 'false';
}
my $content = {
xmlns => $S3_XMLNS,
Quiet => [$quiet_mode],
Object => $keys,
};
my $xml_content = XMLout(
$content,
RootName => 'Delete',
XMLDecl => $XMLDECL,
);
my $conf = {};
my $account = $self->account;
my $md5 = md5($xml_content);
my $md5_base64 = encode_base64($md5);
chomp $md5_base64;
$conf->{'Content-MD5'} = $md5_base64;
return $account->_send_request(
{ method => 'POST',
region => $self->region,
path => $self->_uri() . '?delete',
headers => $conf,
data => $xml_content,
},
);
}
########################################################################
sub delete_bucket {
########################################################################
my ($self) = @_;
croak 'Unexpected arguments'
if @_ > 1;
return $self->account->delete_bucket($self);
}
########################################################################
sub list_v2 {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
$conf->{bucket} = $self->bucket;
$conf->{'list-type'} = '2';
if ( $conf->{'marker'} ) {
$conf->{'continuation-token'} = delete $conf->{'marker'};
}
return $self->list($conf);
}
########################################################################
sub list {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
$conf->{bucket} = $self->bucket;
return $self->account->list_bucket($conf);
}
########################################################################
sub list_all_v2 {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
$conf->{bucket} = $self->bucket;
return $self->account->list_bucket_all_v2($conf);
}
########################################################################
sub list_all {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
$conf->{bucket} = $self->bucket;
return $self->account->list_bucket_all($conf);
}
########################################################################
sub get_acl {
########################################################################
my ( $self, $key ) = @_;
my $account = $self->account;
my $request = $account->_make_request(
{ region => $self->region,
method => 'GET',
path => $self->_uri($key) . '?acl=',
headers => {},
},
);
my $old_redirectable = $account->ua->requests_redirectable;
$account->ua->requests_redirectable( [] );
my $response = $account->_do_http($request);
if ( $response->code =~ /^30/xsm ) {
my $xpc = $account->_xpc_of_content( $response->content );
my $uri = URI->new( $response->header('location') );
my $old_host = $account->host;
$account->host( $uri->host );
$request = $account->_make_request(
{ region => $self->region,
method => 'GET',
path => $uri->path,
headers => {},
},
);
$response = $account->_do_http($request);
$account->ua->requests_redirectable($old_redirectable);
$account->host($old_host);
}
my $content;
# do we test for NOT FOUND, returning undef?
if ( $response->code ne $HTTP_NOT_FOUND ) {
$account->_croak_if_response_error($response);
$content = $response->content;
}
return $content;
}
########################################################################
sub set_acl {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
croak 'need either acl_xml or acl_short'
if !$conf->{acl_xml} && !$conf->{acl_short};
croak 'cannot provide both acl_xml and acl_short'
if $conf->{acl_xml} && $conf->{acl_short};
my $path = $self->_uri( $conf->{key} ) . '?acl=';
my $headers = {};
if ( $conf->{acl_short} ) {
$headers->{'x-amz-acl'} = $conf->{acl_short};
}
my $xml = $conf->{acl_xml} || $EMPTY;
my $account = $self->account;
$headers->{'Content-Length'} = length $xml;
return $account->_send_request_expect_nothing(
{ method => 'PUT',
path => $path,
headers => $headers,
data => $xml,
region => $self->region,
},
);
}
########################################################################
sub get_location_constraint {
########################################################################
my ($self) = @_;
my $account = $self->account;
my $xpc = $account->_send_request(
{ region => $self->region,
method => 'GET',
path => $self->bucket . '/?location=',
},
);
my $lc;
if ( !$xpc ) {
croak $account->errstr
if $account->_remember_errors($xpc);
return $lc;
}
$lc = $xpc;
if ( defined $lc && $lc eq $EMPTY ) {
$lc = undef;
}
return $lc;
}
# proxy up the err requests
########################################################################
sub last_response {
########################################################################
my ($self) = @_;
return $self->account->last_response;
}
########################################################################
sub err {
########################################################################
my ($self) = @_;
return $self->account->err;
}
########################################################################
sub errstr {
########################################################################
my ($self) = @_;
return $self->account->errstr;
}
########################################################################
sub error {
########################################################################
my ($self) = @_;
return $self->account->error;
}
########################################################################
sub _content_sub {
########################################################################
my ( $filename, $buffer_size ) = @_;
my $stat = stat $filename;
my $remaining = $stat->size;
my $blksize = $stat->blksize || $buffer_size;
croak "$filename not a readable file with fixed size"
if !-r $filename || !$remaining;
my $fh = IO::File->new( $filename, 'r' )
or croak "Could not open $filename: $OS_ERROR";
$fh->binmode;
return sub {
my $buffer;
# upon retries the file is closed and we must reopen it
if ( !$fh->opened ) {
$fh = IO::File->new( $filename, 'r' )
or croak "Could not open $filename: $OS_ERROR";
$fh->binmode;
$remaining = $stat->size;
}
my $read = $fh->read( $buffer, $blksize );
if ( !$read ) {
croak
"Error while reading upload content $filename ($remaining remaining) $OS_ERROR"
if $OS_ERROR and $remaining;
$fh->close # otherwise, we found EOF
or croak "close of upload content $filename failed: $OS_ERROR";
$buffer ||= $EMPTY; # LWP expects an empty string on finish, read returns 0
}
$remaining -= length $buffer;
return $buffer;
};
}
1;
__END__
=pod
=head1 NAME
Amazon::S3::Bucket - A container class for a S3 bucket and its contents.
=head1 SYNOPSIS
use Amazon::S3;
# creates bucket object (no "bucket exists" check)
my $bucket = $s3->bucket("foo");
# create resource with meta data (attributes)
my $keyname = 'testing.txt';
my $value = 'T';
$bucket->add_key(
$keyname, $value,
{ content_type => 'text/plain',
'x-amz-meta-colour' => 'orange',
}
);
# list keys in the bucket
$response = $bucket->list
or die $s3->err . ": " . $s3->errstr;
print $response->{bucket}."\n";
for my $key (@{ $response->{keys} }) {
print "\t".$key->{key}."\n";
}
# check if resource exists.
print "$keyname exists\n" if $bucket->head_key($keyname);
# delete key from bucket
$bucket->delete_key($keyname);
=head1 DESCRIPTION
=head1 METHODS AND SUBROUTINES
=head2 new
Instaniates a new bucket object.
Pass a hash or hash reference containing various options:
=over
=item bucket (required)
The name (identifier) of the bucket.
=item account (required)
The L object (representing the S3 account) this
bucket is associated with.
=item buffer_size
The buffer size used for reading and writing objects to S3.
default: 4K
=item region
If no region is set and C is set to true, the region of
the bucket will be determined by calling the
C method. Note that this will decrease
performance of the constructor. If you know the region or are
operating in only 1 region, set the region in the C object
(C).
=item logger
Sets the logger. The logger should be a blessed reference capable of
providing at least a C and C method for recording log
messages. If no logger object is passed the C object's logger
object will be used.
=item verify_region
Indicates that the bucket's region should be determined by calling the
C method.
default: false
=back
I This method does not check if a bucket actually exists unless
you set C to true. If the bucket does not exist,
the constructor will set the region to the default region specified by
the L object (C) that you passed.
Typically a developer will not call this method directly,
but work through the interface in L that will
handle their creation.
=head2 add_key
add_key( key, value, configuration)
Write a new or existing object to S3.
=over
=item key
A string identifier for the object being written to the bucket.
=item value
A SCALAR string representing the contents of the object.
=item configuration
A HASHREF of configuration data for this key. The configuration
is generally the HTTP headers you want to pass to the S3
service. The client library will add all necessary headers.
Adding them to the configuration hash will override what the
library would send and add headers that are not typically
required for S3 interactions.
=item acl_short (optional)
In addition to additional and overriden HTTP headers, this
HASHREF can have a C key to set the permissions
(access) of the resource without a seperate call via
C or in the form of an XML document. See the
documentation in C for the values and usage.
=back
Returns a boolean indicating the sucess or failure of the call. Check
C and C for error messages if this operation fails. To
examine the raw output of the response from the API call, use the
C method.
my $retval = $bucket->add_key('foo', $content, {});
if ( !$retval ) {
print STDERR Dumper([$bucket->err, $bucket->errstr, $bucket->last_response]);
}
=head2 add_key_filename
The method works like C except the value is assumed
to be a filename on the local file system. The file will
be streamed rather then loaded into memory in one big chunk.
=head2 copy_object %parameters
Copies an object from one bucket to another bucket. I Returns a
hash reference to the response object (C).
Headers returned from the request can be obtained using the
C method.
my $headers = { $bucket->last_response->headers->flatten };
Throws an exception if the response code is not 2xx. You can get an
extended error message using the C method.
my $result = eval { return $s3->copy_object( key => 'foo.jpg',
source => 'boo.jpg' ); };
if ($@) {
die $s3->errstr;
}
Examples:
$bucket->copy_object( key => 'foo.jpg', source => 'boo.jpg' );
$bucket->copy_object(
key => 'foo.jpg',
source => 'boo.jpg',
bucket => 'my-source-bucket'
);
$bucket->copy_object(
key => 'foo.jpg',
headers => { 'x-amz-copy-source' => 'my-source-bucket/boo.jpg'
);
See L
for more details.
C<%parameters> is a list of key/value pairs described below:
=over
=item key (required)
Name of the destination key in the bucket represented by the bucket object.
=item headers (optional)
Hash or array reference of headers to send in the request.
=item bucket (optional)
Name of the source bucket. Default is the same bucket as the destination.
=item source (optional)
Name of the source key in the source bucket. If not provided, you must
provide the source in the `x-amz-copy-source` header.
=back
=head2 head_key $key_name
Returns a configuration HASH of the given key. If a key does
not exist in the bucket C will be returned.
HASH will contain the following members:
=over
=item content_length
=item content_type
=item etag
=item value
=back
=head2 delete_key $key_name
Permanently removes C<$key_name> from the bucket. Returns a
boolean value indicating the operations success.
=head2 delete_keys @keys
=head2 delete_keys $keys
Permanently removes keys from the bucket. Returns the response body
from the API call. Returns C on non '2xx' return codes.
See
The argument to C can be:
=over 5
=item * list of key names
=item * an array of hashes where each hash reference contains the keys
C and optionally C.
=item * an array of scalars where each scalar is a key name
=item * a hash of options where the hash contains
=item * a callback that returns the key and optionally the version id
=over 10
=item quiet
Boolean indicating quiet mode
=item keys
An array of keys containing scalars or hashes as describe above.
=back
=back
Examples:
# delete a list of keys
$bucket->delete_keys(qw( foo bar baz));
# delete an array of keys
$bucket->delete_keys([qw(foo bar baz)]);
# delete an array of keys in quiet mode
$bucket->delete({ quiet => 1, keys => [ qw(foo bar baz) ]);
# delete an array of versioned objects
$bucket->delete_keys([ { Key => 'foo', VersionId => '1'} ]);
# callback
my @key_list = qw(foo => 1, bar => 3, biz => 1);
$bucket->delete_keys(
sub {
return ( shift @key_list, shift @key_list );
}
);
I API is only called once.>
=head2 delete_bucket
Permanently removes the bucket from the server. A bucket
cannot be removed if it contains any keys (contents).
This is an alias for C<$s3-Edelete_bucket($bucket)>.
=head2 get_key $key_name, [$method]
Takes a key and an optional HTTP method and fetches it from
S3. The default HTTP method is GET.
The method returns C if the key does not exist in the
bucket and throws an exception (dies) on server errors.
On success, the method returns a HASHREF containing:
=over
=item content_type
=item etag
=item value
=item @meta
=back
=head2 get_key_filename $key_name, $method, $filename
This method works like C, but takes an added
filename that the S3 resource will be written to.
=head2 list
List all keys in this bucket.
See L for documentation of this
method.
=head2 list_v2
See L for documentation of this
method.
=head2 list_all
List all keys in this bucket without having to worry about
'marker'. This may make multiple requests to S3 under the
hood.
See L for documentation of this
method.
=head2 list_all_v2
Same as C but uses the version 2 API for listing keys.
See L for documentation of this
method.
=head2 get_acl
Retrieves the Access Control List (ACL) for the bucket or
resource as an XML document.
=over
=item key
The key of the stored resource to fetch. This parameter is
optional. By default the method returns the ACL for the
bucket itself.
=back
=head2 set_acl
set_acl(acl)
Retrieves the Access Control List (ACL) for the bucket or
resource. Requires a HASHREF argument with one of the following keys:
=over
=item acl_xml
An XML string which contains access control information
which matches Amazon's published schema.
=item acl_short
Alternative shorthand notation for common types of ACLs that
can be used in place of a ACL XML document.
According to the Amazon S3 API documentation the following recognized acl_short
types are defined as follows:
=over
=item private
Owner gets FULL_CONTROL. No one else has any access rights.
This is the default.
=item public-read
Owner gets FULL_CONTROL and the anonymous principal is
granted READ access. If this policy is used on an object, it
can be read from a browser with no authentication.
=item public-read-write
Owner gets FULL_CONTROL, the anonymous principal is granted
READ and WRITE access. This is a useful policy to apply to a
bucket, if you intend for any anonymous user to PUT objects
into the bucket.
=item authenticated-read
Owner gets FULL_CONTROL, and any principal authenticated as
a registered Amazon S3 user is granted READ access.
=back
=item key
The key name to apply the permissions. If the key is not
provided the bucket ACL will be set.
=back
Returns a boolean indicating the operations success.
=head2 get_location_constraint
Returns the location constraint (region the bucket resides in) for a
bucket. Returns undef if no location constraint.
Valid values that may be returned:
af-south-1
ap-east-1
ap-northeast-1
ap-northeast-2
ap-northeast-3
ap-south-1
ap-southeast-1
ap-southeast-2
ca-central-1
cn-north-1
cn-northwest-1
EU
eu-central-1
eu-north-1
eu-south-1
eu-west-1
eu-west-2
eu-west-3
me-south-1
sa-east-1
us-east-2
us-gov-east-1
us-gov-west-1
us-west-1
us-west-2
For more information on location constraints, refer to the
documentation for
L.
=head2 err
The S3 error code for the last error the account encountered.
=head2 errstr
A human readable error string for the last error the account encountered.
=head2 error
The decoded XML string as a hash object of the last error.
=head2 last_response
Returns the last C to an API call.
=head1 MULTIPART UPLOAD SUPPORT
From Amazon's website:
I
See L for more information about multipart uploads.
=over 5
=item * Maximum object size 5TB
=item * Maximum number of parts 10,000
=item * Part numbers 1 to 10,000 (inclusive)
=item * Part size 5MB to 5GB. There is no limit on the last part of your multipart upload.
=item * Maximum nubmer of parts returned for a list parts request - 1000
=item * Maximum number of multipart uploads returned in a list multipart uploads request - 1000
=back
A multipart upload begins by calling
C. This will return an identifier that is
used in subsequent calls.
my $bucket = $s3->bucket('my-bucket');
my $id = $bucket->initiate_multipart_upload('some-big-object');
my $part_list = {};
my $part = 1;
my $etag = $bucket->upload_part_of_multipart_upload('my-bucket', $id, $part, $data, length $data);
$part_list{$part++} = $etag;
$bucket->complete_multipart_upload('my-bucket', $id, $part_list);
=heads upload_multipart_object
upload_multipart_object( ... )
Convenience routine C that encapsulates the
multipart upload process. Accepts a hash or hash reference of
arguments. If successful, a reference to a hash that contains the part
numbers and etags of the uploaded parts.
You can pass a data object, callback routine or a file handle.
=over 5
=item key
Name of the key to create.
=item data
Scalar object that contains the data to write to S3.
=item callback
Optionally provided a callback routine that will be called until you
pass a buffer with a length of 0. Your callback will receive no
arguments but should return a tuple consisting of a B to a
scalar object that contains the data to write and a scalar that
represents the length of data. Once you return a zero length buffer
the multipart process will be completed.
=item fh
File handle of an open file. The file must be greater than the minimum
chunk size for multipart uploads otherwise the method will throw an
exception.
=item abort_on_error
Indicates whether the multipart upload should be aborted if an error
is encountered. Amazon will charge you for the storage of parts that
have been uploaded unless you abort the upload.
default: true
=back
=head2 abort_multipart_upload
abort_multipart_upload(key, multpart-upload-id)
Abort a multipart upload
=head2 complete_multipart_upload
complete_multipart_upload(key, multpart-upload-id, parts)
Signal completion of a multipart upload. C is a reference to a
hash of part numbers and etags.
=head2 initiate_multipart_upload
initiate_multipart_upload(key, headers)
Initiate a multipart upload. Returns an id used in subsequent call to
C.
=head2 list_multipart_upload_parts
List all the uploaded parts of a multipart upload
=head2 list_multipart_uploads
List multipart uploads in progress
=head2 upload_part_of_multipart_upload
upload_part_of_multipart_upload(key, id, part, data, length)
Upload a portion of a multipart upload
=over 5
=item key
Name of the key in the bucket to create.
=item id
The multipart-upload id return in the C call.
=item part
The next part number (part numbers start at 1).
=item data
Scalar or reference to a scalar that contains the data to upload.
=item length (optional)
Length of the data.
=back
=head1 SEE ALSO
L
=head1 AUTHOR
Please see the L manpage for author, copyright, and
license information.
=head1 CONTRIBUTORS
Rob Lauer
Jojess Fournier
Tim Mullin
Todd Rinaldo
luiserd97
=cut
Amazon-S3-0.65/lib/Amazon/S3.pm 0000644 0001750 0001750 00000210540 14531467536 015666 0 ustar rclauer rclauer package Amazon::S3;
use strict;
use warnings;
use Amazon::S3::Bucket;
use Amazon::S3::Constants qw(:all);
use Amazon::S3::Logger;
use Amazon::S3::Signature::V4;
use Carp;
use Data::Dumper;
use Digest::HMAC_SHA1;
use Digest::MD5 qw(md5_hex);
use English qw(-no_match_vars);
use HTTP::Date;
use URI;
use LWP::UserAgent::Determined;
use MIME::Base64 qw(encode_base64 decode_base64);
use Scalar::Util qw( reftype blessed );
use List::Util qw( any pairs );
use URI::Escape qw(uri_escape_utf8);
use XML::Simple qw(XMLin); ## no critic (Community::DiscouragedModules)
use parent qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(
qw(
aws_access_key_id
aws_secret_access_key
token
buffer_size
cache_signer
credentials
dns_bucket_names
digest
err
errstr
error
host
last_request
last_response
logger
log_level
retry
_region
secure
_signer
timeout
ua
),
);
our $VERSION = '0.65'; ## no critic (RequireInterpolation)
########################################################################
sub new {
########################################################################
my ( $class, @args ) = @_;
my %options = ref $args[0] ? %{ $args[0] } : @args;
$options{timeout} //= $DEFAULT_TIMEOUT;
$options{secure} //= $TRUE;
$options{host} //= $DEFAULT_HOST;
$options{dns_bucket_names} //= $TRUE;
$options{cache_signer} //= $FALSE;
$options{retry} //= $FALSE;
$options{_region} = delete $options{region};
$options{_signer} = delete $options{signer};
# convenience for level => 'debug' & for consistency with
# Amazon::Credentials only do this if we are using internal logger,
# call should NOT use debug flag but rather use their own logger's
# level to turn on higher levels of logging...
if ( !$options{logger} ) {
if ( delete $options{debug} ) {
$options{level} = 'debug';
}
$options{log_level} = delete $options{level};
$options{log_level} //= $DEFAULT_LOG_LEVEL;
$options{logger}
= Amazon::S3::Logger->new( log_level => $options{log_level} );
}
my $self = $class->SUPER::new( \%options );
# setup logger internal logging
$self->get_logger->debug(
sub {
my %safe_options = %options;
if ( $safe_options{aws_secret_access_key} ) {
$safe_options{aws_secret_access_key} = '****';
$safe_options{aws_access_key_id} = '****';
}
return Dumper( [ options => \%safe_options ] );
},
);
if ( !$self->credentials ) {
croak 'No aws_access_key_id'
if !$self->aws_access_key_id;
croak 'No aws_secret_access_key'
if !$self->aws_secret_access_key;
# encrypt credentials
$self->aws_access_key_id( _encrypt( $self->aws_access_key_id ) );
$self->aws_secret_access_key( _encrypt( $self->aws_secret_access_key ) );
$self->token( _encrypt( $self->token ) );
}
my $ua;
if ( $self->retry ) {
$ua = LWP::UserAgent::Determined->new(
keep_alive => $KEEP_ALIVE_CACHESIZE,
requests_redirectable => [qw(GET HEAD DELETE)],
);
$ua->timing( join $COMMA, map { 2**$_ } 0 .. $MAX_RETRIES );
}
else {
$ua = LWP::UserAgent->new(
keep_alive => $KEEP_ALIVE_CACHESIZE,
requests_redirectable => [qw(GET HEAD DELETE)],
);
}
$ua->timeout( $self->timeout );
$ua->env_proxy;
$self->ua($ua);
$self->region( $self->_region // $DEFAULT_REGION );
if ( !$self->_signer && $self->cache_signer ) {
$self->_signer( $self->signer );
}
$self->turn_on_special_retry();
return $self;
}
########################################################################
{
my $encryption_key;
########################################################################
sub _encrypt {
########################################################################
my ($text) = @_;
return $text if !$text;
if ( !defined $encryption_key ) {
$encryption_key = eval {
if ( !defined $encryption_key ) {
require Crypt::Blowfish;
require Crypt::CBC;
return md5_hex( rand $PID );
}
};
}
if ( !$encryption_key || $EVAL_ERROR ) {
return $text;
}
my $cipher = Crypt::CBC->new(
-pass => $encryption_key,
-key => $encryption_key,
-cipher => 'Crypt::Blowfish',
-nodeprecate => $TRUE,
);
return $cipher->encrypt($text);
}
########################################################################
sub _decrypt {
########################################################################
my ($secret) = @_;
return $secret
if !$secret || !$encryption_key;
my $cipher = Crypt::CBC->new(
-pass => $encryption_key,
-key => $encryption_key,
-cipher => 'Crypt::Blowfish',
);
return $cipher->decrypt($secret);
}
}
########################################################################
sub get_bucket_location {
########################################################################
my ( $self, $bucket ) = @_;
my $region;
if ( !ref $bucket || ref $bucket !~ /Amazon::S3::Bucket/xsm ) {
$bucket = Amazon::S3::Bucket->new( bucket => $bucket, account => $self );
}
return $bucket->get_location_constraint // $DEFAULT_REGION;
}
########################################################################
sub get_default_region {
########################################################################
my ($self) = @_;
my $region = $ENV{AWS_REGION} || $ENV{AWS_DEFAULT_REGION};
return $region
if $region;
my $url
= 'http://169.254.169.254/latest/meta-data/placement/availability-zone';
my $request = HTTP::Request->new( 'GET', $url );
my $ua = LWP::UserAgent->new;
$ua->timeout(0);
my $response = eval { return $ua->request($request); };
if ( $response && $response->is_success ) {
if ( $response->content =~ /\A([[:lower:]]+[-][[:lower:]]+[-]\d+)/xsm ) {
$region = $1;
}
}
return $region || $DEFAULT_REGION;
}
# Amazon::Credentials compatibility methods
########################################################################
sub get_aws_access_key_id {
########################################################################
my ($self) = @_;
return _decrypt( $self->aws_access_key_id );
}
########################################################################
sub get_aws_secret_access_key {
########################################################################
my ($self) = @_;
return _decrypt( $self->aws_secret_access_key );
}
########################################################################
sub get_token {
########################################################################
my ($self) = @_;
return _decrypt( $self->token );
}
########################################################################
sub turn_on_special_retry {
########################################################################
my ($self) = @_;
if ( $self->retry ) {
# In the field we are seeing issue of Amazon returning with a 400
# code in the case of timeout. From AWS S3 logs: REST.PUT.PART
# Backups/2017-05-04/.tar.gz "PUT
# /Backups?partNumber=27&uploadId= - HTTP/1.1" 400
# RequestTimeout 360 20971520 20478 - "-" "libwww-perl/6.15"
my $http_codes_hr = $self->ua->codes_to_determinate();
$http_codes_hr->{$HTTP_BAD_REQUEST} = $TRUE;
}
return;
}
########################################################################
sub turn_off_special_retry {
########################################################################
my ($self) = @_;
if ( $self->retry ) {
# In the field we are seeing issue with Amazon returning a 400
# code in the case of timeout. From AWS S3 logs: REST.PUT.PART
# Backups/2017-05-04/.tar.gz "PUT
# /Backups?partNumber=27&uploadId= - HTTP/1.1" 400
# RequestTimeout 360 20971520 20478 - "-" "libwww-perl/6.15"
my $http_codes_hr = $self->ua->codes_to_determinate();
delete $http_codes_hr->{$HTTP_BAD_REQUEST};
}
return;
}
########################################################################
sub region {
########################################################################
my ( $self, @args ) = @_;
if (@args) {
$self->_region( $args[0] );
}
$self->get_logger->debug(
sub { return 'region: ' . ( $self->_region // $EMPTY ) } );
if ( $self->_region ) {
my $host = $self->host;
$self->get_logger->debug( sub { return 'host: ' . $self->host } );
if ( $host =~ /\As3[.](.*)?amazonaws/xsm ) {
$self->host( sprintf 's3.%s.amazonaws.com', $self->_region );
}
}
return $self->_region;
}
########################################################################
sub buckets {
########################################################################
my ( $self, $verify_region ) = @_;
# The "default" region for Amazon is us-east-1
# This is the region to set it to for listing buckets
# You may need to reset the signer's endpoint to 'us-east-1'
# temporarily cache signer
my $region = $self->_region;
my $bucket_list;
$self->reset_signer_region($DEFAULT_REGION); # default region for buckets op
my $r = $self->_send_request(
{ method => 'GET',
path => $EMPTY,
headers => {},
region => $DEFAULT_REGION,
},
);
return $bucket_list
if !$r || $self->errstr;
my $owner_id = $r->{Owner}{ID};
my $owner_displayname = $r->{Owner}{DisplayName};
my @buckets;
if ( ref $r->{Buckets} ) {
my $buckets = $r->{Buckets}{Bucket};
if ( !ref $buckets || reftype($buckets) ne 'ARRAY' ) {
$buckets = [$buckets];
}
foreach my $node ( @{$buckets} ) {
push @buckets,
Amazon::S3::Bucket->new(
{ bucket => $node->{Name},
creation_date => $node->{CreationDate},
account => $self,
buffer_size => $self->buffer_size,
verify_region => $verify_region // $FALSE,
},
);
}
}
$self->reset_signer_region($region); # restore original region
$bucket_list = {
owner_id => $owner_id,
owner_displayname => $owner_displayname,
buckets => \@buckets,
};
return $bucket_list;
}
########################################################################
sub reset_signer_region {
########################################################################
my ( $self, $region ) = @_;
# reset signer's region, if the region wasn't us-east-1...note this
# is probably not needed anymore since bucket operations now send
# the region of the bucket to the signer
if ( $self->cache_signer ) {
if ( $self->region && $self->region ne $DEFAULT_REGION ) {
if ( $self->signer->can('region') ) {
$self->signer->region($region);
}
}
}
else {
$self->region($region);
}
return $self->region;
}
########################################################################
sub add_bucket {
########################################################################
my ( $self, $conf ) = @_;
my $region = $conf->{location_constraint} // $conf->{region}
// $self->region;
if ( $region && $region eq $DEFAULT_REGION ) {
undef $region;
}
my $bucket = $conf->{bucket};
croak 'must specify bucket'
if !$bucket;
my %header_ref;
if ( $conf->{acl_short} ) {
$self->_validate_acl_short( $conf->{acl_short} );
$header_ref{'x-amz-acl'} = $conf->{acl_short};
}
my $xml = <<'XML';
%s
XML
my $data = defined $region ? sprintf $xml, $region : $EMPTY;
my $retval = $self->_send_request_expect_nothing(
{ method => 'PUT',
path => "$bucket/",
headers => { %header_ref, 'Content-Length' => length $data },
data => $data,
region => $region,
},
);
my $bucket_obj = $retval ? $self->bucket($bucket) : undef;
return $bucket_obj;
}
########################################################################
sub bucket {
########################################################################
my ( $self, @args ) = @_;
my ( $bucketname, $region, $verify_region );
if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) {
( $bucketname, $region, $verify_region )
= @{ $args[0] }{qw(bucket region verify_region)};
}
else {
( $bucketname, $region ) = @args;
}
# only set to default region if a region wasn't passed or region
# verification not requested
if ( !$region && !$verify_region ) {
$region = $self->region;
}
return Amazon::S3::Bucket->new(
{ bucket => $bucketname,
account => $self,
region => $region,
verify_region => $verify_region,
},
);
}
########################################################################
sub delete_bucket {
########################################################################
my ( $self, $conf ) = @_;
my $bucket;
my $region;
if ( eval { return $conf->isa('Amazon::S3::Bucket'); } ) {
$bucket = $conf->bucket;
$region = $conf->region;
}
else {
$bucket = $conf->{bucket};
$region = $conf->{region} || $self->get_bucket_location($bucket);
}
croak 'must specify bucket'
if !$bucket;
return $self->_send_request_expect_nothing(
{ method => 'DELETE',
path => $bucket . $SLASH,
headers => {},
region => $region,
},
);
}
########################################################################
sub list_bucket_v2 {
########################################################################
my ( $self, $conf ) = @_;
$conf->{'list-type'} = '2';
goto &list_bucket;
}
########################################################################
sub list_bucket {
########################################################################
my ( $self, $conf ) = @_;
my $bucket = delete $conf->{bucket};
croak 'must specify bucket' if !$bucket;
$conf ||= {};
my $bucket_list; # return this
my $path = $bucket . $SLASH;
my $list_type = $conf->{'list-type'} // '1';
my ( $marker, $next_marker, $query_next )
= @{ $LIST_OBJECT_MARKERS{$list_type} };
if ( $conf->{marker} ) {
$conf->{$query_next} = delete $conf->{marker};
}
if ( %{$conf} ) {
my @vars = keys %{$conf};
# remove undefined elements
foreach (@vars) {
next if defined $conf->{$_};
delete $conf->{$_};
}
my $query_string = $QUESTION_MARK . join $AMPERSAND,
map { $_ . $EQUAL_SIGN . $self->_urlencode( $conf->{$_} ) }
keys %{$conf};
$path .= $query_string;
}
$self->get_logger->debug( sprintf 'PATH: %s', $path );
my $r = $self->_send_request(
{ method => 'GET',
path => $path,
headers => {}, # { 'Content-Length' => 0 },
region => $self->region,
},
);
$self->get_logger->trace(
Dumper(
[ r => $r,
errstr => $self->errstr,
]
)
);
return $bucket_list
if !$r || $self->errstr;
$self->get_logger->trace(
sub {
return Dumper(
[ marker => $marker,
next_marker => $next_marker,
response => $r,
],
);
},
);
$bucket_list = {
bucket => $r->{Name},
prefix => $r->{Prefix} // $EMPTY,
marker => $r->{$marker} // $EMPTY,
next_marker => $r->{$next_marker} // $EMPTY,
max_keys => $r->{MaxKeys},
is_truncated => (
( defined $r->{IsTruncated} && scalar $r->{IsTruncated} eq 'true' )
? $TRUE
: $FALSE
),
};
my @keys;
foreach my $node ( @{ $r->{Contents} } ) {
my $etag = $node->{ETag};
if ( defined $etag ) {
$etag =~ s{(^"|"$)}{}gxsm;
}
push @keys,
{
key => $node->{Key},
last_modified => $node->{LastModified},
etag => $etag,
size => $node->{Size},
storage_class => $node->{StorageClass},
owner_id => $node->{Owner}{ID},
owner_displayname => $node->{Owner}{DisplayName},
};
}
$bucket_list->{keys} = \@keys;
if ( $conf->{delimiter} ) {
my @common_prefixes;
my $strip_delim = qr/$conf->{delimiter}$/xsm;
foreach my $node ( $r->{CommonPrefixes} ) {
if ( ref $node ne 'ARRAY' ) {
$node = [$node];
}
foreach my $n ( @{$node} ) {
next if !exists $n->{Prefix};
my $prefix = $n->{Prefix};
# strip delimiter from end of prefix
if ($prefix) {
$prefix =~ s/$strip_delim//xsm;
}
push @common_prefixes, $prefix;
}
}
$bucket_list->{common_prefixes} = \@common_prefixes;
}
$self->get_logger->trace( Dumper( [ bucket_list => $bucket_list ] ) );
return $bucket_list;
}
########################################################################
sub list_bucket_all_v2 {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
$conf->{'list-type'} = '2';
return $self->list_bucket_all($conf);
}
########################################################################
sub list_bucket_all {
########################################################################
my ( $self, $conf ) = @_;
$conf ||= {};
my $bucket = $conf->{bucket};
croak 'must specify bucket'
if !$bucket;
my $response = $self->list_bucket($conf);
croak $EVAL_ERROR
if !$response;
return $response
if !$response->{is_truncated};
my $all = $response;
while ($TRUE) {
my $next_marker = $response->{next_marker}
|| $response->{keys}->[-1]->{key};
$conf->{marker} = $next_marker;
$conf->{bucket} = $bucket;
$response = $self->list_bucket($conf);
croak $EVAL_ERROR
if !$response;
push @{ $all->{keys} }, @{ $response->{keys} };
last if !$response->{is_truncated};
}
delete $all->{is_truncated};
delete $all->{next_marker};
return $all;
}
########################################################################
sub get_credentials {
########################################################################
my ($self) = @_;
my $aws_access_key_id;
my $aws_secret_access_key;
my $token;
if ( $self->credentials ) {
$aws_access_key_id = $self->credentials->get_aws_access_key_id;
$aws_secret_access_key = $self->credentials->get_aws_secret_access_key;
$token = $self->credentials->get_token;
}
else {
$aws_access_key_id = $self->aws_access_key_id;
$aws_secret_access_key = $self->aws_secret_access_key;
$token = $self->token;
}
return ( $aws_access_key_id, $aws_secret_access_key, $token );
}
# Log::Log4perl compatibility routines
########################################################################
sub get_logger {
########################################################################
my ($self) = @_;
return $self->logger;
}
########################################################################
sub level {
########################################################################
my ( $self, @args ) = @_;
if (@args) {
$self->log_level( $args[0] );
$self->get_logger->level( uc $args[0] );
}
return $self->get_logger->level;
}
########################################################################
sub signer {
########################################################################
my ($self) = @_;
return $self->_signer
if $self->_signer;
my $creds = $self->credentials ? $self->credentials : $self;
my $signer = Amazon::S3::Signature::V4->new(
{ access_key_id => $creds->get_aws_access_key_id,
secret => $creds->get_aws_secret_access_key,
region => $self->region || $self->get_default_region,
service => 's3',
security_token => $creds->get_token,
},
);
if ( $self->cache_signer ) {
$self->_signer($signer);
}
return $signer;
}
########################################################################
sub _validate_acl_short {
########################################################################
my ( $self, $policy_name ) = @_;
if ( !any { $policy_name eq $_ }
qw(private public-read public-read-write authenticated-read) ) {
croak "$policy_name is not a supported canned access policy";
}
return;
}
# Determine if a bucket can used as subdomain for the host
# Specifying the bucket in the URL path is being deprecated
# So, if the bucket name is suitable, we need to put it
# as a subdomain to the host, instead. Currently buckets with
# periods in their names cannot be handled in that manner
# due to SSL certificate issues, they will have to remain in
# the url path instead
sub _can_bucket_be_subdomain {
my ($bucketname) = @_;
if ( length $bucketname > $MAX_BUCKET_NAME_LENGTH - 1 ) {
return $FALSE;
}
if ( length $bucketname < $MIN_BUCKET_NAME_LENGTH ) {
return $FALSE;
}
return $FALSE if $bucketname !~ m{\A[[:lower:]][[:lower:]\d-]*\z}xsm;
return $FALSE if $bucketname !~ m{[[:lower:]\d]\z}xsm;
return $TRUE;
}
# make the HTTP::Request object
########################################################################
sub _make_request {
########################################################################
my ( $self, @args ) = @_;
my ( $method, $path, $headers, $data, $metadata, $region );
if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) {
( $method, $path, $headers, $data, $metadata, $region )
= @{ $args[0] }{qw(method path headers data metadata region)};
}
else {
( $method, $path, $headers, $data, $metadata, $region ) = @args;
}
# reset region on every call...every bucket can have it's own region
$self->region( $region // $self->_region );
croak 'must specify method'
if !$method;
croak 'must specify path'
if !defined $path;
$headers ||= {};
$metadata ||= {};
$data //= $EMPTY;
my $http_headers = $self->_merge_meta( $headers, $metadata );
my $protocol = $self->secure ? 'https' : 'http';
my $host = $self->host;
$path =~ s/\A\///xsm;
my $url = "$protocol://$host/$path";
if ( $path =~ m{\A([^/?]+)([^?]+)(.*)}xsm
&& $self->dns_bucket_names
&& _can_bucket_be_subdomain($1) ) {
my $bucket = $1;
$path = $2;
my $query_string = $3;
if ( $host =~ /([^:]+):([^:]\d+)$/xsm ) {
$url = eval {
my $port = $2;
$host = $1;
my $uri = URI->new;
$uri->scheme('http');
$uri->host("$bucket.$host");
$uri->port($port);
$uri->path($path);
return $uri . $query_string;
};
die "could not a uri for bucket: $bucket, host: $host, path: $path\n"
if !$url || $EVAL_ERROR;
}
else {
$url = "$protocol://$bucket.$host$path$query_string";
}
}
$self->get_logger->debug( sprintf 'URL (uri): %s', $url );
my $request = HTTP::Request->new( $method, $url, $http_headers );
$self->last_request($request);
$request->content($data);
$self->signer->region($region); # always set regional endpoint for signing
$self->signer->sign($request);
$self->get_logger->trace( sub { return Dumper( [$request] ); } );
return $request;
}
# $self->_send_request($HTTP::Request)
# $self->_send_request(@params_to_make_request)
########################################################################
sub _send_request {
########################################################################
my ( $self, @args ) = @_;
$self->get_logger->trace(
sub {
return Dumper( [ 'REQUEST' => \@args ] );
},
);
my $request;
my $keep_root = $FALSE;
if ( @args == 1 && ref( $args[0] ) =~ /HTTP::Request/xsm ) {
$request = $args[0];
}
else {
if ( ref $args[0] ) {
$keep_root = delete $args[0]->{keep_root};
}
$request = $self->_make_request(@args);
}
my $response = $self->_do_http($request);
$self->get_logger->debug( Dumper( [$response] ) );
$self->last_response($response);
my $content = $response->content;
if ( $response->code !~ /\A2\d\d\z/xsm ) {
$self->_remember_errors( $response->content, 1 );
$content = undef;
}
elsif ( $content && $response->content_type eq 'application/xml' ) {
$content = $self->_xpc_of_content( $content, $keep_root );
}
return $content;
}
#
# This is the necessary to find the region for a specific bucket
# and set the signer object to use that region when signing requests
########################################################################
sub adjust_region {
########################################################################
my ( $self, $bucket, $called_from_redirect ) = @_;
my $request
= HTTP::Request->new( 'GET', 'https://' . $bucket . $DOT . $self->host );
$self->{'signer'}->sign($request);
# We have to turn off our special retry since this will deliberately trigger that code
$self->turn_off_special_retry();
# If the bucket name has a period in it, the certificate validation
# will fail since it will expect a certificate for a subdomain.
# Setting it to verify against the expected host guards against
# that while still being secure since we will have verified
# the response as coming from the expected server.
$self->ua->ssl_opts( SSL_verifycn_name => $self->host );
my $response = $self->_do_http($request);
# Turn this off, since all other requests have the bucket after
# the host in the URL, and the host may change depending on the region
$self->ua->ssl_opts( SSL_verifycn_name => undef );
$self->turn_on_special_retry();
# If No error, then nothing to do
return $TRUE
if $response->is_success();
# If the error is due to the wrong region, then we will get
# back a block of XML with the details
if ( $response->content_type eq 'application/xml' and $response->content ) {
my $error_hash = $self->_xpc_of_content( $response->content );
if ( $error_hash->{'Code'} eq 'PermanentRedirect'
and $error_hash->{'Endpoint'} ) {
# Don't recurse through multiple redirects
return $FALSE
if $called_from_redirect;
# With a permanent redirect error, they are telling us the explicit
# host to use. The endpoint will be in the form of bucket.host
my $host = $error_hash->{'Endpoint'};
# Remove the bucket name from the front of the host name
# All the requests will need to be of the form https://host/bucket
$host =~ s/\A$bucket[.]//xsm;
$self->host($host);
# We will need to call ourselves again in order to trigger the
# AuthorizationHeaderMalformed error in order to get the region
return $self->adjust_region( $bucket, 1 );
}
if ( $error_hash->{'Code'} eq 'AuthorizationHeaderMalformed'
and $error_hash->{'Region'} ) {
# Set the signer to use the correct reader evermore
$self->{'signer'}{'endpoint'} = $error_hash->{'Region'};
# Only change the host if we haven't been called as a redirect
# where an exact host has been given
if ( !$called_from_redirect ) {
$self->host( 's3-' . $error_hash->{'Region'} . '.amazonaws.com' );
}
return $TRUE;
}
if ( $error_hash->{'Code'} eq 'IllegalLocationConstraintException' ) {
# This is hackish; but in this case the region name only appears in the message
if ( $error_hash->{'Message'} =~ /The (\S+) location/xsm ) {
my $region = $1;
# Correct the region for the signer
$self->{'signer'}{'endpoint'} = $region;
# Set the proper host for the region
$self->host( 's3.' . $region . '.amazonaws.com' );
return $TRUE;
}
}
}
# Some other error
$self->_remember_errors( $response->content, 1 );
return $FALSE;
}
########################################################################
sub reset_errors {
########################################################################
my ($self) = @_;
$self->err(undef);
$self->errstr(undef);
$self->error(undef);
return $self;
}
########################################################################
sub _do_http {
########################################################################
my ( $self, $request, $filename ) = @_;
# convenient time to reset any error conditions
$self->reset_errors;
my $response = $self->ua->request( $request, $filename );
# For new buckets at non-standard locations, amazon will sometimes
# respond with a temporary redirect. In this case it is necessary
# to try again with the new URL
if ( $response->code =~ /\A3/xsm and defined $response->header('Location') )
{
$self->get_logger->debug(
'Redirecting to: ' . $response->header('Location') );
$request->uri( $response->header('Location') );
$response = $self->ua->request( $request, $filename );
}
$self->get_logger->debug( Dumper( [$response] ) );
$self->last_response($response);
return $response;
}
# Call this if handling any temporary redirect issues
# (Like needing to probe with a HEAD request when file handle are involved)
########################################################################
sub _do_http_no_redirect {
########################################################################
my ( $self, $request, $filename ) = @_;
# convenient time to reset any error conditions
$self->reset_errors;
my $response = $self->ua->request( $request, $filename );
$self->get_logger->debug( Dumper( [$response] ) );
$self->last_response($response);
return $response;
}
########################################################################
sub _send_request_expect_nothing {
########################################################################
my ( $self, @args ) = @_;
my $request = $self->_make_request(@args);
my $response = $self->_do_http($request);
$self->get_logger->debug( Dumper( [$response] ) );
my $content = $response->content;
return $TRUE
if $response->code =~ /^2\d\d$/xsm;
# anything else is a failure, and we save the parsed result
$self->_remember_errors( $response->content, $TRUE );
return $FALSE;
}
# Send a HEAD request first, to find out if we'll be hit with a 307 redirect.
# Since currently LWP does not have true support for 100 Continue, it simply
# slams the PUT body into the socket without waiting for any possible redirect.
# Thus when we're reading from a filehandle, when LWP goes to reissue the request
# having followed the redirect, the filehandle's already been closed from the
# 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 { ## no critic (ProhibitUnusedPrivateSubroutines)
########################################################################
my ( $self, @args ) = @_;
my ( $method, $path, $conf, $value, $region );
if ( @args == 1 && ref $args[0] ) {
( $method, $path, $conf, $value, $region )
= @{ $args[0] }{qw(method path headers data region)};
}
else {
( $method, $path, $conf, $value, $region )
= @{ $args[0] }{qw(method path headers data region)};
}
$region = $region // $self->region;
my $request = $self->_make_request(
{ method => 'HEAD',
path => $path,
region => $region,
},
);
my $override_uri = undef;
my $old_redirectable = $self->ua->requests_redirectable;
$self->ua->requests_redirectable( [] );
my $response = $self->_do_http_no_redirect($request);
if ( $response->code =~ /^3/xsm ) {
if ( defined $response->header('Location') ) {
$override_uri = $response->header('Location');
}
else {
$self->_croak_if_response_error($response);
}
$self->get_logger->debug( 'setting override URI to ', $override_uri );
}
$request = $self->_make_request(
{ method => $method,
path => $path,
headers => $conf,
data => $value,
region => $region,
},
);
if ( defined $override_uri ) {
$request->uri($override_uri);
}
$response = $self->_do_http_no_redirect($request);
$self->ua->requests_redirectable($old_redirectable);
my $content = $response->content;
return $TRUE
if $response->code =~ /^2\d\d$/xsm;
# anything else is a failure, and we save the parsed result
$self->_remember_errors( $response->content, $TRUE );
return $FALSE;
}
########################################################################
sub _croak_if_response_error {
########################################################################
my ( $self, $response ) = @_;
if ( $response->code !~ /^2\d\d$/xsm ) {
$self->err('network_error');
$self->errstr( $response->status_line );
croak sprintf 'Amazon::S3: Amazon responded with %s ',
$response->status_line;
}
return;
}
########################################################################
sub _xpc_of_content {
########################################################################
my ( $self, $src, $keep_root ) = @_;
my $xml_hr = eval {
XMLin(
$src,
SuppressEmpty => $EMPTY,
ForceArray => ['Contents'],
KeepRoot => $keep_root,
NoAttr => $TRUE,
);
};
if ( !$xml_hr && $EVAL_ERROR ) {
confess "Error parsing $src: $EVAL_ERROR";
}
return $xml_hr;
}
# returns 1 if errors were found
########################################################################
sub _remember_errors {
########################################################################
my ( $self, $src, $keep_root ) = @_;
return $src
if !$src;
if ( !ref $src && $src !~ /^[[:space:]]*err($code);
$self->errstr($src);
return $TRUE;
}
my $r = ref $src ? $src : $self->_xpc_of_content( $src, $keep_root );
$self->error($r);
# apparently buckets() does not keep_root
if ( $r->{Error} ) {
$r = $r->{Error};
}
if ( $r->{Code} ) {
$self->err( $r->{Code} );
$self->errstr( $r->{Message} );
return $TRUE;
}
return $FALSE;
}
#
# Deprecated - this adds a header for the old V2 auth signatures
#
########################################################################
sub _add_auth_header { ## no critic (ProhibitUnusedPrivateSubroutines)
########################################################################
my ( $self, $headers, $method, $path ) = @_;
my ( $aws_access_key_id, $aws_secret_access_key, $token )
= $self->get_credentials;
if ( not $headers->header('Date') ) {
$headers->header( Date => time2str(time) );
}
if ($token) {
$headers->header( $AMAZON_HEADER_PREFIX . 'security-token', $token );
}
my $canonical_string = $self->_canonical_string( $method, $path, $headers );
$self->get_logger->trace( Dumper( [$headers] ) );
$self->get_logger->trace("canonical string: $canonical_string\n");
my $encoded_canonical
= $self->_encode( $aws_secret_access_key, $canonical_string );
$headers->header(
Authorization => "AWS $aws_access_key_id:$encoded_canonical" );
return;
}
# 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;
foreach my $p ( pairs %{$headers} ) {
my ( $k, $v ) = @{$p};
$http_header->header( $k => $v );
}
foreach my $p ( pairs %{$metadata} ) {
my ( $k, $v ) = @{$p};
$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 ) = @_;
# initial / meant to force host/bucket-name instead of DNS based name
$path =~ s/^\///xsm;
my %interesting_headers = ();
foreach my $p ( pairs %{$headers} ) {
my ( $key, $value ) = @{$p};
my $lk = lc $key;
if ( $lk eq 'content-md5'
or $lk eq 'content-type'
or $lk eq 'date'
or $lk =~ /^$AMAZON_HEADER_PREFIX/xsm ) {
$interesting_headers{$lk} = $self->_trim($value);
}
}
# these keys get empty strings if they don't exist
$interesting_headers{'content-type'} ||= $EMPTY;
$interesting_headers{'content-md5'} ||= $EMPTY;
# just in case someone used this. it's not necessary in this lib.
if ( $interesting_headers{'x-amz-date'} ) {
$interesting_headers{'date'} = $EMPTY;
}
# if you're using expires for query string auth, then it trumps date
# (and x-amz-date)
if ($expires) {
$interesting_headers{'date'} = $expires;
}
my $buf = "$method\n";
foreach my $key ( sort keys %interesting_headers ) {
if ( $key =~ /^$AMAZON_HEADER_PREFIX/xsm ) {
$buf .= "$key:$interesting_headers{$key}\n";
}
else {
$buf .= "$interesting_headers{$key}\n";
}
}
# don't include anything after the first ? in the resource...
# $path =~ /^([^?]*)/xsm;
# $buf .= "/$1";
$path =~ /\A([^?]*)/xsm;
$buf .= "/$1";
# ...unless there any parameters we're interested in...
if ( $path =~ /[&?](acl|torrent|location|uploads|delete)([=&]|$)/xsm ) {
# if ( $path =~ /[&?](acl|torrent|location|uploads|delete)([=&])?/xsm ) {
$buf .= "?$1";
}
elsif ( my %query_params = URI->new($path)->query_form ) {
# see if the remaining parsed query string provides us with any
# query string or upload id
if ( $query_params{partNumber} && $query_params{uploadId} ) {
# re-evaluate query string, the order of the params is important
# for request signing, so we can't depend on URI to do the right
# thing
$buf .= sprintf '?partNumber=%s&uploadId=%s',
$query_params{partNumber},
$query_params{uploadId};
}
elsif ( $query_params{uploadId} ) {
$buf .= sprintf '?uploadId=%s', $query_params{uploadId};
}
}
return $buf;
}
########################################################################
sub _trim {
########################################################################
my ( $self, $value ) = @_;
$value =~ s/^\s+//xsm;
$value =~ s/\s+$//xsm;
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, $EMPTY );
return $urlencode ? $self->_urlencode($b64) : return $b64;
}
########################################################################
sub _urlencode {
########################################################################
my ( $self, $unencoded ) = @_;
return uri_escape_utf8( $unencoded, '^A-Za-z0-9\-\._~\x2f' ); ## no critic (RequireInterpolation)
}
1;
__END__
=pod
=head1 NAME
Amazon::S3 - A portable client library for working with and
managing Amazon S3 buckets and keys.
=begin markdown
=end markdown
=head1 SYNOPSIS
use Amazon::S3;
my $aws_access_key_id = "Fill me in!";
my $aws_secret_access_key = "Fill me in too!";
my $s3 = Amazon::S3->new(
{ aws_access_key_id => $aws_access_key_id,
aws_secret_access_key => $aws_secret_access_key,
retry => 1
}
);
my $response = $s3->buckets;
# create a bucket
my $bucket_name = $aws_access_key_id . '-net-amazon-s3-test';
my $bucket = $s3->add_bucket( { bucket => $bucket_name } )
or die $s3->err . ": " . $s3->errstr;
# store a key with a content-type and some optional metadata
my $keyname = 'testing.txt';
my $value = 'T';
$bucket->add_key(
$keyname, $value,
{ content_type => 'text/plain',
'x-amz-meta-colour' => 'orange',
}
);
# copy an object
$bucket->copy_object(
source => $source,
key => $new_keyname
);
# list keys in the bucket
$response = $bucket->list
or die $s3->err . ": " . $s3->errstr;
print $response->{bucket}."\n";
for my $key (@{ $response->{keys} }) {
print "\t".$key->{key}."\n";
}
# delete key from bucket
$bucket->delete_key($keyname);
# delete multiple keys from bucket
$bucket->delete_keys([$key1, $key2, $key3]);
# delete bucket
$bucket->delete_bucket;
=head1 DESCRIPTION
This documentation refers to version 0.65.
C provides a portable client interface to Amazon Simple
Storage System (S3).
This module is rather dated, however with some help from a few
contributors it has had some recent updates. Recent changes include
implementations of:
=over 5
=item ListObjectsV2
=item CopyObject
=item DeleteObjects
=back
Additionally, this module now implements Signature Version 4 signing,
unit tests have been updated and more documentation has been added or
corrected. Credentials are encrypted if you have encryption modules installed.
=head2 Comparison to Other Perl S3 Modules
Other implementations for accessing Amazon's S3 service include
C and the C project. C ostensibly
was intended to be a drop-in replacement for C that
"traded some performance in return for portability". That statement is
no longer accurate as C may have changed the interface in
ways that might break your applications if you are relying on
compatibility with C.
However, C and C today, are dependent on
C which may in fact level the playing field in terms of
performance penalties that may have been introduced by recent updates
to C. Changes to C include the use of more
Perl modules in lieu of raw Perl code to increase maintainability and
stability as well as some refactoring. C also strives now
to adhere to best practices as much as possible.
C may be a much more robust implementation of
a Perl S3 interface, however this module may still appeal to
those that favor simplicity of the interface and a lower number of
dependencies. Below is the original description of the module.
=over 10
Amazon S3 is storage for the Internet. It is designed to
make web-scale computing easier for developers. Amazon S3
provides a simple web services interface that can be used to
store and retrieve any amount of data, at any time, from
anywhere on the web. It gives any developer access to the
same highly scalable, reliable, fast, inexpensive data
storage infrastructure that Amazon uses to run its own
global network of web sites. The service aims to maximize
benefits of scale and to pass those benefits on to
developers.
To sign up for an Amazon Web Services account, required to
use this library and the S3 service, please visit the Amazon
Web Services web site at http://www.amazonaws.com/.
You will be billed accordingly by Amazon when you use this
module and must be responsible for these costs.
To learn more about Amazon's S3 service, please visit:
http://s3.amazonaws.com/.
The need for this module arose from some work that needed
to work with S3 and would be distributed, installed and used
on many various environments where compiled dependencies may
not be an option. L used L
tying it to that specific and often difficult to install
option. In order to remove this potential barrier to entry,
this module is forked and then modified to use L
via L.
=back
=head1 LIMITATIONS AND DIFFERENCES WITH EARLIER VERSIONS
As noted, this module is no longer a I replacement for
C and has limitations and differences that may impact
the use of this module in your applications. Additionally, one of the
original intents of this fork of C was to reduce the
number of dependencies and make it I. Recent changes
to this module have introduced new dependencies in order to improve
the maintainability and provide additional features. Installing CPAN
modules is never easy, especially when the dependencies of the
dependencies are impossible to control and include XS modules.
=over 5
=item MINIMUM PERL
Technically, this module should run on versions 5.10 and above,
however some of the dependencies may require higher versions of
C or some lower versions of the dependencies due to conflicts
with other versions of dependencies...it's a crapshoot when dealing
with older C versions and CPAN modules.
You may however, be able to build this module by installing older
versions of those dependencies and take your chances that those older
versions provide enough working features to support C. It
is likely they do...and this module has recently been tested on
version 5.10.0 C using some older CPAN modules to resolve
dependency issues.
To build this module on an earlier version of C you may need to
downgrade some modules. In particular I have found this recipe to
work for building and testing on 5.10.0.
In this order install:
HTML::HeadParser 2.14
LWP 6.13
Amazon::S3
...other versions I work...YMMV.
=item API Signing
Making calls to AWS APIs requires that the calls be signed. Amazon
has added a new signing method (Signature Version 4) to increase
security around their APIs. This module no longer utilizes Signature
Version V2.
B
See L below for important details.
=over 10
=item Signature Version 4
L
I
Unlike Signature Version 2, Version 4 requires a regional
parameter. This implies that you need to supply the bucket's region
when signing requests for any API call that involves a specific
bucket. Starting with version 0.55 of this module,
C provides a new method (C) and accepts
in the constructor a C parameter. If a region is not
supplied, the region for the bucket will be set to the region set in
the C object (C) that you passed to the bucket's
new constructor. Alternatively, you can request that the bucket's new
constructor determine the bucket's region for you by calling the
C method.
When signing API calls, the region for the specific bucket will be
used. For calls that are not regional (C, e.g.) the default
region ('us-east-1') will be used.
=item Signature Version 2
L
=back
=item New APIs
This module does not support some of the newer API method calls
for S3 added after the initial creation of this interface.
=item Multipart Upload Support
There are some recently added unit tests for multipart uploads that
seem to indicate this feature is working as expected. Please report
any deviation from expected results if you are using those methods.
For more information regarding multipart uploads visit the link below.
L
=back
=head1 METHODS AND SUBROUTINES
=head2 new
Create a new S3 client object. Takes some arguments:
=over
=item credentials (optional)
Reference to a class (like C) that can provide
credentials via the methods:
get_aws_access_key_id()
get_aws_secret_access_key()
get_token()
If you do not provide a credential class you must provide the keys
when you instantiate the object. See below.
I
=item aws_access_key_id
Use your Access Key ID as the value of the AWSAccessKeyId parameter
in requests you send to Amazon Web Services (when required). Your
Access Key ID identifies you as the party responsible for the
request.
=item aws_secret_access_key
Since your Access Key ID is not encrypted in requests to AWS, it
could be discovered and used by anyone. Services that are not free
require you to provide additional information, a request signature,
to verify that a request containing your unique Access Key ID could
only have come from you.
B
I
=item token
An optional temporary token that will be inserted in the request along
with your access and secret key. A token is used in conjunction with
temporary credentials when your EC2 instance has
assumed a role and you've scraped the temporary credentials from
I
=item secure
Set this to a true value if you want to use SSL-encrypted connections
when connecting to S3. Starting in version 0.49, the default is true.
default: true
=item timeout
Defines the time, in seconds, your script should wait or a
response before bailing.
default: 30s
=item retry
Enables or disables the library to retry upon errors. This
uses exponential backoff with retries after 1, 2, 4, 8, 16,
32 seconds, as recommended by Amazon.
default: off
=item host
Defines the S3 host endpoint to use.
default: s3.amazonaws.com
Note that requests are made to domain buckets when possible. You can
prevent that behavior if either the bucket name does not conform to
DNS bucket naming conventions or you preface the bucket name with '/'.
If you set a region then the host name will be modified accordingly if
it is an Amazon endpoint.
=item region
The AWS region you where your bucket is located.
default: us-east-1
=item buffer_size
The default buffer size when reading or writing files.
default: 4096
=back
=head2 signer
Sets or retrieves the signer object. API calls must be signed using
your AWS credentials. By default, starting with version 0.54 the
module will use L as the signer and
instantiate a signer object in the constructor. Note however, that
signers need your credentials and they I get stored by that
class, making them susceptible to inadvertant exfiltration. You have a
few options here:
=over 5
=item 1. Use your own signer.
You may have noticed that you can also provide your own credentials
object forcing this module to use your object for retrieving
credentials. Likewise, you can use your own signer so that this
module's signer never sees or stores those credentials.
=item 2. Pass the credentials object and set C to a
false value.
If you pass a credentials object and set C to a false
value, the module will use the credentials object to retrieve
credentials and create a new signer each time an API call is made that
requires signing. This prevents your credentials from being stored
inside of the signer class.
I
=item 3. Pass credentials, set C to a false value.
Unfortunately, while this will prevent L
from hanging on to your credentials, you credentials will be stored in
the C object.
Starting with version 0.55 of this module, if you have installed
L and L, your credentials will be
encrypted using a random key created when the class is
instantiated. While this is more secure than leaving them in
plaintext, if the key is discovered (the key however is not stored in
the object's hash) and the object is dumped, your I
credentials can be exposed.
=item 4. Use very granular credentials for bucket access only.
Use credentials that only allow access to a bucket or portions of a
bucket required for your application. This will at least limit the
I of any potential security breach.
=item 5. Do nothing...send the credentials, use the default signer.
In this case, both the C class and the
L have your credentials. Caveat Emptor.
See also L for more information about safely
storing your credentials and preventing exfiltration.
=back
=head2 region
Sets the region for the API calls. This will also be the
default when instantiating the bucket object unless you pass the
region parameter in the C method or use the C
flag that will I verify the region of the bucket using the
C method.
default: us-east-1
=head2 buckets
buckets([verify-region])
=over
=item verify-region (optional)
C is a boolean value that indicates if the
bucket's region should be verified when the bucket object is
instantiated.
If set to true, this method will call the C method with
C set to true causing the constructor to call the
C for each bucket to set the bucket's
region. This will cause a significant decrease in the peformance of
the C method. Setting the region for each bucket is
necessary since API operations on buckets require the region of the
bucket when signing API requests. If all of your buckets are in the
same region and you have passed a region parameter to your S3 object,
then that region will be used when calling the constructor of your
bucket objects.
default: false
=back
Returns a reference to a hash containing the metadata for all of the
buckets owned by the accout or (see below) or C on error.
=over
=item owner_id
The owner ID of the bucket's owner.
=item owner_display_name
The name of the owner account.
=item buckets
An array of L objects for the account. Returns
C if there are not buckets or an error occurs.
=back
=head2 add_bucket
add_bucket(bucket-configuration)
C is a reference to a hash with bucket configuration
parameters.
=over
=item bucket
The name of the bucket. See L
for more details on bucket naming rules.
=item acl_short (optional)
See the set_acl subroutine for documenation on the acl_short options
=item location_constraint
=item region
The region the bucket is to be created in.
=back
Returns a L object on success or C on failure.
=head2 bucket
bucket(bucket, [region])
bucket({ bucket => bucket-name, verify_region => boolean, region => region });
Takes a scalar argument or refernce to a hash of arguments.
You can pass the region or set C indicating that
you want the bucket constructor to detemine the bucket region.
If you do not pass the region or set the C value, the
region will be set to the default region set in your C
object.
See L for a complete description of the C
method.
=head2 delete_bucket
Takes either a L object or a reference to a hash
containing:
=over
=item bucket
The name of the bucket to remove
=item region
Region the bucket is located in. If not provided, the method will
determine the bucket's region by calling C.
=back
Returns a boolean indicating the success or failure of the API
call. Check C or C for error messages.
Note from the L
=over 10
If a bucket is empty, you can delete it. After a bucket is deleted,
the name becomes available for reuse. However, after you delete the
bucket, you might not be able to reuse the name for various reasons.
For example, when you delete the bucket and the name becomes available
for reuse, another AWS account might create a bucket with that
name. In addition, B. If you want to use the same bucket name, we
recommend that you don't delete the bucket.
=back
=head2 dns_bucket_names
Set or get a boolean that indicates whether to use DNS bucket
names.
default: true
=head2 list_bucket, list_bucket_v2
List all keys in this bucket.
Takes a reference to a hash of arguments:
=over
=item bucket (required)
The name of the bucket you want to list keys on.
=item prefix
Restricts the response to only contain results that begin with the
specified prefix. If you omit this optional argument, the value of
prefix for your query will be the empty string. In other words, the
results will be not be restricted by prefix.
=item delimiter
If this optional, Unicode string parameter is included with your
request, then keys that contain the same string between the prefix
and the first occurrence of the delimiter will be rolled up into a
single result element in the CommonPrefixes collection. These
rolled-up keys are not returned elsewhere in the response. For
example, with prefix="USA/" and delimiter="/", the matching keys
"USA/Oregon/Salem" and "USA/Oregon/Portland" would be summarized
in the response as a single "USA/Oregon" element in the CommonPrefixes
collection. If an otherwise matching key does not contain the
delimiter after the prefix, it appears in the Contents collection.
Each element in the CommonPrefixes collection counts as one against
the MaxKeys limit. The rolled-up keys represented by each CommonPrefixes
element do not. If the Delimiter parameter is not present in your
request, keys in the result set will not be rolled-up and neither
the CommonPrefixes collection nor the NextMarker element will be
present in the response.
NOTE: CommonPrefixes isn't currently supported by Amazon::S3.
=item max-keys
This optional argument limits the number of results returned in
response to your query. Amazon S3 will return no more than this
number of results, but possibly less. Even if max-keys is not
specified, Amazon S3 will limit the number of results in the response.
Check the IsTruncated flag to see if your results are incomplete.
If so, use the Marker parameter to request the next page of results.
For the purpose of counting max-keys, a 'result' is either a key
in the 'Contents' collection, or a delimited prefix in the
'CommonPrefixes' collection. So for delimiter requests, max-keys
limits the total number of list results, not just the number of
keys.
=item marker
This optional parameter enables pagination of large result sets.
C specifies where in the result set to resume listing. It
restricts the response to only contain results that occur alphabetically
after the value of marker. To retrieve the next page of results,
use the last key from the current page of results as the marker in
your next request.
See also C, below.
If C is omitted,the first page of results is returned.
=back
Returns C on error and a reference to a hash of data on success:
The return value looks like this:
{
bucket => $bucket_name,
prefix => $bucket_prefix,
marker => $bucket_marker,
next_marker => $bucket_next_available_marker,
max_keys => $bucket_max_keys,
is_truncated => $bucket_is_truncated_boolean
keys => [$key1,$key2,...]
}
=over
=item is_truncated
Boolean flag that indicates whether or not all results of your query were
returned in this response. If your results were truncated, you can
make a follow-up paginated request using the Marker parameter to
retrieve the rest of the results.
=item next_marker
A convenience element, useful when paginating with delimiters. The
value of C, if present, is the largest (alphabetically)
of all key names and all CommonPrefixes prefixes in the response.
If the C flag is set, request the next page of results
by setting C to the value of C. This element
is only present in the response if the C parameter was
sent with the request.
=back
Each key is a reference to a hash that looks like this:
{
key => $key,
last_modified => $last_mod_date,
etag => $etag, # An MD5 sum of the stored content.
size => $size, # Bytes
storage_class => $storage_class # Doc?
owner_id => $owner_id,
owner_displayname => $owner_name
}
=head2 get_bucket_location
get_bucket_location(bucket-name)
get_bucket_locaiton(bucket-obj)
This is a convenience routines for the C of
the bucket object. This method will return the default
region of 'us-east-1' when C returns a null
value.
my $region = $s3->get_bucket_location('my-bucket');
Starting with version 0.55, C will call this
C to determine the region for the
bucket. You can get the region for the bucket by using the C
method of the bucket object.
my $bucket = $s3->bucket('my-bucket');
my $bucket_region = $bucket->region;
=head2 get_logger
Returns the logger object. If you did not set a logger when you
created the object then an instance of C is
returned. You can log to STDERR using this logger. For example:
$s3->get_logger->debug('this is a debug message');
$s3->get_logger->trace(sub { return Dumper([$response]) });
=head2 list_bucket_all, list_bucket_all_v2
List all keys in this bucket without having to worry about
'marker'. This is a convenience method, but may make multiple requests
to S3 under the hood.
Takes the same arguments as C.
I method.>
=head2 err
The S3 error code for the last error encountered.
=head2 errstr
A human readable error string for the last error encountered.
=head2 error
The decoded XML string as a hash object of the last error.
=head2 last_response
Returns the last L object.
=head2 last_request
Returns the last L object.
=head2 level
Set the logging level.
default: error
=head2 turn_on_special_retry
Called to add extra retry codes if retry has been set
=head2 turn_off_special_retry
Called to turn off special retry codes when we are deliberately triggering them
=head1 ABOUT
This module contains code modified from Amazon that contains the
following notice:
# This software code is made available "AS IS" without warranties of any
# kind. You may copy, display, modify and redistribute the software
# code either by itself or as incorporated into your code; provided that
# you do not remove any proprietary notices. Your use of this software
# code is at your own risk and you waive any claim against Amazon
# Digital Services, Inc. or its affiliates with respect to your use of
# this software code. (c) 2006 Amazon Digital Services, Inc. or its
# affiliates.
=head1 TESTING
Testing S3 is a tricky thing. Amazon wants to charge you a bit of
money each time you use their service. And yes, testing counts as using.
Because of this, the application's test suite skips anything approaching
a real test unless you set these environment variables:
For more on testing this module see L
=over
=item AMAZON_S3_EXPENSIVE_TESTS
Doesn't matter what you set it to. Just has to be set
=item AMAZON_S3_HOST
Sets the host to use for the API service.
default: s3.amazonaws.com
Note that if this value is set, DNS bucket name usage will be disabled
for testing. Most likely, if you set this variable, you are using a
mocking service and your bucket names are probably not resolvable. You
can override this behavior by setting C to any
value.
=item AWS_S3_DSN_BUCKET_NAMES
Set this to any value to override the default behavior of disabling
DNS bucket names during testing.
=item AWS_ACCESS_KEY_ID
Your AWS access key
=item AWS_SECRET_ACCESS_KEY
Your AWS sekkr1t passkey. Be forewarned that setting this environment variable
on a shared system might leak that information to another user. Be careful.
=item AMAZON_S3_SKIP_ACL_TESTS
Doesn't matter what you set it to. Just has to be set if you want
to skip ACLs tests.
=item AMAZON_S3_SKIP_PERMISSIONS
Skip tests that check for enforcement of ACLs...as of this version,
LocalStack for example does not support enforcement of ACLs.
=item AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST
Doesn't matter what you set it to. Just has to be set if you want
to skip region constraint test.
=item AMAZON_S3_MINIO
Doesn't matter what you set it to. Just has to be set if you want
to skip tests that would fail on minio.
=item AMAZON_S3_LOCALSTACK
Doesn't matter what you set it to. Just has to be set if you want
to skip tests that would fail on LocalStack.
=item AMAZON_S3_REGIONS
A comma delimited list of regions to use for testing. The default will
only test creating a bucket in the local region.
=back
I or C
if you want to create real tests for your applications or this module.>
Here's bash script for testing using LocalStack
#!/bin/bash
# -*- mode: sh; -*-
BUCKET=net-amazon-s3-test-test
ENDPOINT_URL=s3.localhost.localstack.cloud:4566
AMAZON_S3_EXPENSIVE_TESTS=1 \
AMAZON_S3_HOST=$ENDPOINT_URL \
AMAZON_S3_LOCALSTACK=1 \
AWS_ACCESS_KEY_ID=test \
AWS_ACCESS_SECRET_KEY=test \
AMAZON_S3_DOMAIN_BUCKET_NAMES=1 make test 2>&1 | tee test.log
To run the tests...clone the project and build the software.
cd src/main/perl
./test.localstack
=head1 ADDITIONAL INFORMATION
=head2 LOGGING AND DEBUGGING
Additional debugging information can be output to STDERR by setting
the C option when you instantiate the C
object. Levels are represented as a string. The valid levels are:
fatal
error
warn
info
debug
trace
You can set an optionally pass in a logger that implements a subset of
the C interface. Your logger should support at least
these method calls. If you do not supply a logger the default logger
(C) will be used.
get_logger()
fatal()
error()
warn()
info()
debug()
trace()
level()
At the C level, every HTTP request and response will be output
to STDERR. At the C level information regarding the higher
level methods will be output to STDERR. There currently is no
additional information logged at lower levels.
=head2 S3 LINKS OF INTEREST
=over 5
=item L
=item L
=item L
=item L
=item L
=item L
=back
=head1 SUPPORT
Bugs should be reported via the CPAN bug tracker at
L
For other issues, contact the author.
=head1 REPOSITORY
L
=head1 AUTHOR
Original author: Timothy Appnel
Current maintainer: Rob Lauer
=head1 SEE ALSO
L, L
=head1 COPYRIGHT AND LICENCE
This module was initially based on L 0.41, by
Leon Brocard. Net::Amazon::S3 was based on example code from
Amazon with this notice:
I
The software is released under the Artistic License. The
terms of the Artistic License are described at
http://www.perl.com/language/misc/Artistic.html. Except
where otherwise noted, C is Copyright 2008, Timothy
Appnel, tima@cpan.org. All rights reserved.
=cut
Amazon-S3-0.65/README-TESTING.md 0000644 0001750 0001750 00000016410 14531467536 015442 0 ustar rclauer rclauer # Testing This Module
From the original documentation for `Net::Amazon::S3`...
>Testing S3 is a tricky thing. Amazon wants to charge you a bit of
money each time you use their service. And yes, testing counts as
using. Because of this, the application's test suite by default, skips anything
approaching a real test.
I'm not so sure exactly how expensive creating a bucket and then
reading and writing a few bytes from S3 really is nowadays. In any
event, by default, the tests that actually create buckets and objects
will not be executed unless you set the environment variable
`AMAZON_S3_EXPENSIVE_TESTS` to some value. Testing can be controlled
with additional environment variables described below.
| Variable | Description |
| -------- | ----------- |
| `AMAZON_S3_EXPENSIVE_TESTS` | Doesn't matter what you set it to. Just has to be set |
| `AWS_ACCESS_KEY_ID` | Your AWS access key |
| `AWS_ACCESS_KEY_SECRET` | Your AWS sekkr1t passkey. Be forewarned that setting this environment variable on a shared system might leak that information to another user. Be careful. |
| `AWS_SESSION_TOKEN` | Optional session token. |
| `AMAZONS3_HOST` | Defaults to s3.amazonaws.com. Set this for example if you want to test the module against an API compatible service like minio. |
| `AMAZON_S3_SKIP_ACL_TESTS` | Doesn't matter what you set it to. Just has to be set if you want to skip ACLs tests. |
| `AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST` | Doesn't matter what you set it to. Just has to be set if you want to skip region constraint test. |
| `AMAZON_S3_MINIO` | Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on minio. |
| `AMAZON_S3_LOCALSTACK` | Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on minio. |
| `AMAZON_S3_REGIONS` | Comma delimited list of regions to test |
__CAUTION__
__In order to test ACLs, the test will create a public bucket and then
make the bucket private. The test will perform the same kind of tests
on objects. The test will also delete the bucket and the objects as
well, however, stuff happens and you may be left with a public bucket
or object should these tests fail.__
__Check your account to make sure the buckets and objects have been
deleted. The bucket name will be have a prefix of
`net-amazon-s3-test-` and a suffix of your `AWS_ACCESS_KEY_ID`.__
# Regional Constraints
One of the original unit tests for this module attempted to create a
bucket in the EU region to ostensibly test regional constraints and
DNS based bucket names.
The test would create a bucket in the default region, delete the
bucket, then attempt to create a bucket with the same name in a
different region. Today, this will fail consistently with a 409 error
(Operation Aborted). This is due to the fact that you cannot
immediately reclaim a bucket name after deletion as it may takes some
time to free that bucket name in all regions.
[Bucket restrictions and limitations](https://docs.aws.amazon.com/AmazonS3/latest/userguide/BucketRestrictions.html)
To test regional constraints then, the current test will change the
name of the bucket if it encounters a 409 error while creating the
bucket. The test will then proceed to read the ACLs to determine if
the constraint was successful. By default, the tests will only create
a bucket in the default region (but it will check that the constraint is
in place). If you want to test creation of buckets in alternate
regions in addition to testing in the default region, set the
environment variable `AMAZON_S3_REGIONS` to one or more comma
separated regions.
```
cd src/main/perl
make test AMAZON_S3_EXPENSIVE_TESTS=1 AMAZON_S3_REGIONS='eu-west-1'
```
# Credentials for Testing
You should set the environment variables `AWS_ACCESS_KEY_ID` and
`AWS_ACCESS_SECRET_KEY` to your AWS credential values that have the
ability to create and write to buckets.
If you set environment variable `AMAZON_S3_CREDENTIAL` to any value,
the tests will use the `Amazon::Credentials` module to look for valid
credentials in your environment, your credentials files or the
instance role if you are running on an EC2.
# Using S3 Mocking Services
If you want to test *some* parts of this module but don't want to
spend a few pennies (or don't have access to AWS credentials) you can
try one of the S3 mocking services. The two of the most popular services
seem to be:
* [LocalStack](https://localstack.io)
* [minio](https://min.io)
Both of these implement a subset of the S3 API. __Note that Some tests will fail
on both services (as of the writing of this document).__ To make it
through the tests, try setting one or more of the environment
variables above which will selectively skip some test.
If you are using a mocking service, you might find it useful to set
the environment variable AWS_EC2_METADATA_DISABLED to a true value.
```
export AWS_EC2_METADATA_DISABLED=true
```
This will prevent the AWS CLI from looking for metadata when you are
not actually running on an EC2 instance or container. Without this
variable set, the CLI attempts to access the metadata service at
http://169.254.169.254/latest/meta-data/ until it eventually times out.
## Testing with LocalStack
LocalStack seems to be the easiest to work with and supports a number
of AWS APIs besides S3. It does not implement the full suite of APIs
however. In particular, LocalStack does not enforce ACLs. Accordingly,
those tests are skipped if the environment variable AMAZON_S3_LOCALSTACK
is set to any value.
A `docker-compose.yml` file is included now in the
project.
```
version: "3.8"
services:
localstack:
container_name: "${LOCALSTACK_DOCKER_NAME-localstack_main}"
image: localstack/localstack
hostname: s3
networks:
default:
aliases:
- s3.localhost.localstack.cloud
- net-amazon-s3-test-test.localhost.localstack.cloud
ports:
- "127.0.0.1:4510-4530:4510-4530"
- "127.0.0.1:4566:4566"
- "127.0.0.1:4571:4571"
environment:
- SERVICES=s3,ssm,secretsmanager,kms,sqs,ec2,events,sts,logs
- DEBUG=${DEBUG-}
- DATA_DIR=${DATA_DIR-}
- LAMBDA_EXECUTOR=${LAMBDA_EXECUTOR-}
- HOST_TMP_FOLDER=${TMPDIR:-/tmp/}localstack
- DOCKER_HOST=unix:///var/run/docker.sock
volumes:
- "${LOCALSTACK_VOLUME_DIR:-./volume}:/var/lib/localstack"
- "/var/run/docker.sock:/var/run/docker.sock"
```
When testing with LocalStack you'll need to set some environment
variables to get through (the majority) of the tests.
Environment Variable | Value | Description
-------------------- | ----- | -----------
AMAZON_EXPENSIVE_TESTS | 1 | enables testing of S3 API
AMAZONS3_HOST | localhost:4566
AMAZON_S3_LOCALSTACK | any | skips some tests that will fail on LocalStack
AWS_ACCESS_KEY_ID | test | AWS access key for LocalStack
AWS_ACCESS_KEY_SECRET | test | AWS secret access key for LocalStack
In order to test domain name buckets, you will need to spoof a domain
name for your bucket by setting the name of the bucket in your
`/etc/hosts` file.
```
127.0.0.1 localhost net-amazon-s3-test-test.s3.localhost.localstack.cloud
```
To run tests using LocalStack...
```
AMAZON_S3_EXPENSIVE_TESTS=1 \
AMAZON_S3_HOST=s3.localhost.localstack.cloud:4566 \
AMAZON_S3_LOCALSTACK=1 \
AWS_ACCESS_KEY_ID=test \
AWS_ACCESS_SECRET_KEY=test \
AMAZON_S3_DOMAIN_BUCKET_NAMES=1 make test
```
Amazon-S3-0.65/Makefile.PL 0000644 0001750 0001750 00000005322 14531467536 015022 0 ustar rclauer rclauer # autogenerated by /usr/local/libexec/make-cpan-dist.pl on Tue Nov 28 17:53:18 2023
use strict;
use warnings;
use ExtUtils::MakeMaker;
use File::ShareDir::Install;
if ( -d 'share' ) {
install_share 'share';
}
WriteMakefile(
NAME => 'Amazon::S3',
MIN_PERL_VERSION => '5.10.0',
AUTHOR => 'Rob Lauer ',
VERSION_FROM => 'lib/Amazon/S3.pm',
ABSTRACT => 'Perl interface to AWS S3 API',
LICENSE => 'perl',
PL_FILES => {},
EXE_FILES => [],
PREREQ_PM => {
'Class::Accessor::Fast' => '0',
'Digest::HMAC_SHA1' => '0',
'Digest::MD5::File' => '0',
'HTTP::Date' => '0',
'IO::Scalar' => '0',
'JSON::PP' => '0',
'LWP' => '0',
'LWP::Protocol::https' => '0',
'LWP::UserAgent::Determined' => '0',
'List::Util' => '1.5',
'Net::Amazon::Signature::V4' => '0',
'Net::HTTP' => '0',
'Pod::Markdown' => '0',
'Readonly' => '0',
'URI' => '0',
'URI::Escape' => '0',
'XML::Simple' => '0'
},
BUILD_REQUIRES => {
'ExtUtils::MakeMaker' => '6.64',
'File::ShareDir::Install' => 0,
},
CONFIGURE_REQUIRES => {
'ExtUtils::MakeMaker' => '6.64',
'File::ShareDir::Install' => 0,
},
TEST_REQUIRES => {
'Digest::MD5::File' => '0.08',
'Test::More' => '1.302190',
'Test::Output' => '1.033'
},
META_MERGE => {
'meta-spec' => { 'version' => 2 },
'provides' => {
'Amazon::S3' => {
'file' => 'lib/Amazon/S3.pm',
'version' => '0.65'
},
'Amazon::S3::Bucket' => {
'file' => 'lib/Amazon/S3/Bucket.pm',
'version' => '0.65'
},
'Amazon::S3::Constants' => {
'file' => 'lib/Amazon/S3/Constants.pm',
'version' => '0.65'
},
'Amazon::S3::Logger' => {
'file' => 'lib/Amazon/S3/Logger.pm',
'version' => '0.65'
},
'Amazon::S3::Signature::V4' => {
'file' => 'lib/Amazon/S3/Signature/V4.pm',
'version' => 'undef'
}
},
'resources' => {
'bugtracker' => {
'mailto' => 'rlauer6@comcast.net',
'web' => 'http://github.com/rlauer6/perl-amazon-s3/issues'
},
'homepage' => 'http://github.com/rlauer6/perl-amazon-s3',
'repository' => {
'type' => 'git',
'url' => 'git://github.com/rlauer6/perl-amazon-s3.git',
'web' => 'http://github.com/rlauer6/perl-amazon-s3'
}
}
}
);
package MY;
use File::ShareDir::Install qw( postamble );
Amazon-S3-0.65/MANIFEST 0000644 0001750 0001750 00000000762 14531467536 014204 0 ustar rclauer rclauer ChangeLog
lib/Amazon/S3.pm
lib/Amazon/S3/Bucket.pm
lib/Amazon/S3/Constants.pm
lib/Amazon/S3/Logger.pm
lib/Amazon/S3/Signature/V4.pm
Makefile.PL
MANIFEST This list of files
README-TESTING.md
README.md
S3TestUtils.pm
t/01-api.t
t/02-logger.t
t/03-region.t
t/04-list-buckets.t
t/05-multipart-upload.t
t/06-list-multipart-uploads.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
Amazon-S3-0.65/ChangeLog 0000644 0001750 0001750 00000034655 14531467536 014635 0 ustar rclauer rclauer Tue Nov 28 17:42:44 2023 Rob Lauer
[0.65]:
* src/main/perl/lib/Amazon/S3.pm.in
(signer)
- get token from creds object always
Thu Jul 20 07:47:36 2023 Rob Lauer
[0.64 - get_location_constraint() ]:
* VERSION: bump
* NEWS.md: updated
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
(get_location_constraint): content already decoded
Mon Apr 17 08:07:13 2023 Rob Lauer
[0.63 - pass -key to Crypt::CBC]:
* src/mai/perl/lib/Amazon/S3.pm.in
(_decrypt): pass encryption key as -key and -pass
Fri Apr 14 08:29:32 2023 Rob Lauer
[0.62 - list_bucket, buckets]:
* VERSION: bump
* NEWS.md: updated
* README.md: generated
* src/main/perl/lib/Amazon/S3.pm.in
- minor pod updates
(buckets)
- return if null or error, not _remember_errors()
(list_bucket): likewise
* src/main/perl/t/01-api: diag before bailing out
* src/main/perl/t/04-list-buckets.t
- added test for listing non-existent bucket
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
- minor pod tweak, alphabetize methods
Wed Mar 29 08:12:48 2023 Rob Lauer
[0.61 - delete_keys(), refactoring]:
* s3-perl.pl
- added ASCII table output, refactored
* NEWS.md: updated
* src/main/perl/lib/Amazon/S3.pm.in
- some perlcritic refactoring
- pod updates
(list_bucket): use different markers for v1, v2
(list_bucket_all)
- throw $EVAL_ERROR "The server has stopped responding"
(_make_request): light refactoring
(_sendrequest): accept keep_root and pass to _xpc_of_content()
(_xpc_of_content): NoAttr => $TRUE
(_remember_errors): return false if no error
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
- some perlcritic refactoring
(add_key): check reftype properly
(set_acl): send conten-length
* src/main/perl/lib/Amazon/S3/Constants.pm.in
- additional constants for refactoring
- move subs from t/01-api.t to S3TestUtils.pm
* src/main/perl/t/01-api.t: refactoring
* src/main/perl/t/02-logger.t: likewise
* src/main/perl/t/03-region.t: likewise
* src/main/perl/t/04-list-buckets.t: likewise
* src/main/perl/t/05-multipart-upload.t: likewise
* src/main/perl/t/06-list-multipart-uploads.t: likewise
* src/main/perl/test.localstack: converted to bash script
* src/main/perl/S3TestUtils.pm: new
* cpan/buildspec.yml: add above to distribution
Mon Mar 27 10:47:54 2023 Rob Lauer
[0.61 - delete_keys()]:
* VERSION: bump
* NEWS.md: updated
* README.md: generated
* configure.ac: add check for make-cpan-dist.pl
* cpan/Makefile.am: use automake var for above
* src/main/perl/lib/Amazon/S3/.pm.in
(_make_request): don't encode the query string twice
(_send_request): precendence wrt regexp
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
(delete_keys): new
(_format_delete_keys): new
* src/main/perl/lib/Amazon/S3/Constants.pm.in
- new constants to support delete_keys() method
* src/main/perl/lib/Makefile.am: stop make on error
* src/main/perl/t/01-api.t: added tests for delete_keys()
* src/main/perl/test.localstack: save logs
Fri Feb 10 07:47:22 2023 Rob Lauer >
[0.60 - logging]:
* VERSION: bump
* NEWS.md: updated
* bootstrap: support M.rr style versions
* src/main/perl/lib/Amazon/S3.pm.in
- removed all end of block indicators inserted by perltidy
(new)
- only consider 'debug' flag when internal logger used
* src/main/perl/lib/Amazon/S3.pm.in
(new): new
* configure.ac
- fix email addres
- remove -Wall to prevent warning during configure
* s3-perl.pl: new
* src/main/perl/test.localstack: new
* .gitignore: added some of the files created by `make cpan`
Wed Jan 25 11:54:59 2023 Rob Lauer
[0.59 - copy_object]:
* VERSION: bump
* README.md: generated
* src/main/perl/lib/Amazon/S3.pm.in
- minor pod changes
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
(copy_object): new
* src/main/perl/Makefile.am: corrected comments re: make test
* cpan/Makefile.am: PROJECT_HOME
[unit tests]:
* src/main/perl/t/01-api.t
- added unit test for copy_object()
* src/main/perl/t/04-list-buckets.t
- use AMAZON_S3_HOST from environment not S3_HOST
* README-TESTING.md
- corrected way make test invoked
Mon Dec 19 09:25:04 2022 Rob Lauer
[0.58 - min perl required]:
* VERSION: bump
* cpan/buildspec.yml: min perl 5.10
* cpan/requires: JSON::PP
Sat Dec 3 14:09:29 2022 Rob Lauer
[0.57 - rpm packaging]:
* VERSION: bump
* perl-Amazon-S3.spec.in
(Requires): Net::Amazon::Signature::V4
* src/main/perl/lib/Makefile.am
- install Amazon::S3::Signature::V4 to correct directory
Tue Nov 29 10:39:43 2022 Rob Lauer
[0.56 - minor bug, 0.55 issues #8]:
* buildspec.yml: files should be relative to project home
* VERSION: bump
* NEWS.md: updated
* README-TESTING.md: more documentation
* Makefile.am: rpm, not rpmbuild directory
* src/main/perl/Makefile.am: comments re: testing
* src/main/perl/t/04-list-buckets.t
- enable debug mode if $ENV{DEBUG}
- dump response if error
* src/main/perl/lib/Amazon/S3.pm.in
- pod tweaks
(new)
- set -key and -pass for legacy Crypt::CBC
(buckets): avoid return explicit undef
(list_bucket)
- remove undefined hash members from input
(_make_request)
- use URI to set path, host, port if domain bucket ame
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
(last_response): typo, should be last_response(), not last_reponse()
(_uri): minor refactoring for clarity
(add_key): likewise, return a return code
(_add_key): minor refactoring
(get_key): minor refactoring, do not return explicit undef
(delete_key): minor refactoring for clarity
(set_acl): likewise
(get_acl)
- likewise
- return undef if 404 rather than croak
* docker-compose.yml: new
Mon Aug 1 15:44:04 2022 Rob Lauer
[0.55 - bucket region]:
* requires: latest version of most modules
* src/main/perl/lib/Amazon/S3.pm.in
- pod tweaks, corrections
- don't specify a minimum version of perl
(new): set default region to 'us-east-1', again
(get_bucket_location): $bucket, not $self
(buckets)
- verify region option
- pass hash of options and region to _send_request
(add_bucket)
- do not add region constraint if us-east-1
- refactored, send region to _send_request_expect_nothing
(delete_bucket): likewise refactored
(list_bucket): likewise refactored
(_make_request): use region() method of signer
(_do_http): debug statements, set last_reponse, reset_errors
(_do_http_no_redirect): likewise
(_send_request_expect_nothing): likewise
(_send_request_expect_nothing_probed)
- accept hash argument
- debug statements
- croak if redirect, but no Location
(error): new
(reset_errors): new
(_remember_error): set error
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
- pod tweaks, corrections
(new)
- + logger attribute
- + verify_region attribute, verify region if true
(_uri): remove leading '/'
(add_key): correct region if 301 response
(upload_multipart_object): debug messages
(upload_part_of_multipart_upload): likewise
(complete_multipart_upload): likewise
(get_key): remove redundant debug message
(delete_key): pass region to _send_request_expect_nothing
(set_acl): likewise
* src/main/perl/t/01-api.t: do not bailout on early tests
(error): new
(last_response): new
* src/main/perl/t/03-region.t: default region is us-east-1
Fri Jul 22 14:47:30 2022 Rob Lauer
[0.55 - testing, revert to XML::Simple]:
* src/main/perl/t/01-api.t: remove /r option in regex
* src/main/perl/t/04-list-buckets: likewise
* src/main/perl/lib/Amazon/S3.pm: use XML::Simple
* src/main/perl/lib/Amazon/S3/Bucket.pm.in: likewise
(make_xml_document_simple): new
* src/main/perl/t/06-list-multipart-uploads.t: XML::Simple
* configure.ac: remove Lib::XML, Lib::XML::Simple, add XML::Simple
* cpan/requires: likewise
* TODO.md: new
Thu Jul 21 11:14:16 2022 Rob Lauer
[0.55 - CI/CD]:
* .github/workflows/build.yml: remove make cpan
* README.md: generated
* src/main/perl/lib/Amazon/S3.pm.in: update badge
Thu Jul 21 10:53:03 2022 Rob Lauer
[0.55 - CI/CD]:
* .github/workflows/build.yml
* README.md: generated
* configure.ac: typo, IO::Scalar
* cpan/requires
- IO::Scalar, JSON:PP, Pod::Markdown
* src/main/perl/lib/Amazon/S3.pm.in: add badge
* NEWS.md: update
Mon Jul 18 16:27:41 2022 Rob Lauer
[0.55 - regional buckets]:
* NEWS.md: new
* src/main/perl/lib/Amazon/S3/Constants.pm.in
- + $MIN_MULTIPART_UPLOAD_CHUNK_SIZE
* src/main/perl/lib/Amazon/S3.pm.in
- document Signature V4 changes/implications
- use new Amazon::S3::Signature::V4 object
(_make_request): accept hash ref as argument
(get_bucket_location): new
(reset_signer_region): new
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
- document multipart methods
- send region in all _make_request calls
(_send_request): check if arg is a request
(new)
- accept region argument
- set bucket region if region not passed
(upload_multipart_object): new
* src/main/perl/lib/Amazon/S3/Signature/V4: new
* src/main/perl/lib/Makefile.am: add above to build
* src/main/perl/t/05-multpart-upload.t: new
* src/main/perl/t/06-list-multpart-upload.t: new
Thu Jul 14 06:34:56 2022 Rob Lauer >
[0.55 - use XML::LibXML]:
* VERSION: bump
* src/main/perl/lib/Amazon/S3.pm.in: use XML::LibXML, not XML::Simple
- perlcritic cleanups
- pod cleanup
(new)
- cache_signer
- encrypt credentials
(get_default_region): new
(get_aws_access_key_id): new
(get_aws_secret_access_key): new
(get_token): new
(_decrypt): new
(_encrypt): new
(signer)
- accesses _signer now
- set default region to caller's value or default
(buckets): set region to us-east-1 temporarily
(debug): new convenience method for level => 'debug'
(_make_request): allow disabling of domain buckets
* src/main/perl/lib/Amazon/S3/Bucket.pm.in: comment tweak
* src/main/perl/lib/Amazon/S3/Constant.pm.in: $DOT
* src/main/perl/t/01-api.t: set $dns_bucket_names to true?
* cpan/test-requires: +Test::Output
* cpan/requires: -Test::Output
* configure.ac
- ads_PERL_MODULE XML::LibXML::Simple, XML::LibXML, Test::Output
Wed Jul 13 13:09:04 2022 Rob Lauer
[0.54 - merge timmullin changes]:
* src/main/perl/lib/Amazon/S3.pm.in: see commit history
- use XML::LibXML
* src/main/perl/lib/Amazon/Bucket.pm.in: see commit history
Tue Jun 21 12:57:31 2022 Rob Lauer
[0.53 - unit test perl > 5.010]:
* VERSION: bump
* cpan/requires: sorted
* src/main/perl/lib/Amazon/S3.pm.in
- use 5.010
Sun Jun 19 08:19:19 2022 Rob Lauer
[0.52 - specify version of List::Util required]:
* cpan/requires: List::Util
* cpan/Makefile.am: option of --no-core
Sat Jun 18 07:05:14 2022 Rob Lauer
[0.51 - unit tests]:
* src/main/perl/t/02-logger.t: remove Log::Log4perl from test
Fri Jun 17 09:48:16 2022 Rob Lauer
[0.50 - version requirements]:
* cpan/Makefile.am: --no-core
* configure.ac: remove version requirements
* cpan/test-requires: add without core modules
* cpan/requires: remove core modules
Fri Jun 17 07:21:22 2022 Rob Lauer
[0.49]:
* Makefile.am
- make rpm
- use abs_builddir
- src, not dist now
* configure.ac
- get version from VERSION
- don't treat warnings as errors
- output package version
- check for rpmbuild, pod2markdown, scandeps-static.pl
- update dependencies
* src/main/perl/lib/Amazon/S3.pm.in
- new logging option
- mv'd from dist/lib/Amazon/S3.pm
- documenation updates
- refactoring, perlcritic cleanups
- use Amazon::S3::Constants
- allow passing credentials class
(_make_request): check dns_bucket_names option
(dns_bucket_names): new
(get_logger): new
(level): new
(get_credentials): new
(new)
- secure defaults to true
(region): new
(list_bucket_v2): new
(list_bucket_all_v2): new
(last_response): new
* src/main/perl/lib/Amazon/S3/Bucket.pm.in
- mv'd from dist/lib/Amazon/S3/Bucket.pm
- revert using XML::Simple
- use Amazon::S3::Constants
- perlcritic cleanup
- perltidy
(_uri): support DNS bucket names
(list_v2): new
(list_all_v2): new
* src/main/perl/lib/Makefile.am: new
* src/main/perl/Makefile.am: new
* src/main/Makefile.am: new
* src/Makefile.am: new
* cpan/Makfile.am: new
* cpan/requires: new
* cpan/test-requires: new
* src/main/perl/t/01-api.t
- env vars for controlling tests1
- mv'd from dist/t/01api.t
- refactored test
- support AWS mocking services
- enable/disable regional testing
- added list_vs test
- create tempfile instead of using t/README
* src/main/perl/t/02-logging.t: new
* src/main/perl/t/03-region.t: new
* src/main/perl/t/04-list-bucket.t: new
* .gitignore: *.pm
* ChangeLog: mv'd from dist/CHANGES
* README-TESTING.md: new
* README-BUILD.md: new
* VERSION: new
* bootstrap: new
* autotools/ads_PERL_INCLUDES.m4: new
* autotools/ads_PERL_LIBDIR.m4: new
* autotools/ads_PERL_MODULE.m4: new
* autotools/ads_PROG_PERL.m4: new
* autotools/am_rpm_build_mode.m4: new
* autotools/ax_am_conditional_example.m4: new
* autotools/ax_deps_check.m4: new
* autotools/ax_distcheck_hack.m4: new
* autotools/ax_rpmbuild_check.m4: new
Revision history for Perl module Amazon::S3:
0.48 Sep 17 2021
- remove leading '/' from bucket name
- modify tests for not s3.amazonaws.com hosts (e.g. minio)
0.47 Feb 4 2019
- update dependencies (XML::LibXML)
0.46 Jan 19 2019
- use temporary credentials
- error string
-
0.45 Aug 14 2009
- Applied patch to support any S3 end points (Tokuhiro Matsuno)
- Applied patches to not die when 0 or 1 buckets are return also (Tokuhiro Matsuno)
0.441 Jun 16 2008
- Added handling to get_key_filename where the key is used as the file
name if one is not provided.
0.44 Jun 08 2008
- Applied patch for fixing non-xml error parsing (Harold Sinclair)
- Ported changes from Net::Amazon::S3 0.42-0.44. These include:
- Fix bug with storing files consisting of "0" (Martin Atkins)
- Use of IO::File and binmode() to support Windows (Gabriel Weinberg)
- Add exponential backoff upon temporary errors with the new
retry option. (Leon Brocard)
0.41.2 Jan 20 2008
- Added documentation fixes that where causing
99-pod-coverage.t to fail.
0.411 Jan 19 2008
- initial release into CPAN
- Fork of Net::Amazon::S3 0.41
- Renamed packages
- Replaced XML::LibXML and XML::LibXML::XPathContext
with XML::Simple
- Ran perltidy over code
- Removed deprecated methods from Amazon::S3
- Revised documentation and README
Amazon-S3-0.65/S3TestUtils.pm 0000644 0001750 0001750 00000013356 14531467536 015562 0 ustar rclauer rclauer package S3TestUtils;
use strict;
use warnings;
use Data::Dumper;
use English qw(-no_match_vars);
use List::Util qw(any);
use Readonly;
use Test::More;
use parent qw(Exporter);
# chars
Readonly our $EMPTY => q{};
Readonly our $SLASH => q{/};
# booleans
Readonly our $TRUE => 1;
Readonly our $FALSE => 0;
# mocking services
Readonly our $DEFAULT_LOCAL_STACK_HOST => 'localhost:4566';
Readonly our $DEFAULT_MINIO_HOST => 'localhost:9000';
# http codes
Readonly our $HTTP_OK => '200';
Readonly our $HTTP_FORBIDDEN => '403';
Readonly our $HTTP_CONFLICT => '409';
# misc
Readonly our $TEST_BUCKET_PREFIX => 'net-amazon-s3-test';
# create a domain name for this if AMAZON_S3_DNS_BUCKET_NAMES is true
Readonly our $MOCK_SERVICES_BUCKET_NAME => $TEST_BUCKET_PREFIX . '-test';
Readonly our $PUBLIC_READ_POLICY => <
http://acs.amazonaws.com/groups/global/AllUsers
READ
END_OF_POLICY
our %EXPORT_TAGS = (
constants => [
qw(
$EMPTY
$SLASH
$TRUE
$FALSE
$DEFAULT_LOCAL_STACK_HOST
$HTTP_OK
$HTTP_CONFLICT
$HTTP_FORBIDDEN
$TEST_BUCKET_PREFIX
$MOCK_SERVICES_BUCKET_NAME
$PUBLIC_READ_POLICY
)
],
subs => [
qw(
add_keys
check_test_bucket
create_bucket
get_s3_service
is_aws
make_bucket_name
set_s3_host
)
],
);
our @EXPORT_OK = map { @{ $EXPORT_TAGS{$_} } } ( keys %EXPORT_TAGS );
########################################################################
sub make_bucket_name {
########################################################################
return $MOCK_SERVICES_BUCKET_NAME
if !is_aws();
my $suffix = eval {
require Data::UUID;
return lc Data::UUID->new->create_str();
};
$suffix //= join $EMPTY, map { ( 'A' .. 'Z', 'a' .. 'z', 0 .. 9 )[$_] }
map { int rand 62 } ( 0 .. 15 );
my $bucket_name = sprintf '%s-%s', $TEST_BUCKET_PREFIX, $suffix;
return $bucket_name;
}
########################################################################
sub is_aws {
########################################################################
return ( $ENV{AMAZON_S3_LOCALSTACK} || $ENV{AMAZON_S3_MINIO} )
? $FALSE
: $TRUE;
}
########################################################################
sub check_test_bucket {
########################################################################
my ($s3) = @_;
# list all buckets that I own
my $response = eval { return $s3->buckets; };
if ( $EVAL_ERROR || !$response ) {
diag(
Dumper( [ error => [ $response, $s3->err, $s3->errstr, $s3->error ] ] )
);
BAIL_OUT($EVAL_ERROR);
}
my ( $owner_id, $owner_displayname )
= @{$response}{qw(owner_id owner_displayname)};
my $bucket_name = make_bucket_name();
my @buckets = map { $_->{bucket} } @{ $response->{buckets} };
if ( any { $_ =~ /$bucket_name/xsm } @buckets ) {
BAIL_OUT( 'test bucket already exists: ' . $bucket_name );
}
return ( $owner_id, $owner_displayname );
}
########################################################################
sub set_s3_host {
########################################################################
my $host = $ENV{AMAZON_S3_HOST};
$host //= 's3.amazonaws.com';
## no critic (RequireLocalizedPunctuationVars)
if ( exists $ENV{AMAZON_S3_LOCALSTACK} ) {
$host //= $DEFAULT_LOCAL_STACK_HOST;
$ENV{AWS_ACCESS_KEY_ID} = 'test';
$ENV{AWS_SECRET_ACCESS_KEY} = 'test';
$ENV{AMAZON_S3_EXPENSIVE_TESTS} = $TRUE;
$ENV{AMAZON_S3_SKIP_PERMISSIONS} = $TRUE;
}
elsif ( exists $ENV{AMAZON_S3_MINIO} ) {
$host //= $DEFAULT_MINIO_HOST;
$ENV{AMAZON_S3_SKIP_ACLS} = $TRUE;
$ENV{AMAZON_S3_EXPENSIVE_TESTS} = $TRUE;
$ENV{AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST} = $TRUE;
}
return $host;
}
########################################################################
sub get_s3_service {
########################################################################
my ($host) = @_;
my $s3 = eval {
if ( $ENV{AMAZON_S3_CREDENTIALS} ) {
require Amazon::Credentials;
return Amazon::S3->new(
{ credentials => Amazon::Credentials->new,
host => $host,
secure => is_aws(),
dns_bucket_names => $ENV{AMAZON_S3_DNS_BUCKET_NAMES},
level => $ENV{DEBUG} ? 'trace' : 'error',
}
);
}
else {
return Amazon::S3->new(
{ aws_access_key_id => $ENV{AWS_ACCESS_KEY_ID},
aws_secret_access_key => $ENV{AWS_SECRET_ACCESS_KEY},
token => $ENV{AWS_SESSION_TOKEN},
host => $host,
secure => is_aws(),
dns_bucket_names => $ENV{AMAZON_S3_DNS_BUCKET_NAMES},
level => $ENV{DEBUG} ? 'trace' : 'error',
}
);
}
};
return $s3;
}
########################################################################
sub create_bucket {
########################################################################
my ( $s3, $bucket_name ) = @_;
$bucket_name = $SLASH . $bucket_name;
my $bucket_obj
= eval { return $s3->add_bucket( { bucket => $bucket_name } ); };
return $bucket_obj;
}
########################################################################
sub add_keys {
########################################################################
my ( $bucket_obj, $max_keys, $prefix ) = @_;
$prefix //= q{};
foreach my $key ( 1 .. $max_keys ) {
my $keyname = sprintf '%stesting-%02d.txt', $prefix, $key;
my $value = 'T';
$bucket_obj->add_key( $keyname, $value );
}
return $max_keys;
}
1;
Amazon-S3-0.65/META.yml 0000644 0001750 0001750 00000003141 14531467536 014316 0 ustar rclauer rclauer ---
abstract: 'Perl interface to AWS S3 API'
author:
- 'Rob Lauer '
build_requires:
Digest::MD5::File: '0.08'
ExtUtils::MakeMaker: '6.64'
File::ShareDir::Install: '0'
Test::More: '1.302190'
Test::Output: '1.033'
configure_requires:
ExtUtils::MakeMaker: '6.64'
File::ShareDir::Install: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: Amazon-S3
no_index:
directory:
- t
- inc
provides:
Amazon::S3:
file: lib/Amazon/S3.pm
version: '0.65'
Amazon::S3::Bucket:
file: lib/Amazon/S3/Bucket.pm
version: '0.65'
Amazon::S3::Constants:
file: lib/Amazon/S3/Constants.pm
version: '0.65'
Amazon::S3::Logger:
file: lib/Amazon/S3/Logger.pm
version: '0.65'
Amazon::S3::Signature::V4:
file: lib/Amazon/S3/Signature/V4.pm
version: '0'
requires:
Class::Accessor::Fast: '0'
Digest::HMAC_SHA1: '0'
Digest::MD5::File: '0'
HTTP::Date: '0'
IO::Scalar: '0'
JSON::PP: '0'
LWP: '0'
LWP::Protocol::https: '0'
LWP::UserAgent::Determined: '0'
List::Util: '1.5'
Net::Amazon::Signature::V4: '0'
Net::HTTP: '0'
Pod::Markdown: '0'
Readonly: '0'
URI: '0'
URI::Escape: '0'
XML::Simple: '0'
perl: '5.010000'
resources:
bugtracker: http://github.com/rlauer6/perl-amazon-s3/issues
homepage: http://github.com/rlauer6/perl-amazon-s3
repository: git://github.com/rlauer6/perl-amazon-s3.git
version: '0.65'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
Amazon-S3-0.65/META.json 0000644 0001750 0001750 00000005357 14531467536 014501 0 ustar rclauer rclauer {
"abstract" : "Perl interface to AWS S3 API",
"author" : [
"Rob Lauer "
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : 2
},
"name" : "Amazon-S3",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "6.64",
"File::ShareDir::Install" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "6.64",
"File::ShareDir::Install" : "0"
}
},
"runtime" : {
"requires" : {
"Class::Accessor::Fast" : "0",
"Digest::HMAC_SHA1" : "0",
"Digest::MD5::File" : "0",
"HTTP::Date" : "0",
"IO::Scalar" : "0",
"JSON::PP" : "0",
"LWP" : "0",
"LWP::Protocol::https" : "0",
"LWP::UserAgent::Determined" : "0",
"List::Util" : "1.5",
"Net::Amazon::Signature::V4" : "0",
"Net::HTTP" : "0",
"Pod::Markdown" : "0",
"Readonly" : "0",
"URI" : "0",
"URI::Escape" : "0",
"XML::Simple" : "0",
"perl" : "5.010000"
}
},
"test" : {
"requires" : {
"Digest::MD5::File" : "0.08",
"Test::More" : "1.302190",
"Test::Output" : "1.033"
}
}
},
"provides" : {
"Amazon::S3" : {
"file" : "lib/Amazon/S3.pm",
"version" : "0.65"
},
"Amazon::S3::Bucket" : {
"file" : "lib/Amazon/S3/Bucket.pm",
"version" : "0.65"
},
"Amazon::S3::Constants" : {
"file" : "lib/Amazon/S3/Constants.pm",
"version" : "0.65"
},
"Amazon::S3::Logger" : {
"file" : "lib/Amazon/S3/Logger.pm",
"version" : "0.65"
},
"Amazon::S3::Signature::V4" : {
"file" : "lib/Amazon/S3/Signature/V4.pm",
"version" : "0"
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"mailto" : "rlauer6@comcast.net",
"web" : "http://github.com/rlauer6/perl-amazon-s3/issues"
},
"homepage" : "http://github.com/rlauer6/perl-amazon-s3",
"repository" : {
"type" : "git",
"url" : "git://github.com/rlauer6/perl-amazon-s3.git",
"web" : "http://github.com/rlauer6/perl-amazon-s3"
}
},
"version" : "0.65",
"x_serialization_backend" : "JSON::PP version 4.10"
}