PUT results from the CPAN

Amazon-S3-Lite

########################################################################
  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;
  my $url    = $self->_endpoint($bucket);
  my %headers;

  $headers{'x-amz-acl'} = $options{acl} if $options{acl};

  my $content = q{};

  # us-east-1 is the implicit default â€” sending LocationConstraint for it
  # causes an error. All other regions require it.
  if ( $region ne 'us-east-1' ) {
    $content
      = sprintf '<CreateBucketConfiguration '
      . 'xmlns="http://s3.amazonaws.com/doc/2006-03-01/">'
      . '<LocationConstraint>%s</LocationConstraint>'
      . '</CreateBucketConfiguration>',
      $region;
    $headers{'Content-Type'}   = 'application/xml';
    $headers{'Content-Length'} = length $content;
  }

  my $response = $self->_request( 'PUT', $url, \%headers, $content, {}, $region );

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

  return 1;
}

########################################################################
# list_buckets()
#
# Lists all buckets owned by the authenticated user.
#
# Note: ListBuckets is a global S3 operation and must always be signed
# against us-east-1 regardless of the region the object was constructed
# with. We pass the region override directly to the signer.
#
# Returns a hashref:
#   {
#     owner_id   => '...',
#     owner_name => '...',
#     buckets    => [
#       { name => '...', creation_date => '...' },
#       ...
#     ],
#   }
########################################################################
sub list_buckets {
########################################################################
  my ($self) = @_;

  my $url = $self->_endpoint . q{/};  # ensure canonical URI is / not empty

  my $response = $self->_request( 'GET', $url, {}, q{}, {}, 'us-east-1' );

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

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

########################################################################
# Parse ListAllMyBucketsResult XML
########################################################################
########################################################################
sub _parse_list_buckets {
########################################################################
  my ( $self, $xml ) = @_;

  my ( @buckets, $owner_id, $owner_name );

  XML::Twig->new(
    twig_handlers => {
      'Bucket' => sub {
        my ( $t, $node ) = @_;
        push @buckets,
          {
          name          => $node->first_child_text('Name'),
          creation_date => $node->first_child_text('CreationDate'),
          };
      },
      'Owner' => sub {
        my ( $t, $node ) = @_;
        $owner_id   = $node->first_child_text('ID');
        $owner_name = $node->first_child_text('DisplayName');
      },
    }
  )->parse($xml);

  return {
    owner_id   => $owner_id,
    owner_name => $owner_name,
    buckets    => \@buckets,
  };
}

########################################################################
# copy_object( %args )
#
# Copies an object within or between buckets, entirely server-side.
# Required: src_bucket, src_key, dst_bucket, dst_key
#
# Note: S3 can return HTTP 200 with an XML error body for copy operations
# that fail mid-transfer. This method detects and croaks on that case.
#
# Returns a hashref: { etag => '...', last_modified => '...' }
########################################################################
sub copy_object {
########################################################################
  my ( $self, %args ) = @_;

  for my $required (qw( src_bucket src_key dst_bucket dst_key )) {
    croak "$required is required"
      if !defined $args{$required} || !length $args{$required};
  }

  my $url = $self->_endpoint( $args{dst_bucket}, $args{dst_key} );

  # x-amz-copy-source: /src-bucket/encoded-key
  my $copy_source = '/' . $args{src_bucket} . '/' . _encode_key( $args{src_key} );

  my %headers = (
    'x-amz-copy-source'       => $copy_source,
    'x-amz-tagging-directive' => 'COPY',
    'Content-Length'          => 0,
  );

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

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

  # S3 can return HTTP 200 with an XML error body for copies that fail
  # after the headers have been sent. Detect this by checking the root
  # element â€” a success response has <CopyObjectResult>, an error has <Error>.
  return $self->_parse_copy_response( $response->{content}, 'copy_object' );
}

########################################################################
# Parse CopyObjectResult XML, detecting the 200-with-error edge case
########################################################################
########################################################################
sub _parse_copy_response {
########################################################################
  my ( $self, $xml, $context ) = @_;

  my $twig = XML::Twig->new->parse($xml);
  my $root = $twig->root->tag;

  if ( $root eq 'Error' ) {
    my $code = $twig->root->first_child_text('Code');
    my $msg  = $twig->root->first_child_text('Message');
    croak sprintf '%s failed: %s - %s', $context, $code, $msg;
  }

  my $etag = $twig->root->first_child_text('ETag') // q{};
  $etag =~ s/\A"|"\z//gxsm;

  return {
    etag          => $etag,
    last_modified => $twig->root->first_child_text('LastModified'),
  };
}

########################################################################
# put_object( $bucket, $key, $data, %options )
#
# Stores an object in S3. $data may be a scalar string, a reference to
# a scalar, or an open filehandle / IO::File object.
#
# Options: content_type, content_length, metadata (hashref), acl
#
# Returns the ETag of the stored object. Croaks on failure.
########################################################################
sub put_object {
########################################################################
  my ( $self, $bucket, $key, $data, %options ) = @_;

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

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

  my %headers;
  $headers{'Content-Type'} = $options{content_type} // 'application/octet-stream';

  # x-amz-acl header
  if ( $options{acl} ) {
    $headers{'x-amz-acl'} = $options{acl};
  }

  # User metadata â€” prefix bare keys with x-amz-meta-
  if ( my $meta = $options{metadata} ) {
    for my $k ( keys %{$meta} ) {
      my $header = $k =~ /^x-amz-meta-/xsm ? $k : "x-amz-meta-$k";
      $headers{$header} = $meta->{$k};
    }
  }

  my $body;

  if ( openhandle($data) || ( blessed($data) && $data->can('read') ) ) {
    # --- Filehandle path ---
    my $content_length = $options{content_length};

    # Try to stat the handle for real files; suppress warning on
    # in-memory handles (IO::Scalar etc.) that have no underlying fd
    if ( !defined $content_length ) {
      my $fd = eval { fileno($data) };
      if ( defined $fd && $fd >= 0 ) {
        my @st = stat $data;
        $content_length = $st[7] if @st && defined $st[7];
      }
    }

    croak 'content_length is required for in-memory filehandles'
      if !defined $content_length;

    $headers{'Content-Length'} = $content_length;

    # Wrap filehandle in a code ref for HTTP::Tiny streaming
    my $chunk_size = 1024 * 64;  # 64KB chunks
    $body = sub {
      my $buf;
      my $n = read( $data, $buf, $chunk_size );
      return $buf if $n;
      return q{};
    };
  }
  elsif ( ref $data eq 'SCALAR' ) {
    # --- Scalar ref path ---
    $body                      = ${$data};
    $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
########################################################################
########################################################################

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

    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 )
#
# Convenience wrapper that auto-paginates list_objects_v2 and returns
# a flat list of all matching object hashrefs.
# delimiter is ignored â€” use list_objects_v2 directly for that.
########################################################################
sub list_all_objects_v2 {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  # delimiter is meaningless here â€” silently remove it
  delete $options{delimiter};

  my @all_objects;
  my $continuation_token;

  while ($TRUE) {
    if ( defined $continuation_token ) {
      $options{continuation_token} = $continuation_token;
    }

    my $result = $self->list_objects_v2( $bucket, %options );

    last if !$result;  # 404 / empty bucket

    push @all_objects, @{ $result->{objects} };

    last if !$result->{is_truncated};

    $continuation_token = $result->{next_continuation_token};
  }

  return @all_objects;
}

########################################################################
sub put_bucket_notification_configuration {
########################################################################
  my ( $self, $bucket, %options ) = @_;

  my $xml = $self->_create_notification_configuration( $bucket, %options );

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

  my %headers = (
    'Content-Type'   => 'application/xml',
    'Content-Length' => length $xml,
    'Content-MD5'    => encode_base64( md5($xml), q{} ),
  );

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

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

  return $TRUE;
}

########################################################################
sub remove_bucket_notification_configuration {
########################################################################
  my ( $self, $bucket ) = @_;

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

  my $xml = <<'END_XML';
<NotificationConfiguration xmlns="http://s3.amazonaws.com/doc/2006-03-01/"/>
END_XML

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

  my %headers = (
    'Content-Type'   => 'application/xml',
    'Content-Length' => length $xml,
    'Content-MD5'    => encode_base64( md5($xml), q{} ),
  );

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

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

  return $TRUE;
}

########################################################################
sub get_bucket_notification_configuration {
########################################################################
  my ( $self, $bucket ) = @_;

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

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

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

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

  my $rsp = $self->_parse_notification_configuration( $response->{content} );

  $self->logger->debug(
    Dumper(
      [ response        => $response,
        parsed_response => $rsp
      ]
    )
  );

  return $rsp;
}

########################################################################
sub _parse_notification_configuration {
########################################################################
  my ( $self, $xml ) = @_;

  my @configs;

  my $handler = sub {
    my ( $t, $node ) = @_;

    my @events = map { $_->text } $node->children('Event');

    my @filter_rules;

    if ( my $filter = $node->first_child('Filter') ) {
      if ( my $s3key = $filter->first_child('S3Key') ) {
        for my $rule ( $s3key->children('FilterRule') ) {
          push @filter_rules,
            {
            name  => $rule->first_child_text('Name'),
            value => $rule->first_child_text('Value'),
            };
        }
      }
    }

    push @configs,

( run in 1.445 second using v1.01-cache-2.11-cpan-13bb782fe5a )