has
'account'
=> (
is
=>
'ro'
,
isa
=>
'Net::Amazon::S3'
,
required
=> 1 );
has
'bucket'
=> (
is
=>
'ro'
,
isa
=>
'Str'
,
required
=> 1 );
has
'creation_date'
=> (
is
=>
'ro'
,
isa
=>
'Maybe[Str]'
,
required
=> 0 );
__PACKAGE__->meta->make_immutable;
sub
_uri {
my
(
$self
,
$key
) =
@_
;
return
(
$key
)
?
$self
->bucket .
"/"
.
$self
->account->_urlencode(
$key
)
:
$self
->bucket .
"/"
;
}
sub
_conf_to_headers {
my
(
$self
,
$conf
) =
@_
;
$conf
= {}
unless
defined
$conf
;
$conf
= {
%$conf
};
if
(
$conf
->{acl_short} ) {
$self
->account->_validate_acl_short(
$conf
->{acl_short} );
$conf
->{
'x-amz-acl'
} =
$conf
->{acl_short};
delete
$conf
->{acl_short};
}
return
$conf
;
}
sub
add_key {
my
(
$self
,
$key
,
$value
,
$conf
) =
@_
;
if
(
ref
(
$value
) eq
'SCALAR'
) {
$conf
->{
'Content-Length'
} ||= -s
$$value
;
$value
= _content_sub(
$$value
);
}
else
{
$conf
->{
'Content-Length'
} ||=
length
$value
;
}
my
$acl_short
;
if
(
$conf
->{acl_short} ) {
$acl_short
=
$conf
->{acl_short};
delete
$conf
->{acl_short};
}
my
$http_request
= Net::Amazon::S3::Request::PutObject->new(
s3
=>
$self
->account,
bucket
=>
$self
->bucket,
key
=>
$key
,
value
=>
$value
,
acl_short
=>
$acl_short
,
headers
=>
$conf
,
)->http_request;
if
(
ref
(
$value
) ) {
return
$self
->account->_send_request_expect_nothing_probed(
$http_request
);
}
else
{
return
$self
->account->_send_request_expect_nothing(
$http_request
);
}
}
sub
add_key_filename {
my
(
$self
,
$key
,
$value
,
$conf
) =
@_
;
return
$self
->add_key(
$key
, \
$value
,
$conf
);
}
sub
copy_key {
my
(
$self
,
$key
,
$source
,
$conf
) =
@_
;
my
$acl_short
;
if
(
defined
$conf
) {
if
(
$conf
->{acl_short} ) {
$acl_short
=
$conf
->{acl_short};
delete
$conf
->{acl_short};
}
$conf
->{
'x-amz-metadata-directive'
} =
'REPLACE'
;
}
else
{
$conf
= {};
}
$conf
->{
'x-amz-copy-source'
} =
$source
;
my
$acct
=
$self
->account;
my
$http_request
= Net::Amazon::S3::Request::PutObject->new(
s3
=>
$self
->account,
bucket
=>
$self
->bucket,
key
=>
$key
,
value
=>
''
,
acl_short
=>
$acl_short
,
headers
=>
$conf
,
)->http_request;
my
$response
=
$acct
->_do_http(
$http_request
);
my
$xpc
=
$acct
->_xpc_of_content(
$response
->content );
if
( !
$response
->is_success || !
$xpc
||
$xpc
->findnodes(
"//Error"
) ) {
$acct
->_remember_errors(
$response
->content );
return
0;
}
return
1;
}
sub
edit_metadata {
my
(
$self
,
$key
,
$conf
) =
@_
;
croak
"Need configuration hash"
unless
defined
$conf
;
return
$self
->copy_key(
$key
,
"/"
.
$self
->bucket .
"/"
.
$key
,
$conf
);
}
sub
head_key {
my
(
$self
,
$key
) =
@_
;
return
$self
->get_key(
$key
,
"HEAD"
);
}
sub
get_key {
my
(
$self
,
$key
,
$method
,
$filename
) =
@_
;
$filename
=
$$filename
if
ref
$filename
;
my
$acct
=
$self
->account;
my
$http_request
= Net::Amazon::S3::Request::GetObject->new(
s3
=>
$acct
,
bucket
=>
$self
->bucket,
key
=>
$key
,
method
=>
$method
||
'GET'
,
)->http_request;
my
$response
=
$acct
->_do_http(
$http_request
,
$filename
);
if
(
$response
->code == 404 ) {
return
undef
;
}
$acct
->_croak_if_response_error(
$response
);
my
$etag
=
$response
->header(
'ETag'
);
if
(
$etag
) {
$etag
=~ s/^"//;
$etag
=~ s/"$//;
}
my
$return
;
foreach
my
$header
(
$response
->headers->header_field_names ) {
$return
->{
lc
$header
} =
$response
->header(
$header
);
}
$return
->{content_length} =
$response
->content_length || 0;
$return
->{content_type} =
$response
->content_type;
$return
->{etag} =
$etag
;
$return
->{value} =
$response
->content;
return
$return
;
}
sub
get_key_filename {
my
(
$self
,
$key
,
$method
,
$filename
) =
@_
;
return
$self
->get_key(
$key
,
$method
, \
$filename
);
}
sub
delete_key {
my
(
$self
,
$key
) =
@_
;
croak
'must specify key'
unless
defined
$key
&&
length
$key
;
my
$http_request
= Net::Amazon::S3::Request::DeleteObject->new(
s3
=>
$self
->account,
bucket
=>
$self
->bucket,
key
=>
$key
,
)->http_request;
return
$self
->account->_send_request_expect_nothing(
$http_request
);
}
sub
delete_bucket {
my
$self
=
shift
;
croak
"Unexpected arguments"
if
@_
;
return
$self
->account->delete_bucket(
$self
);
}
sub
list {
my
$self
=
shift
;
my
$conf
=
shift
|| {};
$conf
->{bucket} =
$self
->bucket;
return
$self
->account->list_bucket(
$conf
);
}
sub
list_all {
my
$self
=
shift
;
my
$conf
=
shift
|| {};
$conf
->{bucket} =
$self
->bucket;
return
$self
->account->list_bucket_all(
$conf
);
}
sub
get_acl {
my
(
$self
,
$key
) =
@_
;
my
$account
=
$self
->account;
my
$http_request
;
if
(
$key
) {
$http_request
= Net::Amazon::S3::Request::GetObjectAccessControl->new(
s3
=>
$account
,
bucket
=>
$self
->bucket,
key
=>
$key
,
)->http_request;
}
else
{
$http_request
= Net::Amazon::S3::Request::GetBucketAccessControl->new(
s3
=>
$account
,
bucket
=>
$self
->bucket,
)->http_request;
}
my
$response
=
$account
->_do_http(
$http_request
);
if
(
$response
->code == 404 ) {
return
undef
;
}
$account
->_croak_if_response_error(
$response
);
return
$response
->content;
}
sub
set_acl {
my
(
$self
,
$conf
) =
@_
;
$conf
||= {};
my
$key
=
$conf
->{key};
my
$http_request
;
if
(
$key
) {
$http_request
= Net::Amazon::S3::Request::SetObjectAccessControl->new(
s3
=>
$self
->account,
bucket
=>
$self
->bucket,
key
=>
$key
,
acl_short
=>
$conf
->{acl_short},
acl_xml
=>
$conf
->{acl_xml},
)->http_request;
}
else
{
$http_request
= Net::Amazon::S3::Request::SetBucketAccessControl->new(
s3
=>
$self
->account,
bucket
=>
$self
->bucket,
acl_short
=>
$conf
->{acl_short},
acl_xml
=>
$conf
->{acl_xml},
)->http_request;
}
return
$self
->account->_send_request_expect_nothing(
$http_request
);
}
sub
get_location_constraint {
my
(
$self
) =
@_
;
my
$http_request
= Net::Amazon::S3::Request::GetBucketLocationConstraint->new(
s3
=>
$self
->account,
bucket
=>
$self
->bucket,
)->http_request;
my
$xpc
=
$self
->account->_send_request(
$http_request
);
return
undef
unless
$xpc
&& !
$self
->account->_remember_errors(
$xpc
);
my
$lc
=
$xpc
->findvalue(
"//s3:LocationConstraint"
);
if
(
defined
$lc
&&
$lc
eq
''
) {
$lc
=
undef
;
}
return
$lc
;
}
sub
err {
$_
[0]->account->err }
sub
errstr {
$_
[0]->account->errstr }
sub
_content_sub {
my
$filename
=
shift
;
my
$stat
=
stat
(
$filename
);
my
$remaining
=
$stat
->size;
my
$blksize
=
$stat
->blksize || 4096;
croak
"$filename not a readable file with fixed size"
unless
-r
$filename
and ( -f _ ||
$remaining
);
my
$fh
= IO::File->new(
$filename
,
'r'
)
or croak
"Could not open $filename: $!"
;
$fh
->
binmode
;
return
sub
{
my
$buffer
;
unless
(
$fh
->opened ) {
$fh
= IO::File->new(
$filename
,
'r'
)
or croak
"Could not open $filename: $!"
;
$fh
->
binmode
;
$remaining
=
$stat
->size;
}
unless
(
my
$read
=
$fh
->
read
(
$buffer
,
$blksize
) ) {
croak
"Error while reading upload content $filename ($remaining remaining) $!"
if
$! and
$remaining
;
$fh
->
close
or croak
"close of upload content $filename failed: $!"
;
$buffer
||=
''
;
}
$remaining
-=
length
(
$buffer
);
return
$buffer
;
};
}
1;