File Coverage

lib/Amazon/S3/Bucket.pm

Criterion	Covered	Total	%
statement	54	464	11.6
branch	0	184	0.0
condition	0	138	0.0
subroutine	18	57	31.5
pod	27	29	93.1
total	99	872	11.3

package Amazon::S3::Bucket;

use strict;
use warnings;

use Amazon::S3::Constants qw(:all);
use Amazon::S3::Util      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 List::Util   qw(none pairs);
use Scalar::Util qw(reftype);
use URI;
use XML::Simple; ## no critic (DiscouragedModules)

use parent qw(Exporter Class::Accessor::Fast);

our $VERSION = '2.0.2'; ## no critic (RequireInterpolation)

__PACKAGE__->mk_accessors(
  qw(
    bucket
    creation_date
    account
    buffer_size
    region
    logger
    verify_region
  ),
);

########################################################################
sub new {
########################################################################
  my ( $class, @args ) = @_;

  my $options = get_parameters(@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 = $self->bucket . $SLASH;

  if ($key) {
    $uri .= urlencode($key);
  }

  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;

  $conf //= {};

  my $account = $self->account;

  my $headers = delete $conf->{headers};
  $headers //= {};

  if ( $conf->{acl_short} ) {
    $account->_validate_acl_short( $conf->{acl_short} );

    $conf->{'x-amz-acl'} = $conf->{acl_short};

    delete $conf->{acl_short};
  }

  $headers = { %{$conf}, %{$headers} };

  set_md5_header( data => $value, headers => $headers );

  if ( ref $value ) {
    $value = _content_sub( ${$value}, $self->buffer_size );

    $headers->{'x-amz-content-sha256'} = 'UNSIGNED-PAYLOAD';
  }

  # 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 => $headers,
        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 => $headers,
        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 = get_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, $headers ) = @_;

  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 => $headers,
    },
  );

  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 $headers = {};
  my $acct    = $self->account;

  set_md5_header( data => $data, headers => $headers );

  my $path = create_api_uri(
    path       => $self->_uri($key),
    partNumber => ${part_number},
    uploadId   => ${upload_id}
  );

  my $params = $QUESTION_MARK
    . create_query_string(
    partNumber => ${part_number},
    uploadId   => ${upload_id}
    );

  $self->logger->debug(
    sub {
      return Dumper(
        [ part   => $part_number,
          length => length $data,
          path   => $path,
        ]
      );
    }
  );

  my $request = $acct->_make_request(
    { region => $self->region,
      method => 'PUT',
      path   => $self->_uri($key) . $params,
      #path    => $path,
      headers => $headers,
      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;
}

#
# 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)
  my $content = _create_multipart_upload_request($parts_hr);

  $self->logger->debug("content: \n$content");

  my $md5        = md5($content);
  my $md5_base64 = encode_base64($md5);
  chomp $md5_base64;

  my $headers = {
    '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 => $headers,
      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;
}

########################################################################
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, $headers ) = @_;

  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 => $headers,
    },
  );

  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, $headers ) = @_;

  my $acct = $self->account;

  my $request = $acct->_make_request(
    { region  => $self->region,
      method  => 'GET',
      path    => $self->_uri() . '?uploads',
      headers => $headers,
    },
  );

  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_v2 {
########################################################################
  my ( $self, $key, $method, $headers ) = @_;

  return $self->_get_key( $key, $method, undef, $headers );
}

########################################################################
sub get_key {
########################################################################
  my ( $self, @args ) = @_;

  my ( $key, $method, $headers, $uri_params );

  if ( ref $args[0] ) {
    ( $key, $method, $headers, $uri_params )
      = @{ $args[0] }{qw(key method headers uri_params)};
  }
  else {
    ( $key, $method, $headers, $uri_params ) = @args;
  }

  return $self->_get_key(
    key        => $key,
    method     => $method,
    filename   => undef,
    headers    => $headers,
    uri_params => $uri_params,
  );
}

########################################################################
sub _get_key {
########################################################################
  my ( $self, @args ) = @_;

  my $parameters = get_parameters(@args);

  my ( $key, $method, $filename, $headers, $uri_params )
    = @{$parameters}{qw(key method filename headers uri_params)};

  $method //= 'GET';

  my $uri = $self->_uri($key);

  if ( $uri_params && keys %{$uri_params} ) {
    $uri = $QUESTION_MARK . create_query_string($uri_params);
  }

  if ( ref $filename ) {
    $filename = ${$filename};
  }

  my $acct = $self->account;

  my $request = $acct->_make_request(
    { region  => $self->region,
      method  => $method,
      path    => $uri,
      headers => $headers,
    },
  );

  my $response = $acct->_do_http( $request, $filename );

  return
    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;
  }

  my $retval = {
    content_length => ( $response->content_length || 0 ),
    content_type   => scalar $response->content_type,
    etag           => $etag,
    value          => ( $response->content // $EMPTY ),
    content_range  => ( $response->header('Content-Range') || $EMPTY ),
    last_modified  => ( $response->header('Last-Modified') || $EMPTY ),
  };

  # Validate against data corruption by verifying the MD5 (only if not partial)
  if ( $method eq 'GET' && $response->code ne $HTTP_PARTIAL_CONTENT ) {
    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, @args ) = @_;

  my ( $key, $method, $filename, $headers, $uri_params );

  if ( ref $args[0] ) {
    ( $key, $method, $filename, $headers, $uri_params )
      = @{ $args[0] }{qw(key method filename headers uri_params)};
  }
  else {
    ( $key, $method, $filename, $headers, $uri_params ) = @args;
  }

  if ( !defined $filename ) {
    $filename = $key;
  }

  return $self->_get_key(
    key        => $key,
    method     => $method,
    filename   => \$filename,
    headers    => $headers,
    uri_params => $uri_params,
  );
}

########################################################################
# 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, @args ) = @_;

  my $parameters = get_parameters(@args);

  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;
  $bucket //= $self->bucket();

  if ( !$request_headers{'x-amz-copy-source'} ) {

    $request_headers{'x-amz-copy-source'} = sprintf '%s/%s', $bucket,
      urlencode($source);
  }

  $request_headers{'x-amz-tagging-directive'} //= 'COPY';

  $key = $self->_uri($key);

  my $request = $acct->_make_request(
    method  => 'PUT',
    path    => $key,
    headers => \%request_headers,
  );

  my $response = $acct->_do_http($request);

  if ( $response->code !~ /\A2\d{2}\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, $version ) = @_;

  croak 'must specify key'
    if !$key && length $key;

  my $account = $self->account;

  my $path = $self->_uri($key);

  if ($version) {
    $path = '?versionId=' . $version;
  }

  return $account->_send_request_expect_nothing(
    { method  => 'DELETE',
      region  => $self->region,
      path    => $path,
      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, $headers );

  if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) {
    ( $keys, $quiet_mode, $headers ) = @{ $args[0] }{qw(keys quiet headers)};
    $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 $account = $self->account;

  my $md5        = md5($xml_content);
  my $md5_base64 = encode_base64($md5);

  chomp $md5_base64;

  $headers //= {};

  $headers->{'Content-MD5'} = $md5_base64;

  return $account->_send_request(
    { method  => 'POST',
      region  => $self->region,
      path    => $self->_uri() . '?delete',
      headers => $headers,
      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, $headers ) = @_;

  my $account = $self->account;

  my $request = $account->_make_request(
    { region  => $self->region,
      method  => 'GET',
      path    => $self->_uri($key) . '?acl=',
      headers => $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 ) = @_;

  my $account = $self->account;

  $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 = $conf->{headers};

  if ( $conf->{acl_short} ) {
    $headers->{'x-amz-acl'} //= $conf->{acl_short};
  }

  my $xml = $conf->{acl_xml} // $EMPTY;

  $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, @args ) = @_;

  my $parameters = get_parameters(@args);

  my ( $bucket, $headers, $region )
    = @{$parameters}{qw(bucket headers region)};

  my $account = $self->account;
  $bucket //= $self->bucket;

  my $location = $account->_send_request(
    { region  => $region // $self->region,
      method  => 'GET',
      path    => $bucket . '/?location=',
      headers => $headers,
    },
  );

  return $location
    if $location;

  croak $account->errstr
    if $account->_remember_errors($location);

  return;
}

########################################################################
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;
  };
}

########################################################################
sub _create_multipart_upload_request {
########################################################################
  my ($parts_hr) = @_;

  my @parts;

  foreach my $part_num ( sort { $a <=> $b } keys %{$parts_hr} ) {
    push @parts,
      {
      PartNumber => $part_num,
      ETag       => $parts_hr->{$part_num},
      };
  }

  return create_xml_request(
    { CompleteMultipartUpload => { Part => \@parts } } );
}

1;

__END__