• Your recent searches
Amazon-S3-Lite
2 results

 view release on metacpan or  search on metacpan

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

sub _request {
########################################################################
  my ( $self, $method, $url, $headers, $content, $extra, $region ) = @_;

  $region  //= $self->region;
  $headers //= {};
  $content //= q{};
  $extra   //= {};

  my $content_is_coderef = ref $content eq 'CODE';

  # sign — returns merged headers ready for HTTP::Tiny
  my $signed = $self->_signer($region)->sign(
    method  => $method,
    url     => $url,
    headers => $headers,
    payload => $content_is_coderef ? q{} : $content,
  );

  # HTTP::Tiny sets Host itself — remove to avoid duplicate header error
  delete $signed->{host};

  $self->logger->debug("$method $url");

  my $options = { headers => $signed };

  if ( length $content || $content_is_coderef ) {
    $options->{content} = $content;
  }

  if ( $extra->{data_callback} ) {
    $options->{data_callback} = $extra->{data_callback};
  }

  my $response = $self->ua->request( $method, $url, $options );

  $self->logger->debug( sprintf 'Response: %s %s', $response->{status}, $response->{reason} );

  return $response;
}

########################################################################
# head_object( $bucket, $key )
#
# Fetches metadata for an object without retrieving the body.
# Returns undef if the key does not exist (404).
# Returns a hashref with content_type, content_length, etag,
# last_modified, and metadata (x-amz-meta-* headers).
########################################################################
sub head_object {
########################################################################
  my ( $self, $bucket, $key ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url      = $self->_endpoint( $bucket, $key );
  my $response = $self->_request( 'HEAD', $url );

  return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
    if _is_not_found($response);

  $self->_croak_on_error( $response, 'head_object' );

  return $self->_extract_object_metadata( $response->{headers} );
}

########################################################################
# Extract the standard object metadata hashref from a response headers
# hash. Used by both head_object and get_object.
########################################################################
sub _extract_object_metadata {
########################################################################
  my ( $self, $headers ) = @_;

  my $etag = $headers->{etag};
  $etag =~ s/\A"|"\z//gxsm if defined $etag;

  # Collect x-amz-meta-* headers, stripping the prefix from the key
  my %metadata;
  for my $name ( keys %{$headers} ) {
    if ( $name =~ /^x-amz-meta-(.+)$/xsm ) {
      $metadata{$1} = $headers->{$name};
    }
  }

  return {
    content_type   => $headers->{'content-type'},
    content_length => $headers->{'content-length'} + 0,
    etag           => $etag,
    last_modified  => $headers->{'last-modified'},
    metadata       => \%metadata,
  };
}

########################################################################
# get_object( $bucket, $key, %options )
#
# Fetches an object from S3. Options:
#   range    => 'bytes=0-1023'   partial fetch
#   filename => '/tmp/foo'       stream body to disk; omits content key
#
# Returns undef on 404.
# Returns a hashref with content_type, content_length, etag,
# last_modified, metadata, and content (unless filename is used).
########################################################################
sub get_object {
########################################################################
  my ( $self, $bucket, $key, %options ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url = $self->_endpoint( $bucket, $key );

  my %headers;
  $headers{Range} = $options{range} if defined $options{range};

  my $filename = $options{filename};
  my $extra    = {};

  if ( defined $filename ) {
    # Open the destination file before making the request so we catch
    # permission errors early, before network round-trip
    open my $fh, '>', $filename
      or croak "cannot open '$filename' for writing: $!";

    $extra->{data_callback} = sub {
      my ($data) = @_;
      print {$fh} $data
        or croak "write to '$filename' failed: $!";
    };

    my $response = $self->_request( 'GET', $url, \%headers, q{}, $extra );

    close $fh
      or croak "close of '$filename' failed: $!";

    return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
      if _is_not_found($response);

    $self->_croak_on_error( $response, 'get_object' );

    # Return metadata only — content is on disk
    return $self->_extract_object_metadata( $response->{headers} );
  }

  # In-memory path
  my $response = $self->_request( 'GET', $url, \%headers );

  return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
    if _is_not_found($response);

  $self->_croak_on_error( $response, 'get_object' );

  my $result = $self->_extract_object_metadata( $response->{headers} );
  $result->{content} = $response->{content};

  return $result;
}

########################################################################
# delete_object( $bucket, $key, %options )
#
# Deletes an object from S3. Options:
#   version_id => $vid    delete a specific version
#
# Returns true on success. Note S3 returns 204 for both successful
# deletes and deletes of non-existent keys — no distinction is made.
# Croaks on network or server errors.
########################################################################
sub delete_object {
########################################################################
  my ( $self, $bucket, $key, %options ) = @_;

  croak 'bucket is required' if !defined $bucket || !length $bucket;
  croak 'key is required'    if !defined $key    || !length $key;

  my $url = $self->_endpoint( $bucket, $key );

  if ( defined $options{version_id} ) {
    $url .= '?versionId=' . uri_escape_utf8( $options{version_id} );
  }

  my $response = $self->_request( 'DELETE', $url );

  $self->_croak_on_error( $response, 'delete_object' );

  return 1;
}

########################################################################
# create_bucket( $bucket, %options )
#
# Creates a new S3 bucket.
#
# us-east-1 is the S3 default region — the CreateBucketConfiguration
# body must NOT be sent for us-east-1 (S3 will error). All other regions
# require it with LocationConstraint set to the target region.
#
# Options: acl, region
#
# Returns true on success. Croaks on failure.
########################################################################
sub create_bucket {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  croak 'bucket is required'
    if !defined $bucket || !length $bucket;

  my $region = $options{region} // $self->region;

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

    $headers{'Content-Length'} = length $body;
    $headers{'Content-MD5'}    = encode_base64( md5($body), q{} );
  }
  else {
    # --- Plain scalar path ---
    $body                      = $data;
    $headers{'Content-Length'} = length $body;
    $headers{'Content-MD5'}    = encode_base64( md5($body), q{} );
  }

  my $response = $self->_request( 'PUT', $url, \%headers, $body );

  $self->_croak_on_error( $response, 'put_object' );

  my $etag = $response->{headers}{etag};
  $etag =~ s/\A"|"\z//gxsm if defined $etag;

  return $etag;
}

########################################################################
# list_objects_v2( $bucket, %options )
#
# Lists objects in a bucket using the S3 ListObjectsV2 API.
# Returns a hashref with keys: bucket, prefix, key_count, max_keys,
# is_truncated, next_continuation_token, objects, common_prefixes.
########################################################################
sub list_objects_v2 {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  croak 'bucket is required'
    if !defined $bucket || !length $bucket;

  # Map our option names to S3 query parameter names
  my %param_map = (
    prefix             => 'prefix',
    delimiter          => 'delimiter',
    max_keys           => 'max-keys',
    continuation_token => 'continuation-token',
    start_after        => 'start-after',
  );

  my %params = ( 'list-type' => '2' );

  for my $opt ( keys %param_map ) {
    if ( defined $options{$opt} ) {
      $params{ $param_map{$opt} } = $options{$opt};
    }
  }

  # Build query string
  my $query = join q{&}, map { uri_escape_utf8($_) . q{=} . uri_escape_utf8( $params{$_} ) }
    sort keys %params;

  my $url = $self->_endpoint($bucket) . q{?} . $query;

  my $response = $self->_request( 'GET', $url );

  return undef ## no critic (Subroutines::ProhibitExplicitReturnUndef)
    if _is_not_found($response);

  $self->_croak_on_error( $response, 'list_objects_v2' );

  return $self->_parse_list_objects_v2( $response->{content} );
}

########################################################################
# Parse the XML body of a ListObjectsV2 response
########################################################################
########################################################################
sub _parse_list_objects_v2 {
########################################################################
  my ( $self, $xml ) = @_;

  my ( @objects, @common_prefixes );
  my ( $bucket, $prefix, $key_count, $max_keys, $is_truncated, $next_token );

  XML::Twig->new(
    twig_handlers => {
      'Name'                    => sub { $bucket       = $_[1]->text },
      'ListBucketResult/Prefix' => sub { $prefix       = $_[1]->text },
      'KeyCount'                => sub { $key_count    = $_[1]->text + 0 },
      'MaxKeys'                 => sub { $max_keys     = $_[1]->text + 0 },
      'IsTruncated'             => sub { $is_truncated = $_[1]->text eq 'true' ? 1 : 0 },
      'NextContinuationToken'   => sub { $next_token   = $_[1]->text },
      'Contents'                => sub {
        my ( $t, $node ) = @_;
        my $etag = $node->first_child_text('ETag') // q{};
        $etag =~ s/\A"|"\z//gxsm;
        push @objects,
          {
          key           => $node->first_child_text('Key'),
          size          => $node->first_child_text('Size') + 0,
          last_modified => $node->first_child_text('LastModified'),
          etag          => $etag,
          storage_class => $node->first_child_text('StorageClass'),
          };
        $t->purge;  # free memory as we go - important for large listings
      },
      'CommonPrefixes' => sub {
        my ( $t, $node ) = @_;
        push @common_prefixes, $node->first_child_text('Prefix');
      },
    }
  )->parse($xml);

  return {
    bucket                  => $bucket,
    prefix                  => $prefix,
    key_count               => $key_count,
    max_keys                => $max_keys,
    is_truncated            => $is_truncated,
    next_continuation_token => $next_token,
    objects                 => \@objects,
    common_prefixes         => \@common_prefixes,
  };
}

########################################################################
# list_all_objects_v2( $bucket, %options )

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


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

  return \%TEMPLATES
    if %TEMPLATES;

  local $RS = undef;

  my $data = <DATA>;
  $data =~ s/\A(.*?)^=pod.*\z/$1/xsm;

  my $t             = q{};
  my $template_name = q{};

  foreach my $line ( split /\n/xsm, $data ) {
    if ( $line =~ /^:(.*)$/xsm ) {
      if ( $template_name && $t ) {
        $TEMPLATES{$template_name} = $t;
      }
      $t             = q{};
      $template_name = $1;
      next;
    }

    $t .= "$line\n";
  }

  $TEMPLATES{$template_name} = $t;

  return \%TEMPLATES;
}

########################################################################
sub _resolve {
########################################################################
  my ( $self, $template, %data ) = @_;

  my $output = $template;

  foreach my $p ( pairs %data ) {
    my ( $k, $v ) = @{$p};

    $output =~ s/[@]\Q$k\E[@]/$v/xsmg;
  }

  return $output;
}

########################################################################
# Error checking helpers
########################################################################
sub _is_success {
########################################################################
  return $_[0]->{status} =~ /\A2\d{2}\z/;
}

########################################################################
sub _is_not_found {
########################################################################
  return $_[0]->{status} == 404;
}

########################################################################
sub _croak_on_error {
########################################################################
  my ( $self, $response, $context ) = @_;

  return if _is_success($response);

  my ( $status, $reason ) = @{$response}{qw(status reason)};

  # Attempt to extract S3 error message from XML body
  my $detail = q{};

  if ( $response->{content} && $response->{content} =~ /<\?xml/xsm ) {
    my ($code) = $response->{content} =~ m{<Code>([^<]+)</Code>}xsm;
    my ($msg)  = $response->{content} =~ m{<Message>([^<]+)</Message>}xsm;

    if ( $code || $msg ) {
      $detail = " - $code: $msg";
    }
  }

  croak sprintf '%s failed: HTTP %s %s%s', $context, $status, $reason, $detail;
}

1;

## no critic (RequirePodSections)

__DATA__
:filters
<Filter>
  <S3Key>
    @filter_rules@
  </S3Key>
</Filter>
:filter-rule
<FilterRule>
  <Name>@filter_name@</Name>
  <Value>@filter@</Value>
</FilterRule>
:event
<Event>@event@</Event>
:lambda-event
<NotificationConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
  <CloudFunctionConfiguration>
    <Id>@id@</Id>
    <CloudFunction>@lambda_arn@</CloudFunction>
    @events@
    @filters@
  </CloudFunctionConfiguration>
</NotificationConfiguration>
:sqs-event
<NotificationConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/">
  <QueueConfiguration>
    <Id>@id@</Id>
    <Queue>@queue_arn@</Queue>



( run in 2.685 seconds using v1.01-cache-2.11-cpan-9581c071862 )