view release on metacpan or  search on metacpan

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

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 File::Temp qw(tempfile);
use IO::File;
use IO::Scalar;
use List::Util qw(none pairs any);
use MIME::Base64;
use Scalar::Util qw(reftype);
use URI;
use XML::Simple; ## no critic (DiscouragedModules)

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

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

__PACKAGE__->mk_accessors(
  qw(
    account
    bucket
    buffer_size
    creation_date
    logger
    region
    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, @args ) = @_;

  my ( $data, $headers, $key ) = @{ $args[0] }{qw{data headers key}};

  my $account = $self->account;

  my $args = {
    method  => 'PUT',
    path    => $self->_uri($key),
    headers => $headers,
    data    => $data,
    region  => $self->region,
  };

  return $account->send_request_expect_nothing_probed($args)
    if ref $data;

  return $account->send_request_expect_nothing($args);
}

########################################################################
sub add_key {
########################################################################

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, $algorithm )
        = @{ $args[0] }{qw{ key id part data length algorithm}};
    }
    elsif ( reftype( $args[0] ) eq 'ARRAY' ) {
      ( $key, $upload_id, $part_number, $data, $length, $algorithm ) = @{ $args[0] };
    }
  }
  else {
    ( $key, $upload_id, $part_number, $data, $length, $algorithm ) = @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 );

  $algorithm = lc( $algorithm // $EMPTY );

  my $checksum;

  my $checksum_types = $self->account->checksum_types;

  if ( exists $checksum_types->{$algorithm} ) {
    my $digest = $checksum_types->{$algorithm}->( data => $data, );

    $checksum = encode_base64( $digest, $EMPTY );

    $headers->{ 'x-amz-checksum-' . $algorithm } = $checksum;
  }

  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 wantarray ? ( $etag, $checksum ) : $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, $algorithm ) = @_;

  $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';

  $algorithm = lc( $algorithm // $EMPTY );

  # 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, $algorithm );

  $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);

  $acct->_croak_if_response_error($response);

  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