File Coverage

blib/lib/Net/Amazon/S3/Client/Bucket.pm
Criterion Covered Total %
statement 67 69 97.1
branch 12 24 50.0
condition 2 5 40.0
subroutine 17 17 100.0
pod 9 10 90.0
total 107 125 85.6


line stmt bran cond sub pod time code
1             package Net::Amazon::S3::Client::Bucket;
2             $Net::Amazon::S3::Client::Bucket::VERSION = '0.98';
3 96     96   780 use Moose 0.85;
  96         2568  
  96         786  
4 96     96   669199 use MooseX::StrictConstructor 0.16;
  96         2150  
  96         728  
5 96     96   386018 use Data::Stream::Bulk::Callback;
  96         13230675  
  96         5693  
6 96     96   60809 use MooseX::Types::DateTime::MoreCoercions 0.07 qw( DateTime );
  96         89510852  
  96         933  
7              
8             # ABSTRACT: An easy-to-use Amazon S3 client bucket
9              
10             has 'client' =>
11             ( is => 'ro', isa => 'Net::Amazon::S3::Client', required => 1 );
12             has 'name' => ( is => 'ro', isa => 'Str', required => 1 );
13             has 'creation_date' =>
14             ( is => 'ro', isa => DateTime, coerce => 1, required => 0 );
15             has 'owner_id' => ( is => 'ro', isa => 'Str', required => 0 );
16             has 'owner_display_name' => ( is => 'ro', isa => 'Str', required => 0 );
17             has 'region' => (
18             is => 'ro',
19             lazy => 1,
20             predicate => 'has_region',
21             default => sub { $_[0]->location_constraint },
22             );
23              
24              
25             __PACKAGE__->meta->make_immutable;
26              
27             sub _create {
28 17     17   75 my ($self, %conf) = @_;
29              
30             my $response = $self->_perform_operation (
31             'Net::Amazon::S3::Operation::Bucket::Create',
32              
33             (acl => $conf{acl}) x!! defined $conf{acl},
34             (acl_short => $conf{acl_short}) x!! defined $conf{acl_short},
35             (location_constraint => $conf{location_constraint}) x!! defined $conf{location_constraint},
36 17         202 );
37              
38 6 50       45 return unless $response->is_success;
39              
40 6         285 return $response->http_response;
41             }
42              
43             sub delete {
44 6     6 1 18 my $self = shift;
45              
46 6         36 my $response = $self->_perform_operation (
47             'Net::Amazon::S3::Operation::Bucket::Delete',
48             );
49              
50 1 50       21 return unless $response->is_success;
51 1         122 return $response->http_response;
52             }
53              
54             sub acl {
55 5     5 1 14 my $self = shift;
56              
57 5         26 my $response = $self->_perform_operation (
58             'Net::Amazon::S3::Operation::Bucket::Acl::Fetch',
59             );
60              
61 1 50       5 return if $response->is_error;
62 1         28 return $response->http_response->content;
63             }
64              
65             sub set_acl {
66 9     9 0 36 my ($self, %params) = @_;
67              
68 9         48 my $response = $self->_perform_operation (
69             'Net::Amazon::S3::Operation::Bucket::Acl::Set',
70             %params,
71             );
72              
73 5         277 return $response->is_success;
74             }
75              
76             sub add_tags {
77 5     5 1 25 my ($self, %params) = @_;
78              
79             my $response = $self->_perform_operation (
80             'Net::Amazon::S3::Operation::Bucket::Tags::Add',
81              
82             tags => $params{tags},
83 5         41 );
84              
85 1         21 return $response->is_success;
86             }
87              
88             sub delete_tags {
89 5     5 1 19 my ($self, $conf) = @_;
90              
91 5         31 my $response = $self->_perform_operation (
92             'Net::Amazon::S3::Operation::Bucket::Tags::Delete',
93             );
94              
95 1         19 return $response->is_success;
96             }
97              
98             sub location_constraint {
99 1     1 1 3 my $self = shift;
100              
101 1         6 my $response = $self->_perform_operation (
102             'Net::Amazon::S3::Operation::Bucket::Location',
103             );
104              
105 0 0       0 return unless $response->is_success;
106 0         0 return $response->location;
107             }
108              
109 81     81 1 2949 sub object_class { 'Net::Amazon::S3::Client::Object' }
110              
111             sub list {
112 8     8 1 22 my ( $self, $conf ) = @_;
113 8   50     21 $conf ||= {};
114 8         16 my $prefix = $conf->{prefix};
115 8         14 my $delimiter = $conf->{delimiter};
116              
117 8         14 my $marker = undef;
118 8         17 my $end = 0;
119              
120             return Data::Stream::Bulk::Callback->new(
121             callback => sub {
122              
123 8 50   8   2846 return undef if $end;
124              
125 8         31 my $response = $self->_perform_operation (
126             'Net::Amazon::S3::Operation::Objects::List',
127              
128             marker => $marker,
129             prefix => $prefix,
130             delimiter => $delimiter,
131             );
132              
133 4 50       27 return unless $response->is_success;
134              
135 4         81 my @objects;
136 4         17 foreach my $node ($response->contents) {
137             push @objects, $self->object_class->new (
138             client => $self->client,
139             bucket => $self,
140             key => $node->{key},
141             etag => $node->{etag},
142             size => $node->{size},
143             last_modified_raw => $node->{last_modified},
144 5         17 );
145             }
146              
147 4 100       17 return undef unless @objects;
148              
149 3 50       12 $end = 1 unless $response->is_truncated;
150              
151 3   33     12 $marker = $response->next_marker
152             || $objects[-1]->key;
153              
154 3         17 return \@objects;
155             }
156 8         340 );
157             }
158              
159             sub delete_multi_object {
160 5     5 1 24 my $self = shift;
161 5         23 my @objects = @_;
162 5 50       22 return unless( scalar(@objects) );
163              
164             # Since delete can handle up to 1000 requests, be a little bit nicer
165             # and slice up requests and also allow keys to be strings
166             # rather than only objects.
167 5         14 my $last_result;
168 5         25 while (scalar(@objects) > 0) {
169             my $response = $self->_perform_operation (
170             'Net::Amazon::S3::Operation::Objects::Delete',
171              
172             keys => [
173 5 50       33 map { ref ($_) ? $_->key : $_ }
  11 50       61  
174             splice @objects, 0, ((scalar(@objects) > 1000) ? 1000 : scalar(@objects))
175             ]
176             );
177              
178 1         6 $last_result = $response;
179              
180 1 50       19 last unless $response->is_success;
181             }
182 1         66 return $last_result->http_response;
183             }
184              
185             sub object {
186 76     76 1 379 my ( $self, %conf ) = @_;
187 76         349 return $self->object_class->new(
188             client => $self->client,
189             bucket => $self,
190             %conf,
191             );
192             }
193              
194             sub _perform_operation {
195 133     133   570 my ($self, $operation, %params) = @_;
196              
197 133         4391 $self->client->_perform_operation ($operation => (
198             bucket => $self->name,
199             %params,
200             ));
201             }
202              
203             1;
204              
205             __END__
206              
207             =pod
208              
209             =encoding UTF-8
210              
211             =head1 NAME
212              
213             Net::Amazon::S3::Client::Bucket - An easy-to-use Amazon S3 client bucket
214              
215             =head1 VERSION
216              
217             version 0.98
218              
219             =head1 SYNOPSIS
220              
221             # return the bucket name
222             print $bucket->name . "\n";
223              
224             # return the bucket location constraint
225             print "Bucket is in the " . $bucket->location_constraint . "\n";
226              
227             # return the ACL XML
228             my $acl = $bucket->acl;
229              
230             # list objects in the bucket
231             # this returns a L<Data::Stream::Bulk> object which returns a
232             # stream of L<Net::Amazon::S3::Client::Object> objects, as it may
233             # have to issue multiple API requests
234             my $stream = $bucket->list;
235             until ( $stream->is_done ) {
236             foreach my $object ( $stream->items ) {
237             ...
238             }
239             }
240              
241             # or list by a prefix
242             my $prefix_stream = $bucket->list( { prefix => 'logs/' } );
243              
244             # returns a L<Net::Amazon::S3::Client::Object>, which can then
245             # be used to get or put
246             my $object = $bucket->object( key => 'this is the key' );
247              
248             # delete the bucket (it must be empty)
249             $bucket->delete;
250              
251             =head1 DESCRIPTION
252              
253             This module represents buckets.
254              
255             =for test_synopsis no strict 'vars'
256              
257             =head1 METHODS
258              
259             =head2 acl
260              
261             # return the ACL XML
262             my $acl = $bucket->acl;
263              
264             =head2 add_tags
265              
266             $bucket->add_tags (
267             tags => { tag1 => 'val1', ... },
268             )
269              
270             =head2 delete_tags
271              
272             $bucket->delete_tags;
273              
274             =head2 delete
275              
276             # delete the bucket (it must be empty)
277             $bucket->delete;
278              
279             =head2 list
280              
281             # list objects in the bucket
282             # this returns a L<Data::Stream::Bulk> object which returns a
283             # stream of L<Net::Amazon::S3::Client::Object> objects, as it may
284             # have to issue multiple API requests
285             my $stream = $bucket->list;
286             until ( $stream->is_done ) {
287             foreach my $object ( $stream->items ) {
288             ...
289             }
290             }
291              
292             # or list by a prefix
293             my $prefix_stream = $bucket->list( { prefix => 'logs/' } );
294              
295             # you can emulate folders by using prefix with delimiter
296             # which shows only entries starting with the prefix but
297             # not containing any more delimiter (thus no subfolders).
298             my $folder_stream = $bucket->list( { prefix => 'logs/', delimiter => '/' } );
299              
300             =head2 location_constraint
301              
302             # return the bucket location constraint
303             print "Bucket is in the " . $bucket->location_constraint . "\n";
304              
305             =head2 name
306              
307             # return the bucket name
308             print $bucket->name . "\n";
309              
310             =head2 object
311              
312             # returns a L<Net::Amazon::S3::Client::Object>, which can then
313             # be used to get or put
314             my $object = $bucket->object( key => 'this is the key' );
315              
316             =head2 delete_multi_object
317              
318             # delete multiple objects using a multi object delete operation
319             # Accepts a list of L<Net::Amazon::S3::Client::Object or String> objects.
320             $bucket->delete_multi_object($object1, $object2)
321              
322             =head2 object_class
323              
324             # returns string "Net::Amazon::S3::Client::Object"
325             # allowing subclasses to add behavior.
326             my $object_class = $bucket->object_class;
327              
328             =head1 AUTHOR
329              
330             Branislav ZahradnĂ­k <barney@cpan.org>
331              
332             =head1 COPYRIGHT AND LICENSE
333              
334             This software is copyright (c) 2021 by Amazon Digital Services, Leon Brocard, Brad Fitzpatrick, Pedro Figueiredo, Rusty Conover, Branislav ZahradnĂ­k.
335              
336             This is free software; you can redistribute it and/or modify it under
337             the same terms as the Perl 5 programming language system itself.
338              
339             =cut