AWS-S3
view release on metacpan or search on metacpan
README.markdown view on Meta::CPAN
# Add a file:
my $new_file = $bucket->add_file(
key => 'foo/bar.txt',
contents => \'This is the contents of the file',
);
# You can also set the contents with a coderef:
# Coderef should eturn a reference, not the actual string of content:
$new_file = $bucket->add_file(
key => 'foo/bar.txt',
contents => sub { return \"This is the contents" }
);
# Get the file:
my $same_file = $bucket->file( 'foo/bar.txt' );
# Get the contents:
my $scalar_ref = $same_file->contents;
print $$scalar_ref;
# Update the contents with a scalar ref:
$same_file->contents( \"New file contents" );
# Update the contents with a code ref:
$same_file->contents( sub { return \"New file contents" } );
# Delete the file:
$same_file->delete();
# Iterate through lots of files:
my $iterator = $bucket->files(
page_size => 100,
page_number => 1,
);
while( my @files = $iterator->next_page )
lib/AWS/S3.pm view on Meta::CPAN
use AWS::S3::Bucket;
our $VERSION = '1.00';
has [qw/access_key_id secret_access_key/] => ( is => 'ro', isa => 'Str' );
has 'session_token' => (
is => 'ro',
isa => 'Maybe[Str]',
lazy => 1,
default => sub { $ENV{AWS_SESSION_TOKEN} },
);
has 'region' => (
is => 'ro',
isa => 'Maybe[Str]',
lazy => 1,
default => sub { $ENV{AWS_REGION} },
);
has 'secure' => (
is => 'ro',
isa => 'Bool',
lazy => 1,
default => 0
);
has 'endpoint' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my ( $s ) = @_;
if ( my $region = $s->region ) {
return "s3.$region.amazonaws.com"
} else {
return "s3.amazonaws.com"
}
},
);
has 'ua' => (
is => 'ro',
isa => 'LWP::UserAgent',
default => sub { LWP::UserAgent::Determined->new }
);
has 'honor_leading_slashes' => (
is => 'ro',
isa => 'Bool',
default => sub { 0 },
);
sub request {
my ( $s, $type, %args ) = @_;
my $class = "AWS::S3::Request::$type";
load_class( $class );
return $class->new( %args, s3 => $s, type => $type );
} # end request()
sub owner {
my $s = shift;
my $type = 'ListAllMyBuckets';
my $request = $s->request( $type );
my $response = $request->request();
my $xpc = $response->xpc;
return AWS::S3::Owner->new(
id => $xpc->findvalue( '//s3:Owner/s3:ID' ),
display_name => $xpc->findvalue( '//s3:Owner/s3:DisplayName' ),
);
} # end owner()
sub buckets {
my ( $s ) = @_;
my $type = 'ListAllMyBuckets';
my $request = $s->request( $type );
my $response = $request->request();
my $xpc = $response->xpc;
my @buckets = ();
foreach my $node ( $xpc->findnodes( './/s3:Bucket' ) ) {
push @buckets,
AWS::S3::Bucket->new(
name => $xpc->findvalue( './/s3:Name', $node ),
creation_date => $xpc->findvalue( './/s3:CreationDate', $node ),
s3 => $s,
);
} # end foreach()
return @buckets;
} # end buckets()
sub bucket {
my ( $s, $name ) = @_;
my ( $bucket ) = grep { $_->name eq $name } $s->buckets
or return;
$bucket;
} # end bucket()
sub add_bucket {
my ( $s, %args ) = @_;
my $type = 'CreateBucket';
my $request = $s->request(
$type,
bucket => $args{name},
(
$args{location} ? ( location => $args{location} )
: $s->region ? ( location => $s->region )
: ()
lib/AWS/S3.pm view on Meta::CPAN
# Add a file:
my $new_file = $bucket->add_file(
key => 'foo/bar.txt',
contents => \'This is the contents of the file',
);
# You can also set the contents with a coderef:
# Coderef should eturn a reference, not the actual string of content:
$new_file = $bucket->add_file(
key => 'foo/bar.txt',
contents => sub { return \"This is the contents" }
);
# Get the file:
my $same_file = $bucket->file( 'foo/bar.txt' );
# Get the contents:
my $scalar_ref = $same_file->contents;
print $$scalar_ref;
# Update the contents with a scalar ref:
$same_file->contents( \"New file contents" );
# Update the contents with a code ref:
$same_file->contents( sub { return \"New file contents" } );
# Delete the file:
$same_file->delete();
# Iterate through lots of files:
my $iterator = $bucket->files(
page_size => 100,
page_number => 1,
);
while( my @files = $iterator->next_page )
lib/AWS/S3/Bucket.pm view on Meta::CPAN
);
use MooseX::Types -declare => [qw/ACLShorts/];
has 'acl' => (
is => 'rw',
isa => 'Str',
required => 0,
lazy => 1,
clearer => '_clear_acl',
default => sub {
my $self = shift;
my $type = 'GetBucketAccessControl';
return $self->_get_property( $type )->response->decoded_content();
},
trigger => sub {
my ( $self, $new_val, $old_val ) = @_;
my %shorts = map { $_ => undef } qw(
private public-read public-read-write authenticated-read
);
my %acl = ();
if ( $new_val =~ m{<} ) {
$acl{acl_xml} = $new_val;
}
lib/AWS/S3/Bucket.pm view on Meta::CPAN
$self->_clear_acl;
}
);
has 'location_constraint' => (
is => 'ro',
isa => 'Str',
required => 0,
lazy => 1,
default => sub {
my $self = shift;
my $type = 'GetBucketLocationConstraint';
my $response = $self->_get_property( $type );
my $constraint = $response->xpc->findvalue( '//s3:LocationConstraint' );
if ( defined $constraint && $constraint eq '' ) {
return;
} else {
return $constraint;
}
}
);
has 'policy' => (
is => 'rw',
isa => 'Str',
required => 0,
lazy => 1,
clearer => '_clear_policy',
default => sub {
my $self = shift;
my $type = 'GetBucketPolicy';
my $req = $self->s3->request( $type, bucket => $self->name, );
my $response = $req->request();
eval { $response->_parse_errors };
if ( my $msg = $response->friendly_error() ) {
if ( $response->error_code eq 'NoSuchBucketPolicy' ) {
return '';
} else {
die $msg;
} # end if()
} # end if()
return $response->response->decoded_content();
},
trigger => sub {
my ( $self, $policy ) = @_;
my $type = 'SetBucketPolicy';
my $req = $self->s3->request(
$type,
bucket => $self->name,
policy => $policy,
);
my $response = $req->request();
lib/AWS/S3/Bucket.pm view on Meta::CPAN
if ( my $msg = $response->friendly_error() ) {
die $msg;
} # end if()
$self->_clear_policy;
}
);
# XXX: Not tested.
sub enable_cloudfront_distribution {
my ( $s, $cloudfront_dist ) = @_;
$cloudfront_dist->isa( 'AWS::CloudFront::Distribution' )
or die "Usage: enable_cloudfront_distribution( <AWS::CloudFront::Distribution object> )";
my $ident = $cloudfront_dist->cf->create_origin_access_identity( Comment => "Access to s3://" . $s->name, );
$s->policy( <<"JSON");
{
"Version":"2008-10-17",
"Id":"PolicyForCloudFrontPrivateContent",
lib/AWS/S3/Bucket.pm view on Meta::CPAN
"CanonicalUser":"@{[ $ident->S3CanonicalUserId ]}"
},
"Action": "s3:GetObject",
"Resource": "arn:aws:s3:::@{[ $s->name ]}/*"
}
]
}
JSON
} # end enable_cloudfront_distribution()
sub files {
my ( $s, %args ) = @_;
return AWS::S3::FileIterator->new( %args, bucket => $s, );
} # end files()
sub file {
my ( $s, $key ) = @_;
my $type = 'GetFileInfo';
my $parser = $s->_get_property( $type, key => $key )
or return;
my $res = $parser->response;
confess "Cannot get file: ", $res->as_string, " " unless $res->is_success;
return AWS::S3::File->new(
bucket => $s,
key => $key || undef,
size => $res->header( 'content-length' ) || 0,
contenttype => $res->header( 'content-type' ) || 'application/octet-stream',
etag => $res->header( 'etag' ) || undef,
lastmodified => $res->header( 'last-modified' ) || undef,
is_encrypted => ( $res->header( 'x-amz-server-side-encryption' ) || '' ) eq 'AES256' ? 1 : 0,
);
} # end file()
sub add_file {
my ( $s, %args ) = @_;
my $file = AWS::S3::File->new(
%args,
bucket => $s
);
$file->contents( $args{contents} );
return $file;
} # end add_file()
sub delete {
my ( $s ) = @_;
my $type = 'DeleteBucket';
my $req = $s->s3->request( $type, bucket => $s->name, );
my $response = $req->request();
if ( my $msg = $response->friendly_error() ) {
die $msg;
} # end if()
return 1;
} # end delete()
# Working as of v0.023
sub delete_multi {
my ( $s, @keys ) = @_;
die "You can only delete up to 1000 keys at once"
if @keys > 1000;
my $type = 'DeleteMulti';
my $req = $s->s3->request(
$type,
bucket => $s->name,
keys => \@keys,
);
my $response = $req->request();
if ( my $msg = $response->friendly_error() ) {
die $msg;
} # end if()
return 1;
} # end delete_multi()
sub _get_property {
my ( $s, $type, %args ) = @_;
my $req = $s->s3->request( $type, bucket => $s->name, %args );
my $response = $req->request();
return if $response->response->code == 404;
if ( my $msg = $response->friendly_error() ) {
die $msg;
} # end if()
lib/AWS/S3/File.pm view on Meta::CPAN
is => 'ro',
isa => 'AWS::S3::Bucket',
required => 1,
weak_ref => 0,
);
has 'size' => (
is => 'ro',
isa => 'Int',
required => 0,
default => sub {
my $self = shift;
return length ${$self->contents};
}
);
has 'etag' => (
is => 'ro',
isa => 'Str',
required => 0,
);
lib/AWS/S3/File.pm view on Meta::CPAN
isa => 'Str',
required => 0,
default => 'binary/octet-stream'
);
has 'is_encrypted' => (
is => 'rw',
isa => 'Bool',
required => 1,
lazy => 1,
default => sub {
my $s = shift;
my $type = 'GetFileInfo';
my $req = $s->bucket->s3->request(
$type,
bucket => $s->bucket->name,
key => $s->key,
);
return $req->request->response->header( 'x-amz-server-side-encryption' ) ? 1 : 0;
lib/AWS/S3/File.pm view on Meta::CPAN
has 'contents' => (
is => 'rw',
isa => fileContents,
required => 0,
lazy => 1,
coerce => 1,
default => \&_get_contents,
trigger => \&_set_contents
);
sub BUILD {
my $s = shift;
return unless $s->etag;
( my $etag = $s->etag ) =~ s{^"}{};
$etag =~ s{"$}{};
$s->{etag} = $etag;
} # end BUILD()
sub update {
my $s = shift;
my %args = @_;
my @args_ok = grep { /^content(?:s|type)$/ } keys %args;
if ( @args_ok ) {
$s->{$_} = $args{$_} for @args_ok;
$s->_set_contents();
return 1;
}
return;
} # end update()
sub _get_contents {
my $s = shift;
my $type = 'GetFileContents';
my $req = $s->bucket->s3->request(
$type,
bucket => $s->bucket->name,
key => $s->key,
);
return \$req->request->response->decoded_content;
} # end contents()
sub _set_contents {
my ( $s, $ref ) = @_;
my $type = 'SetFileContents';
my %args = ();
my $response = $s->bucket->s3->request(
$type,
bucket => $s->bucket->name,
file => $s,
contents => $ref,
content_type => $s->contenttype,
lib/AWS/S3/File.pm view on Meta::CPAN
( my $etag = $response->response->header( 'etag' ) ) =~ s{^"}{};
$etag =~ s{"$}{};
$s->{etag} = $etag;
if ( my $msg = $response->friendly_error() ) {
die $msg;
} # end if()
} # end _set_contents()
sub signed_url {
my $s = shift;
my $expires = shift || 3600;
# expiry for v4 signature is in seconds, not epoch time
if ( $expires > time ) {
$expires -= time;
}
my $key = $s->key;
lib/AWS/S3/File.pm view on Meta::CPAN
my $uri = $s->bucket->s3->request(
$type,
bucket => $s->bucket->name,
key => $key,
expires => $expires,
)->request;
return $uri;
}
sub delete {
my $s = shift;
my $type = 'DeleteFile';
my $req = $s->bucket->s3->request(
$type,
bucket => $s->bucket->name,
key => $s->key,
);
my $response = $req->request();
lib/AWS/S3/File.pm view on Meta::CPAN
print $file->owner->display_name;
print $file->bucket->name;
# Set the contents with a scalarref:
my $new_contents = "This is the new contents of the file.";
$file->contents( \$new_contents );
# Set the contents with a coderef:
$file->contents( sub {
return \$new_contents;
});
# Alternative update
$file->update(
contents => \'New contents', # optional
contenttype => 'text/plain' # optional
);
# Get signed URL for the file for public access
lib/AWS/S3/File.pm view on Meta::CPAN
Returns a scalar-reference of the file's contents.
Accepts either a scalar-ref or a code-ref (which would return a scalar-ref).
Once given a new value, the file is instantly updated on Amazon S3.
# GOOD: (uses scalarrefs)
my $value = "A string";
$file->contents( \$value );
$file->contents( sub { return \$value } );
# BAD: (not scalarrefs)
$file->contents( $value );
$file->contents( sub { return $value } );
=head1 PUBLIC METHODS
=head2 delete()
Deletes the file from Amazon S3.
=head2 update()
Update contents and/or contenttype of the file.
lib/AWS/S3/FileIterator.pm view on Meta::CPAN
package AWS::S3::FileIterator;
use strict;
use warnings 'all';
use Carp 'confess';
use AWS::S3::Owner;
use AWS::S3::File;
sub new {
my ($class, %args) = @_;
my $s = bless {
data => [ ],
page_number => 0,
idx => 0,
%args,
}, $class;
$s->_init;
return $s;
}
sub _init {
my ( $s ) = @_;
foreach ( qw( bucket page_size page_number ) ) {
confess "Required argument '$_' was not provided"
unless $s->{$_};
} # end foreach()
$s->{page_number}--;
$s->{marker} = '' unless defined( $s->{marker} );
$s->{__fetched_first_page} = 0;
$s->{data} = [];
$s->{pattern} ||= qr(.*);
} # end _init()
sub marker { shift->{marker} }
sub pattern { shift->{pattern} }
sub bucket { shift->{bucket} }
sub page_size { shift->{page_size} }
sub prefix { shift->{prefix} }
sub has_prev {
my $s = shift;
return $s->page_number > 1;
} # end has_prev()
sub has_next { shift->{has_next} }
sub next {
my $s = shift;
if( exists( $s->{data}->[ $s->{idx} ] ) ) {
return $s->{data}->[ $s->{idx}++ ];
} else {
# End of the current resultset, see if we can get another page of records:
if( my $page = $s->next_page ) {
$s->{data} = $page;
$s->{idx} = 0;
return $s->{data}->[ $s->{idx}++ ];
} else {
# No more pages, no more data:
return;
}
}
}
sub reset {
my $s = shift;
$s->{idx} = 0;
}
sub page_number {
my $s = shift;
@_ ? $s->{page_number} = $_[0] - 1 : $s->{page_number};
} # end page_number()
# S3 returns files 100 at a time. If we want more or less than 100, we can't
# just fetch the next page over and over - that would be inefficient and likely
# to cause errors.
# If the page size is 5 and page number is 2, then we:
# - fetch 100 items
lib/AWS/S3/FileIterator.pm view on Meta::CPAN
# - iterate internally until we get to 'page 2'
# - return the result.
# If the page size is 105 and page number is 1, then we:
# - fetch 100 items
# - fetch the next 100 items
# - return the first 105 items, keeping the remaining 95 items
# - on page '2', fetch the next 100 items and return 105 items, saving 90 items.
# If the page size is 105 and page number is 3, then we:
# - fetch items until our internal 'start' marker is 316-420
# - return items 316-420
sub next_page {
my $s = shift;
# Advance to page X before proceding:
if ( ( !$s->{__fetched_first_page}++ ) && $s->page_number ) {
# Advance to $s->page_number
my $start_page = $s->page_number;
my $to_discard = $start_page * $s->page_size;
my $discarded = 0;
while ( 1 ) {
lib/AWS/S3/FileIterator.pm view on Meta::CPAN
delete $_->{owner};
AWS::S3::File->new( %$_, owner => $owner );
} @chunk;
$s->{page_number}++;
return unless @out;
wantarray ? @out : \@out;
} # end next_page()
sub _next {
my $s = shift;
if ( my $item = shift( @{ $s->{data} } ) ) {
return $item;
} else {
if ( my @chunk = $s->_fetch() ) {
push @{ $s->{data} }, @chunk;
return shift( @{ $s->{data} } );
} else {
return;
} # end if()
} # end if()
} # end _next()
sub _fetch {
my ( $s ) = @_;
my $path = $s->{bucket}->name . '/';
my %params = ();
$params{marker} = $s->{marker} if $s->{marker};
$params{prefix} = $s->{prefix} if $s->{prefix};
$params{max_keys} = 1000;
$params{delimiter} = $s->{delimiter} if $s->{delimiter};
my $type = 'ListBucket';
lib/AWS/S3/HTTPRequest.pm view on Meta::CPAN
coerce 'HTTP::Headers'
=> from 'HashRef'
=> via { my $h = HTTP::Headers->new( %$_ ) };
has 'headers' => (
is => 'ro',
required => 1,
isa => 'HTTP::Headers',
lazy => 1,
default => sub { HTTP::Headers->new() },
coerce => 1,
);
has 'content' => (
is => 'ro',
required => 1,
isa => 'Str|ScalarRef|CodeRef',
default => '',
);
has 'metadata' => (
is => 'ro',
required => 1,
isa => 'HashRef',
default => sub { {} },
);
has 'contenttype' => (
is => 'ro',
required => 0,
isa => 'Str',
);
# Make the HTTP::Request object:
sub http_request {
my $s = shift;
my $method = $s->method;
my $headers = $s->headers;
my $content = $s->content;
my $metadata = $s->metadata;
my $uri = $s->bucket_uri( $s->path );
my $signer = AWS::S3::Signer->new(
s3 => $s->s3,
lib/AWS/S3/Request/CreateBucket.pm view on Meta::CPAN
is => 'ro',
isa => 'Str',
required => 1,
);
has 'location' => (
is => 'ro',
isa => 'Maybe[Str]',
lazy => 1,
required => 0,
default => sub { shift->s3->region || $ENV{AWS_REGION} },
);
has '+_expect_nothing' => ( default => 1 );
sub request {
my $s = shift;
# By default the bucket is put in us-east-1. But if you _ask_ for
# us-east-1 you get an error.
my $xml = q{};
if ( $s->location && $s->location ne 'us-east-1' ) {
$xml = <<"XML";
<CreateBucketConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
<LocationConstraint>@{[ $s->location ]}</LocationConstraint>
</CreateBucketConfiguration>
lib/AWS/S3/Request/DeleteMulti.pm view on Meta::CPAN
is => 'ro',
isa => 'Str',
init_arg => undef,
default => 'delete'
);
has '+_expect_nothing' => ( default => 0 );
sub request {
my $s = shift;
my $objects = join "\n", map { "<Object><Key>@{[ $_ ]}</Key></Object>" } @{ $s->keys };
my $xml = <<"XML";
<?xml version="1.0" encoding="UTF-8"?>
<Delete>
$objects
</Delete>
XML
lib/AWS/S3/Request/GetPreSignedUrl.pm view on Meta::CPAN
use AWS::S3::Signer;
use URI::Escape qw(uri_escape);
with 'AWS::S3::Roles::Request';
has 'bucket' => ( is => 'ro', isa => 'Str', required => 1 );
has 'key' => ( is => 'ro', isa => 'Str', required => 1 );
has 'expires' => ( is => 'ro', isa => 'Int', required => 1 );
sub request {
my $s = shift;
return $s->signerv4->signed_url(
$s->_uri,
$s->expires,
'GET',
);
}
__PACKAGE__->meta->make_immutable;
lib/AWS/S3/Request/ListBucket.pm view on Meta::CPAN
);
has 'delimiter' => (
is => 'ro',
isa => 'Str',
required => 0,
);
has '+_expect_nothing' => ( default => 0 );
sub request {
my $s = shift;
my @params = ();
push @params, 'max-keys=' . $s->max_keys;
push @params, 'marker=' . uri_escape( $s->marker ) if $s->marker;
push @params, 'prefix=' . $s->prefix if $s->prefix;
push @params, 'delimiter=' . $s->delimiter if $s->delimiter;
my $uri = $s->bucket_uri;
lib/AWS/S3/Request/SetBucketAccessControl.pm view on Meta::CPAN
);
has 'acl_xml' => (
is => 'ro',
isa => 'Str',
required => 0,
);
has '+_expect_nothing' => ( default => 1 );
sub request {
my $s = shift;
if ( $s->acl_short ) {
my $signer = AWS::S3::Signer->new(
s3 => $s->s3,
method => 'PUT',
uri => $s->protocol . '://' . $s->bucket . '.' . $s->endpoint . '/?acl',
headers => [ 'x-amz-acl' => $s->acl_short ]
);
return $s->_send_request(
lib/AWS/S3/Request/SetBucketPolicy.pm view on Meta::CPAN
);
has 'policy' => (
is => 'ro',
isa => 'Maybe[Str]',
required => 1,
# Evan Carroll 6/14/2012
# COMMENTED THIS OUT, not sure if it ever worked on VSO
# Must be able to decode the JSON string:
# where => sub {
# eval { decode_json( $_ ); 1 };
# }
);
has '+_expect_nothing' => ( default => 1 );
sub request {
my $s = shift;
my $signer = AWS::S3::Signer->new(
s3 => $s->s3,
method => 'PUT',
uri => $s->_uri,
content => \$s->policy,
content_type => '',
content_md5 => '',
);
lib/AWS/S3/Request/SetFileContents.pm view on Meta::CPAN
is => 'ro',
isa => 'AWS::S3::File',
required => 1,
);
has 'content_type' => (
is => 'ro',
isa => 'Str',
required => 1,
lazy => 1,
default => sub { 'binary/octet-stream' },
);
has '+_expect_nothing' => ( default => 0 );
sub request {
my $s = shift;
my $contents;
if ( ref( $s->file->contents ) eq 'CODE' ) {
$contents = $s->file->contents->();
} elsif ( ref( $s->file->contents ) eq 'SCALAR' ) {
$contents = $s->file->contents;
} # end if()
my %other_args = ();
lib/AWS/S3/ResponseParser.pm view on Meta::CPAN
use Moose;
use XML::LibXML;
use XML::LibXML::XPathContext;
has 'expect_nothing' => (
is => 'ro',
isa => 'Bool',
required => 1,
default => 0,
trigger => sub {
my ( $self, $expect_nothing) = @_;
if ( $expect_nothing ) {
my $code = $self->response->code;
if ( $code =~ m{^2\d\d} && !$self->response->content ) {
return; # not sure what jdrago wanted this to do originally
}
else {
if ( $self->_parse_errors() ) {
# die $self->friendly_error();
}
lib/AWS/S3/ResponseParser.pm view on Meta::CPAN
has 'type' => (
is => 'ro',
isa => 'Str',
required => 1,
);
has 'libxml' => (
is => 'ro',
isa => 'XML::LibXML',
required => 1,
default => sub { return XML::LibXML->new() },
);
has 'error_code' => (
is => 'rw',
isa => 'Str',
required => 0,
);
has 'error_message' => (
is => 'rw',
isa => 'Str',
required => 0,
);
has 'xpc' => (
is => 'ro',
isa => 'XML::LibXML::XPathContext',
required => 0,
lazy => 1,
clearer => '_clear_xpc',
default => sub {
my $self = shift;
my $src = $self->response->content;
return unless $src =~ m/^[[:space:]]*</s;
my $doc = $self->libxml->parse_string( $src );
my $xpc = XML::LibXML::XPathContext->new( $doc );
$xpc->registerNs( 's3', 'http://s3.amazonaws.com/doc/2006-03-01/' );
return $xpc;
}
);
has 'friendly_error' => (
is => 'ro',
isa => 'Maybe[Str]',
lazy => 1,
required => 0,
default => sub {
my $s = shift;
return unless $s->error_code || $s->error_message;
$s->type . " call had errors: [" . $s->error_code . "] " . $s->error_message;
}
);
sub _parse_errors {
my $self = shift;
my $src = $self->response->content;
# Do not try to parse non-xml:
unless ( $src =~ m/^[[:space:]]*</s ) {
( my $code = $src ) =~ s/^[[:space:]]*\([0-9]*\).*$/$1/s;
$self->error_code( $code );
$self->error_message( $src );
return 1;
lib/AWS/S3/Roles/Bucket.pm view on Meta::CPAN
package AWS::S3::Roles::Bucket;
use Moose::Role;
sub bucket_uri {
my ( $s,$path ) = @_;
$path //= $s->bucket;
my $protocol = $s->s3->secure ? 'https' : 'http';
my $endpoint = $s->s3->endpoint;
my $uri = "$protocol://$endpoint/$path";
if ( $path =~ m{^([^/?]+)(.*)} && $s->is_dns_bucket( $1 ) ) {
$uri = "$protocol://$1.$endpoint$2";
} # end if()
return $uri;
}
sub is_dns_bucket {
my ( $s,$bucket ) = @_;
# https://docs.aws.amazon.com/AmazonS3/latest/dev/BucketRestrictions.html
return 0 if ( length( $bucket ) < 3 or length( $bucket ) > 63 );
return 0 if $bucket =~ /^(?:\d{1,3}\.){3}\d{1,3}$/;
# DNS bucket names can contain lowercase letters, numbers, and hyphens
# so anything outside this range we say isn't a valid DNS bucket
return $bucket =~ /[^a-z0-9-\.]/ ? 0 : 1;
}
lib/AWS/S3/Roles/BucketAction.pm view on Meta::CPAN
package AWS::S3::Roles::BucketAction;
use Moose::Role;
use HTTP::Request;
use AWS::S3::ResponseParser;
with 'AWS::S3::Roles::Request';
sub request {
my $s = shift;
my $signer = AWS::S3::Signer->new(
s3 => $s->s3,
method => $s->_action,
uri => $s->_uri
);
$s->_send_request(
$signer->method => $signer->uri => {
Authorization => $signer->auth_header,
lib/AWS/S3/Roles/Request.pm view on Meta::CPAN
has 'type' => (
is => 'ro',
isa => 'Str',
required => 1,
);
has 'protocol' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
shift->s3->secure ? 'https' : 'http';
}
);
has 'endpoint' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
shift->s3->endpoint;
}
);
# XXX should be required=>1; https://rt.cpan.org/Ticket/Display.html?id=77863
has "_action" => (
isa => 'Str',
is => 'ro',
init_arg => undef,
#required => 1
);
has '_expect_nothing' => ( isa => 'Bool', is => 'ro', init_arg => undef );
has '_uri' => (
isa => Uri,
is => 'ro',
lazy => 1,
default => sub {
my $self = shift;
my $m = $self->meta;
my $uri = URI->new(
$self->protocol . '://'
. ( $m->has_attribute('bucket') ? $self->bucket . '.' : '' )
. $self->endpoint
. '/'
);
lib/AWS/S3/Roles/Request.pm view on Meta::CPAN
if $m->has_attribute('_subresource');
$uri;
}
);
has 'signerv4' => (
is => 'ro',
isa => 'AWS::S3::Signer::V4',
lazy => 1,
default => sub {
my $s = shift;
AWS::S3::Signer::V4->new(
-access_key => $s->s3->access_key_id,
-secret_key => $s->s3->secret_access_key,
);
}
);
sub _send_request {
my ( $s, $method, $uri, $headers, $content ) = @_;
my $req = HTTP::Request->new( $method => $uri );
$req->content( $content ) if $content;
delete($headers->{Authorization}); # we will use a v4 signature
map { $req->header( $_ => $headers->{$_} ) } keys %$headers;
$s->_sign($req);
my $res = $s->s3->ua->request( $req );
# After creating a bucket and setting its location constraint, we get this
# strange 'TemporaryRedirect' response. Deal with it.
if ( $res->header( 'location' ) && $res->content =~ m{>TemporaryRedirect<}s ) {
$req->uri( $res->header( 'location' ) );
$res = $s->s3->ua->request( $req );
}
return $s->parse_response( $res );
}
sub _sign {
my ($s, $request) = @_;
my $signer = $s->signerv4;
if (defined $s->s3->session_token) {
$request->header('X-Amz-Security-Token', $s->s3->session_token);
}
my $digest = Digest::SHA::sha256_hex($request->content);
$request->header('X-Amz-Content-SHA256', $digest);
$signer->sign($request, $s->s3->region, $digest);
$request;
}
sub parse_response {
my ( $self, $res ) = @_;
AWS::S3::ResponseParser->new(
response => $res,
expect_nothing => $self->_expect_nothing,
type => $self->type,
);
}
1;
lib/AWS/S3/Signer.pm view on Meta::CPAN
is => 'ro',
isa => enum([qw/ HEAD GET PUT POST DELETE /]),
required => 1,
);
has 'bucket_name' => (
is => 'ro',
isa => 'Str',
required => 1,
lazy => 1,
default => sub {
my $s = shift;
my $endpoint = $s->s3->endpoint;
if ( my ( $name ) = $s->uri->host =~ m{^(.+?)\.\Q$endpoint\E} ) {
return $name;
} else {
return '';
} # end if()
}
);
lib/AWS/S3/Signer.pm view on Meta::CPAN
is => 'ro',
isa => Uri,
required => 1,
coerce => 1,
);
has 'headers' => (
is => 'ro',
isa => 'ArrayRef[Str]',
lazy => 1,
default => sub { [] },
);
has 'date' => (
is => 'ro',
isa => 'Str',
default => sub {
time2str( time );
}
);
has 'string_to_sign' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my $s = shift;
join "\n",
(
$s->method, $s->content_md5,
$s->content ? $s->content_type : '',
$s->date || '',
( join "\n", grep { $_ } ( $s->canonicalized_amz_headers, $s->canonicalized_resource ) )
);
}
);
has 'canonicalized_amz_headers' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my $s = shift;
my @h = @{ $s->headers };
my %out = ();
while ( my ( $k, $v ) = splice( @h, 0, 2 ) ) {
$k = lc( $k );
if ( exists $out{$k} ) {
$out{$k} = [ $out{$k} ] unless ref( $out{$k} );
push @{ $out{$k} }, $v;
} else {
lib/AWS/S3/Signer.pm view on Meta::CPAN
} # end while()
return join "\n", @parts;
}
);
has 'canonicalized_resource' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my $s = shift;
my $str = $s->bucket_name ? '/' . $s->bucket_name . $s->uri->path : $s->uri->path;
if ( my ( $resource ) =
( $s->uri->query || '' ) =~ m{[&]*(acl|website|location|policy|delete|lifecycle)(?!\=)} )
{
$str .= '?' . $resource;
} # end if()
return $str;
}
);
has 'content_type' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my $s = shift;
return '' if $s->method eq 'GET';
return '' unless $s->content;
return 'text/plain';
}
);
has 'content_md5' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my $s = shift;
return '' unless $s->content;
return encode_base64( md5( ${ $s->content } ), '' );
}
);
has 'content' => (
is => 'ro',
isa => 'Maybe[ScalarRef]',
);
has 'content_length' => (
is => 'ro',
isa => 'Int',
lazy => 1,
default => sub { length( ${ shift->content } ) }
);
has 'signature' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my $s = shift;
my $hmac = Digest::HMAC_SHA1->new( $s->s3->secret_access_key );
$hmac->add( $s->string_to_sign() );
return encode_base64( $hmac->digest, '' );
}
);
sub auth_header {
my $s = shift;
return 'AWS ' . $s->s3->access_key_id . ':' . $s->signature;
} # end auth_header()
sub _trim {
my ( $value ) = @_;
$value =~ s/^\s+//;
$value =~ s/\s+$//;
return $value;
} # end _trim()
1;
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
If the environment variables EC2_ACCESS_KEY and/or EC2_SECRET_KEY are
set, their contents are used as defaults for -access_key and
-secret_key.
If -service and/or -region is not provided, they are automtically determined
according to endpoint.
=cut
sub new {
my $self = shift;
my %args = @_;
my ( $id, $secret, $token, $region, $service );
if ( ref $args{-security_token}
&& $args{-security_token}->can('access_key_id') )
{
$id = $args{-security_token}->accessKeyId;
$secret = $args{-security_token}->secretAccessKey;
}
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
service => $args{-service},
(
defined( $args{-security_token} )
? ( security_token => $args{-security_token} )
: ()
),
},
ref $self || $self;
}
sub access_key { shift->{access_key} }
sub secret_key { shift->{secret_key} }
=item $signer->sign($request [,$region] [,$payload_sha256_hex])
Given an HTTP::Request object, add the headers required by AWS and
then sign it with a version 4 signature by adding an "Authorization"
header.
The request must include a URL from which the AWS endpoint and service
can be derived, such as "ec2.us-east-1.amazonaws.com." In some cases
(e.g. S3 bucket operations) the endpoint does not indicate the
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
The method returns a true value if successful. On errors, it will
throw an exception.
=item $url = $signer->signed_url($request)
This method will generate a signed GET URL for the request. The URL
will include everything needed to perform the request.
=cut
sub sign {
my $self = shift;
my ( $request, $region, $payload_sha256_hex ) = @_;
$self->_add_date_header($request);
$self->_sign( $request, $region, $payload_sha256_hex );
}
=item my $url $signer->signed_url($request_or_uri [,$expires] [,$verb])
Pass an HTTP::Request, a URI object, or just a plain URL string
containing the proper endpoint and parameters needed for an AWS REST
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
e.g., accessing an object in a private S3 bucket.
Pass an optional $expires argument to indicate that the URL will only
be valid for a finite period of time. The value of the argument is in
seconds.
Pass an optional verb which is useful for HEAD requests, this defaults to GET.
=cut
sub signed_url {
my $self = shift;
my ( $arg1, $expires, $verb ) = @_;
my ( $request, $uri );
$verb ||= 'GET';
$verb = uc($verb);
my $incorrect_verbs = {
POST => 1,
PUT => 1
};
if ( exists( $incorrect_verbs->{$verb} ) ) {
die "Use AWS::S3::Signer::V4->sign sub for $verb method";
}
if ( ref $arg1 && UNIVERSAL::isa( $arg1, 'HTTP::Request' ) ) {
$request = $arg1;
$uri = $request->uri;
my $content = $request->content;
$uri->query($content) if $content;
if ( my $date =
$request->header('X-Amz-Date') || $request->header('Date') )
{
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
$self->_sign($request);
}
my ( $algorithm, $credential, $signedheaders, $signature ) =
$request->header('Authorization') =~
/^(\S+) Credential=(\S+), SignedHeaders=(\S+), Signature=(\S+)/;
$uri->query_param_append( 'X-Amz-Signature' => $signature );
return $uri;
}
sub _add_date_header {
my $self = shift;
my $request = shift;
my $datetime;
unless ( $datetime = $request->header('x-amz-date') ) {
$datetime = $self->_zulu_time($request);
$request->header( 'x-amz-date' => $datetime );
}
}
sub _scope {
my $self = shift;
my ( $request, $region ) = @_;
my $host = $request->uri->host;
my $datetime = $self->_datetime($request);
my ($date) = $datetime =~ /^(\d+)T/;
my $service;
( $service, $region ) = $self->parse_host( $host, $region );
$service ||= $self->{service} || 's3';
$region ||= $self->{region} || 'us-east-1'; # default
return "$date/$region/$service/aws4_request";
}
sub parse_host {
my $self = shift;
my $host = shift;
my $region = shift;
# this entire thing should probably refactored into its own
# distribution, a la https://github.com/zirkelc/amazon-s3-url
# https://docs.aws.amazon.com/prescriptive-guidance/latest/defining-bucket-names-data-lakes/faq.html
# Only lowercase letters, numbers, dashes, and dots are allowed in S3 bucket names.
# Bucket names must be three to 63 characters in length,
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
$url_style = 'legacy path-style';
}
elsif ( exists PAAPI_REGION->{$host} ) {
$service = 'ProductAdvertisingAPI';
$region = PAAPI_REGION->{$host};
}
return ( $service, $region, $url_style );
}
sub _parse_scope {
my $self = shift;
my $scope = shift;
return split '/', $scope;
}
sub _datetime {
my $self = shift;
my $request = shift;
return $request->header('x-amz-date') || $self->_zulu_time($request);
}
sub _algorithm { return 'AWS4-HMAC-SHA256' }
sub _sign {
my $self = shift;
my ( $request, $region, $payload_sha256_hex ) = @_;
return if $request->header('Authorization'); # don't overwrite
my $datetime = $self->_datetime($request);
unless ( $request->header('host') ) {
my $host = $request->uri->host;
$request->header( host => $host );
}
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
my $string_to_sign =
$self->_string_to_sign( $datetime, $scope, $hashed_request );
my $signature =
$self->_calculate_signature( $secret_key, $service, $region, $date,
$string_to_sign );
$request->header( Authorization =>
"$algorithm Credential=$access_key/$scope, SignedHeaders=$signed_headers, Signature=$signature"
);
}
sub _zulu_time {
my $self = shift;
my $request = shift;
my $date = $request->header('Date');
my @datetime = $date ? gmtime( str2time($date) ) : gmtime();
return strftime( '%Y%m%dT%H%M%SZ', @datetime );
}
sub _hash_canonical_request {
my $self = shift;
my ( $request, $hashed_payload ) =
@_; # (HTTP::Request,sha256_hex($content))
my $method = $request->method;
my $uri = $request->uri;
my $path = $uri->path || '/';
my @params = $uri->query_form;
my $headers = $request->headers;
$hashed_payload ||= sha256_hex( $request->content );
lib/AWS/S3/Signer/V4.pm view on Meta::CPAN
my $signed_headers = join ';', sort map { lc } keys %signed_fields;
my $canonical_request = join( "\n",
$method, $path, $canonical_query_string,
$canonical_headers, $signed_headers, $hashed_payload );
my $request_digest = sha256_hex($canonical_request);
return ( $request_digest, $signed_headers );
}
sub _string_to_sign {
my $self = shift;
my ( $datetime, $credential_scope, $hashed_request ) = @_;
return join( "\n",
'AWS4-HMAC-SHA256', $datetime, $credential_scope, $hashed_request );
}
=item $signing_key = AWS::S3::Signer::V4->signing_key($secret_access_key,$service_name,$region,$date)
Return just the signing key in the event you wish to roll your own signature.
=cut
sub signing_key {
my $self = shift;
my ( $kSecret, $service, $region, $date ) = @_;
my $kDate = hmac_sha256( $date, 'AWS4' . $kSecret );
my $kRegion = hmac_sha256( $region, $kDate );
my $kService = hmac_sha256( $service, $kRegion );
my $kSigning = hmac_sha256( 'aws4_request', $kService );
return $kSigning;
}
sub _calculate_signature {
my $self = shift;
my ( $kSecret, $service, $region, $date, $string_to_sign ) = @_;
my $kSigning = $self->signing_key( $kSecret, $service, $region, $date );
return hmac_sha256_hex( $string_to_sign, $kSigning );
}
1;
=back
t/001_compiles_pod.t view on Meta::CPAN
use warnings;
use Test::More;
use File::Find;
use Moose;
if(($ENV{HARNESS_PERL_SWITCHES} || '') =~ /Devel::Cover/) {
plan skip_all => 'HARNESS_PERL_SWITCHES =~ /Devel::Cover/';
}
if(!eval 'use Test::Pod; 1') {
*Test::Pod::pod_file_ok = sub { SKIP: { skip "pod_file_ok(@_) (Test::Pod is required)", 1 } };
}
if(!eval 'use Test::Pod::Coverage; 1') {
*Test::Pod::Coverage::pod_coverage_ok = sub { SKIP: { skip "pod_coverage_ok(@_) (Test::Pod::Coverage is required)", 1 } };
}
my @files;
find(
{
wanted => sub { /\.pm$/ and push @files, $File::Find::name },
no_chdir => 1
},
-e 'blib' ? 'blib' : 'lib',
);
plan tests => @files * 3;
for my $file (@files) {
my $module = $file; $module =~ s,\.pm$,,; $module =~ s,.*/?lib/,,; $module =~ s,/,::,g;
ok eval "use $module; 1", "use $module" or diag $@;
t/010_basic.t view on Meta::CPAN
GET_FILE: {
ok my $file = $bucket->file($filename), 'bucket.file(filename) works';
is ${ $file->contents }, $test_str, 'file.contents is correct';
};
ADD_FILE_WITH_CODE: {
my $text = "This is the content"x4;
ok $bucket->add_file(
key => 'code/test.txt',
contents => sub { return \$text }
), 'add file with code contents worked';
ok my $file = $bucket->file('code/test.txt'), "got file back from bucket";
is ${$file->contents}, $text, "file.contents on code is correct";
$file->contents( sub { return \uc($text) } );
is ${$file->contents}, uc($text), "file.contents on code is correct after update";
$file->delete;
};
# Set contents:
SET_CONTENTS: {
my $new_contents = "This is the updated value"x10;
ok my $file = $bucket->file($filename), 'bucket.file(filename) works';
$file->contents( \$new_contents );
t/010_basic.t view on Meta::CPAN
}
};
# Cleanup:
ok $bucket->delete, 'bucket.delete succeeds when bucket IS empty.';
}# end if()
cleanup();
done_testing();
sub cleanup
{
warn "\nCleaning Up...\n";
foreach my $bucket ( grep { $_->name =~ m{^(aws-s3-test\-\d+).+?foo$} } $s3->buckets )
{
warn "Bucket: ", $bucket->name, "\n";
my $iter = $bucket->files( page_size => 100, page_number => 1 );
while( my @files = $iter->next_page )
{
$bucket->delete_multi( map { $_->key } @files );
# foreach my $file ( @files )
#!perl
use strict;
use warnings;
package Mocked::HTTP::Response;
use Moose;
extends 'HTTP::Response';
sub content { return shift->{_msg}; }
1;
package main;
use Test::More 'no_plan';
use Test::Deep;
use Test::Exception;
use Data::Section::Simple 'get_data_section';
$@,
qr/Can't connect to aws-s3-test-.*?bad\.hostname/,
'endpoint was used'
);
isa_ok(
$s3->request( 'CreateBucket',bucket => 'foo' ),
'AWS::S3::Request::CreateBucket'
);
subtest 'create bucket strange temporary redirect' => sub {
plan tests => 8; # make sure all tests in here get run
my $i = 1;
local *LWP::UserAgent::Determined::request = sub {
my ( undef, $req ) = @_;
if ( $i == 1 ) {
# first PUT request, send a forward
is( $req->method, 'PUT', 'bucket creation with PUT request' );
is( $req->uri->as_string, 'http://bar.bad.hostname./', '... and with correct URI' );
$i++;
return HTTP::Response->new(
};
my $bucket = $s3->add_bucket( name => 'bar' );
isa_ok( $bucket, 'AWS::S3::Bucket' );
is( $bucket->name, 'bar', '... and the right bucket got returned' );
};
# list all buckets and owner
{
my $xml = get_data_section('ListAllMyBucketsResult.xml');
local *LWP::UserAgent::Determined::request = sub {
return Mocked::HTTP::Response->new( 200,$xml );
};
isa_ok( my $owner = $s3->owner,'AWS::S3::Owner' );
is( $owner->id, 'bcaf1ffd86f41161ca5fb16fd081034f', '... and the owner id correct' );
is( $owner->display_name, 'webfile', '... and the owner name is correct' );
my @buckets = $s3->buckets;
cmp_deeply( \@buckets,
[ obj_isa('AWS::S3::Bucket'), obj_isa('AWS::S3::Bucket') ], '->buckets' );
ok( ! $s3->bucket( 'does not exist' ),'!->bucket' );
is( $s3->bucket( 'foo' )->name, 'foo', '->bucket' );
}
{
my $xml = get_data_section('error.xml');
local *LWP::UserAgent::Determined::request = sub {
return Mocked::HTTP::Response->new( 400,$xml );
};
throws_ok { $s3->add_bucket( name => 'too many buckets', location => 'us-west-1' ) }
qr/TooManyBuckets/, 'add_bucket throws an error';
}
__DATA__
@@ ListAllMyBucketsResult.xml
<?xml version="1.0" encoding="UTF-8"?>
<ListAllMyBucketsResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
t/aws/s3/bucket.t view on Meta::CPAN
#!perl
use strict;
use warnings;
package Mocked::HTTP::Response;
use Moose;
extends 'HTTP::Response';
sub content { shift->{_msg}; }
sub code { 200 }
sub is_success { 1 }
sub header { $_[1] =~ /content-length/i ? 1 : 'header' }
1;
package main;
use Test::More;
use Test::Exception;
use FindBin qw/ $Script /;
use Carp 'confess';
$SIG{__DIE__} = \&confess;
t/aws/s3/bucket.t view on Meta::CPAN
isa_ok(
$bucket->files(
page_size => 1,
page_number => 1,
),
'AWS::S3::FileIterator'
);
no warnings 'once';
my $mocked_response = Mocked::HTTP::Response->new( 200,'bar' );
*LWP::UserAgent::Determined::request = sub { $mocked_response };
isa_ok( $bucket->file( 'foo' ),'AWS::S3::File' );
isa_ok(
$bucket->add_file(
key => 'foo',
size => 1,
contents => \"bar",
),
'AWS::S3::File'
);
t/aws/s3/file.t view on Meta::CPAN
#!perl
use strict;
use warnings;
package Mocked::HTTP::Response;
use Moose;
extends 'HTTP::Response';
sub content { shift->{_msg}; }
sub code { 200 }
sub is_success { 1 }
sub header { $_[1] =~ /content-length/i ? 1 : 'header' }
1;
package main;
use Test::More;
use Test::Deep;
use URI::Escape qw/ uri_escape /;
use Carp 'confess';
t/aws/s3/file.t view on Meta::CPAN
use_ok('AWS::S3::Request::SetFileContents');
monkey_patch_module();
my $path = '/path/to/';
my $key = $ENV{AWS_TEST_KEY} // "my+image.jpg";
isa_ok(
my $file = AWS::S3::File->new(
key => $path . $key,
contents => sub { 'test file contents' },
is_encrypted => 0,
bucket => AWS::S3::Bucket->new(
s3 => $s3,
name => $ENV{AWS_TEST_BUCKET} // 'maibucket',
),
),
'AWS::S3::File'
);
can_ok(
t/aws/s3/file.t view on Meta::CPAN
ok( $file->update( contents => \'new contents' ),'update with args' );
like(
$file->signed_url( 1406712744 ),
qr/X-Amz-Algorithm.*X-Amz-Credential.*X-Amz-Date.*X-Amz-Signature/,
'signed_url'
);
no warnings qw/ once redefine /;
my $mocked_response = Mocked::HTTP::Response->new( 200,'bar' );
*LWP::UserAgent::Determined::request = sub { $mocked_response };
$mocked_response->{_msg} = '';
ok( $file->delete,'->delete' );
ok( $file->_get_contents,'_get_contents' );
}
done_testing();
sub monkey_patch_module {
# monkey patching for true(r) unit tests
no warnings 'redefine';
no warnings 'once';
sub response { return shift; }
sub header { return shift; }
sub friendly_error { return; }
*AWS::S3::Request::SetFileContents::request = sub {
return bless( {},'main' );
};
}
t/aws/s3/file_iterator.t view on Meta::CPAN
#!perl
use strict;
use warnings;
package Mocked::HTTP::Response;
use Moose;
extends 'HTTP::Response';
sub content { shift->{_msg}; }
sub code { 200 }
sub is_success { 1 }
sub header { $_[1] =~ /content-length/i ? 1 : 'header' }
1;
package main;
use Test::More;
use Test::Deep;
use Test::Exception;
use FindBin qw/ $Script /;
use Data::Section::Simple 'get_data_section';
t/aws/s3/file_iterator.t view on Meta::CPAN
bucket => $bucket,
marker => 'foo',
pattern => qr/\d/,
);
is( $iterator2->marker,'foo','marker passed');
is( $iterator2->pattern,qr/\d/,'pattern passed');
is( $iterator2->prefix,undef,'!prefix' );
}
my $mocked_response = Mocked::HTTP::Response->new( 200,get_data_section('ListBucketResult.xml') );
local *LWP::UserAgent::Determined::request = sub { $mocked_response };
my @pages = $iterator->next_page; # to check wantarray
cmp_deeply( \@pages,[ obj_isa('AWS::S3::File') ],'next_page returns one ::File' );
is( $pages[0]->key,'img/my image.jpg','... and it is the one expected' );
is( $iterator->next_page->[0]->key,'img/my-third-image.jpg','next_page second item' );
is( $iterator->next_page->[0]->key,'img/my image.jpg','next_page new request, first item' );
$mocked_response = Mocked::HTTP::Response->new( 200,get_data_section('EmptyResult') );
ok( $iterator->next_page,'next_page second item' );
ok( ! $iterator->next_page,'no more items' );
}
subtest 'advance to page X before processing' => sub {
my $iterator = AWS::S3::FileIterator->new(
page_number => 5,
page_size => 1,
bucket => $bucket,
pattern => qr/\d+/,
);
my $number_of_request;
my $xml = get_data_section('LongResult');
my $mocked_response = Mocked::HTTP::Response->new( 200,$xml );
local *LWP::UserAgent::Determined::request = sub { $number_of_request++; return $mocked_response };
is( $iterator->next_page->[0]->key,5,'start at file 5' );
is( $iterator->next_page->[0]->key,6,'... file 6' );
is( $iterator->next_page->[0]->key,7,'... file 7' );
is( $iterator->next_page->[0]->key,8,'... file 8' );
is( $iterator->next_page->[0]->key,9,'... file 9' );
is( $iterator->next_page->[0]->key,0,'do a new request and get file 0' );
is( $number_of_request,2,'did two requests' );
};
( run in 1.490 second using v1.01-cache-2.11-cpan-a5abf4f5562 )