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.99';
3 99     99   773 use Moose 0.85;
  99         2486  
  99         810  
4 99     99   675250 use MooseX::StrictConstructor 0.16;
  99         2222  
  99         759  
5 99     99   390590 use Data::Stream::Bulk::Callback;
  99         13392493  
  99         5342  
6 99     99   56158 use MooseX::Types::DateTime::MoreCoercions 0.07 qw( DateTime );
  99         90244905  
  99         854  
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   66 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         145 );
37              
38 6 50       316 return unless $response->is_success;
39              
40 6         301 return $response->http_response;
41             }
42              
43             sub delete {
44 6     6 1 13 my $self = shift;
45              
46 6         23 my $response = $self->_perform_operation (
47             'Net::Amazon::S3::Operation::Bucket::Delete',
48             );
49              
50 1 50       12 return unless $response->is_success;
51 1         52 return $response->http_response;
52             }
53              
54             sub acl {
55 5     5 1 12 my $self = shift;
56              
57 5         30 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         29 return $response->http_response->content;
63             }
64              
65             sub set_acl {
66 9     9 0 29 my ($self, %params) = @_;
67              
68 9         39 my $response = $self->_perform_operation (
69             'Net::Amazon::S3::Operation::Bucket::Acl::Set',
70             %params,
71             );
72              
73 5         216 return $response->is_success;
74             }
75              
76             sub add_tags {
77 5     5 1 27 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         33 );
84              
85 1         12 return $response->is_success;
86             }
87              
88             sub delete_tags {
89 5     5 1 19 my ($self, $conf) = @_;
90              
91 5         35 my $response = $self->_perform_operation (
92             'Net::Amazon::S3::Operation::Bucket::Tags::Delete',
93             );
94              
95 1         18 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 87     87 1 3108 sub object_class { 'Net::Amazon::S3::Client::Object' }
110              
111             sub list {
112 8     8 1 21 my ( $self, $conf ) = @_;
113 8   50     26 $conf ||= {};
114 8         18 my $prefix = $conf->{prefix};
115 8         16 my $delimiter = $conf->{delimiter};
116              
117 8         17 my $marker = undef;
118 8         15 my $end = 0;
119              
120             return Data::Stream::Bulk::Callback->new(
121             callback => sub {
122              
123 8 50   8   2815 return undef if $end;
124              
125 8         41 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         83 my @objects;
136 4         30 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         21 );
145             }
146              
147 4 100       16 return undef unless @objects;
148              
149 3 50       17 $end = 1 unless $response->is_truncated;
150              
151 3   33     16 $marker = $response->next_marker
152             || $objects[-1]->key;
153              
154 3         17 return \@objects;
155             }
156 8         443 );
157             }
158              
159             sub delete_multi_object {
160 5     5 1 22 my $self = shift;
161 5         16 my @objects = @_;
162 5 50       20 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         18 my $last_result;
168 5         26 while (scalar(@objects) > 0) {
169             my $response = $self->_perform_operation (
170             'Net::Amazon::S3::Operation::Objects::Delete',
171              
172             keys => [
173 5 50       37 map { ref ($_) ? $_->key : $_ }
  11 50       47  
174             splice @objects, 0, ((scalar(@objects) > 1000) ? 1000 : scalar(@objects))
175             ]
176             );
177              
178 1         3 $last_result = $response;
179              
180 1 50       14 last unless $response->is_success;
181             }
182 1         52 return $last_result->http_response;
183             }
184              
185             sub object {
186 82     82 1 398 my ( $self, %conf ) = @_;
187 82         353 return $self->object_class->new(
188             client => $self->client,
189             bucket => $self,
190             %conf,
191             );
192             }
193              
194             sub _perform_operation {
195 139     139   651 my ($self, $operation, %params) = @_;
196              
197 139         4596 $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.99
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