PUT results from the CPAN

Amazon-S3

    $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

lib/Amazon/S3/Bucket.pm view on Meta::CPAN


  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;

lib/Amazon/S3/Bucket.pm view on Meta::CPAN

  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

lib/Amazon/S3/Bucket.pm view on Meta::CPAN

  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;

lib/Amazon/S3/Bucket.pm view on Meta::CPAN


Same as C<list_all> but uses the version 2 API for listing keys.

See L<Amazon::S3/list_bucket_all_v2> for documentation of this
method.

=head2 get_acl

Retrieves the Access Control List (ACL) for the bucket or
resource as an XML document.

=over

=item key

The key of the stored resource to fetch. This parameter is
optional. By default the method returns the ACL for the
bucket itself.

=back

=head2 set_acl

 set_acl(acl)

Sets the Access Control List (ACL) for the bucket or
resource. Requires a HASHREF argument with one of the following keys:

=over

=item acl_xml

An XML string which contains access control information
which matches Amazon's published schema.

=item acl_short

Alternative shorthand notation for common types of ACLs that
can be used in place of a ACL XML document.

According to the Amazon S3 API documentation the following recognized acl_short
types are defined as follows:

=over

=item private

Owner gets FULL_CONTROL. No one else has any access rights.
This is the default.

=item public-read

Owner gets FULL_CONTROL and the anonymous principal is
granted READ access. If this policy is used on an object, it
can be read from a browser with no authentication.

=item public-read-write

Owner gets FULL_CONTROL, the anonymous principal is granted
READ and WRITE access. This is a useful policy to apply to a
bucket, if you intend for any anonymous user to PUT objects
into the bucket.

=item authenticated-read

Owner gets FULL_CONTROL, and any principal authenticated as
a registered Amazon S3 user is granted READ access.

=back

=item key

The key name to apply the permissions. If the key is not
provided the bucket ACL will be set.

=back

Returns a boolean indicating the operations success.

=head2 get_location_constraint

Returns the location constraint (region the bucket resides in) for a
bucket. Returns undef if there is no location constraint.

Valid values that may be returned:

 af-south-1
 ap-east-1
 ap-northeast-1
 ap-northeast-2
 ap-northeast-3
 ap-south-1
 ap-southeast-1
 ap-southeast-2
 ca-central-1
 cn-north-1
 cn-northwest-1
 EU
 eu-central-1
 eu-north-1
 eu-south-1
 eu-west-1
 eu-west-2
 eu-west-3
 me-south-1
 sa-east-1
 us-east-2
 us-gov-east-1
 us-gov-west-1
 us-west-1
 us-west-2

For more information on location constraints, refer to the
documentation for
L<GetBucketLocation|https://docs.aws.amazon.com/AmazonS3/latest/API/API_GetBucketLocation.html>.

=head2 err

The S3 error code for the last error the account encountered.

=head2 errstr

( run in 1.306 second using v1.01-cache-2.11-cpan-437f7b0c052 )