view release on metacpan or  search on metacpan

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

    foreach my $node ( @{$buckets} ) {
      push @buckets,
        Amazon::S3::Bucket->new(
        { bucket        => $node->{Name},
          creation_date => $node->{CreationDate},
          account       => $self,
          buffer_size   => $self->buffer_size,
          verify_region => $verify_region // $FALSE,
        },
        );

    }
  }

  $self->reset_signer_region($region); # restore original region

  $bucket_list = {
    owner_id          => $owner_id,
    owner_displayname => $owner_displayname,
    buckets           => \@buckets,
  };

  return $bucket_list;
}

########################################################################
sub reset_signer_region {
########################################################################
  my ( $self, $region ) = @_;

  # reset signer's region, if the region wasn't us-east-1...note this
  # is probably not needed anymore since bucket operations now send
  # the region of the bucket to the signer
  if ( $self->cache_signer ) {
    if ( $self->region && $self->region ne $DEFAULT_REGION ) {
      if ( $self->signer->can('region') ) {
        $self->signer->region($region);
      }
    }
  }
  else {
    $self->region($region);
  }

  return $self->region;
}

########################################################################
sub add_bucket {
########################################################################
  my ( $self, $conf ) = @_;

  my $bucket = $conf->{bucket};

  croak 'must specify bucket'
    if !$bucket;

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

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

    $headers->{'x-amz-acl'}              //= $conf->{acl_short};
    $headers->{'x-amz-object-ownership'} //= 'ObjectWriter';
  }

  my $region = $conf->{location_constraint} // $conf->{region};

  $region //= $self->region;

  if ( $region && $region eq $DEFAULT_REGION ) {
    undef $region;
  }

  return $self->_add_bucket(
    { headers           => $headers,
      bucket            => $conf->{bucket},
      region            => $region,
      availability_zone => $conf->{availability_zone},
    }
  );
}

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

  my $parameters = get_parameters(@args);

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

  $region  //= $EMPTY;
  $headers //= {};

  my $request
    = { CreateBucketConfiguration => { LocationConstraint => $region, } };

  if ($availability_zone) {
    $request->{CreateBucketConfiguration}->{Location} = {
      Name => $availability_zone,
      Type => 'AvailabilityZone',
    };

    $request->{CreateBucketConfiguration}->{Bucket} = {
      DataRedundancy => 'SingleAvailabilityZone',
      Type           => 'Directory',
    };

    delete $request->{CreateBucketConfiguration}->{LocationConstraint};
  }

  $self->dns_bucket_names(0);

  my $data
    = ( $region || $availability_zone )
    ? create_xml_request($request)
    : $EMPTY;

  $headers->{'Content-Length'} = length $data;

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

  else {
    $aws_access_key_id     = $self->aws_access_key_id;
    $aws_secret_access_key = $self->aws_secret_access_key;
    $token                 = $self->token;
  }

  return ( $aws_access_key_id, $aws_secret_access_key, $token );
}

# Log::Log4perl compatibility routines
########################################################################
sub get_logger {
########################################################################
  my ($self) = @_;

  return $self->logger;
}

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

  if (@args) {
    $self->log_level( $args[0] );

    $self->get_logger->level( uc $args[0] );
  }

  return $self->get_logger->level;
}

########################################################################
sub signer {
########################################################################
  my ($self) = @_;

  return $self->_signer
    if $self->_signer;

  my $creds   = $self->credentials ? $self->credentials : $self;
  my $express = $self->express;

  my $signer = Amazon::S3::Signature::V4->new(
    { access_key_id  => $creds->get_aws_access_key_id,
      secret         => $creds->get_aws_secret_access_key,
      region         => $self->region || $self->get_default_region,
      service        => $express ? 's3express' : 's3',
      security_token => $creds->get_token,
    },
  );

  if ( $self->cache_signer ) {
    $self->_signer($signer);
  }

  return $signer;
}

########################################################################
sub _validate_acl_short {
########################################################################
  my ( $self, $policy_name ) = @_;

  croak sprintf '%s is not a supported canned access policy', $policy_name
    if none { $policy_name eq $_ }
    qw(private public-read public-read-write authenticated-read);

  return;
}

########################################################################
# Determine if a bucket can used as subdomain for the host
# Specifying the bucket in the URL path is being deprecated
# So, if the bucket name is suitable, we need to use it
# as a subdomain in the host name instead.
#
# Currently buckets with periods in their names cannot be handled in
# that manner due to SSL certificate issues, they will have to remain
# in the url path instead.
#
########################################################################
sub is_domain_bucket { goto &_can_bucket_be_subdomain; }
########################################################################

########################################################################
sub _can_bucket_be_subdomain {
########################################################################
  my ($bucketname) = @_;

  return $FALSE
    if length $bucketname > $MAX_BUCKET_NAME_LENGTH - 1;

  return $FALSE
    if length $bucketname < $MIN_BUCKET_NAME_LENGTH;

  return $FALSE
    if $bucketname !~ m{\A[[:lower:]][[:lower:]\d-]*\z}xsm;

  return $FALSE
    if $bucketname !~ m{[[:lower:]\d]\z}xsm;

  return $TRUE;
}

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

  my $parameters = get_parameters(@args);

  my ( $method, $path, $headers, $data, $metadata, $region )
    = @{$parameters}{qw(method path headers data metadata region)};

  # reset region on every call...every bucket can have it's own region
  $self->region( $region // $self->_region );

  croak 'must specify method'
    if !$method;