view release on metacpan or  search on metacpan

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

package Amazon::S3::Lite;

use strict;
use warnings;

use Amazon::Signature4::Lite;
use Amazon::S3::Lite::Credentials;
use Amazon::S3::Lite::Logger;
use Carp qw(croak);
use Data::Dumper;
use Digest::MD5 qw(md5_base64 md5);
use English qw(-no_match_vars);
use HTTP::Tiny;
use List::Util qw(pairs);
use MIME::Base64 qw(encode_base64);
use Scalar::Util qw(blessed openhandle);
use URI::Escape qw(uri_escape_utf8);
use XML::Twig;

use Readonly;
Readonly our $TRUE  => 1;
Readonly our $FALSE => 0;

our $VERSION = '1.2.2';

########################################################################
sub new {
########################################################################
  my ( $class, @args ) = @_;

  my $options = ref $args[0] ? $args[0] : {@args};

  my $self = bless $options, $class;

  $self->{host}    //= 's3.amazonaws.com';
  $self->{secure}  //= $TRUE;
  $self->{timeout} //= 30;
  $self->{region}  //= 'us-east-1';

  $self->_init_logger;
  $self->_init_credentials;
  $self->_init_ua;

  return $self;
}

########################################################################
# Logger setup
# Priority: caller-supplied object -> Log::Log4perl (if available) ->
#           minimal STDERR logger
########################################################################
sub _init_logger {
########################################################################
  my ($self) = @_;

  my $logger = $self->{logger};

  if ( $logger && blessed $logger ) {
    # Validate it quacks like a logger
    for my $method (qw(trace debug info warn error)) {
      croak "logger object must implement '$method'"
        if !$logger->can($method);
    }

    return;
  }

  my $log4perl = eval {
    require Log::Log4perl;
    1;
  };

  my $log_level = $self->{log_level} // 'warn';
  $self->{log_level} = $log_level;

  if ($log4perl) {
    if ( !Log::Log4perl->initialized ) {
      Log::Log4perl->easy_init( { level => uc $log_level } );
    }
    else {
      $self->{logger} = Log::Log4perl->get_logger(__PACKAGE__);
    }
    return;
  }

  # Fall back to minimal STDERR logger
  $self->{logger} = Amazon::S3::Lite::Logger->new( log_level => $log_level );

  return;
}

########################################################################
# Credential resolution
# Priority: explicit credentials object -> constructor args ->
#           environment variables -> Amazon::Credentials (if available)
########################################################################
sub _init_credentials {
########################################################################
  my ($self) = @_;

  # 1. Caller-supplied credentials object (duck-typed)
  if ( my $creds = $self->{credentials} ) {
    croak "credential object is not blessed.\n"
      if !blessed $creds;

    foreach (qw(aws_access_key_id aws_secret_access_key token)) {
      my $sub = $creds->can($_) // $creds->can("get_$_");

      croak "credentials object must implement $_ or get_$_\n"
        if !$sub;
    }

    $self->{credentials} = $creds;

    return;
  }

  # 2. Explicit constructor args
  if ( $self->{aws_access_key_id} && $self->{aws_secret_access_key} ) {
    $self->{credentials} = Amazon::S3::Lite::Credentials->new(
      aws_access_key_id     => delete $self->{aws_access_key_id},
      aws_secret_access_key => delete $self->{aws_secret_access_key},
      token                 => delete $self->{token},
    );
    return;
  }

  # 3. Environment variables
  if ( $ENV{AWS_ACCESS_KEY_ID} && $ENV{AWS_SECRET_ACCESS_KEY} ) {
    $self->{credentials} = Amazon::S3::Lite::Credentials->new(
      aws_access_key_id     => $ENV{AWS_ACCESS_KEY_ID},
      aws_secret_access_key => $ENV{AWS_SECRET_ACCESS_KEY},
      token                 => $ENV{AWS_SESSION_TOKEN},
    );
    return;
  }

  # 4. Amazon::Credentials (covers IAM roles, ECS task roles,
  #    ~/.aws/credentials, etc.)
  if ( eval { require Amazon::Credentials; 1 } ) {
    $self->{credentials} = Amazon::Credentials->new;
    return;
  }

  croak 'No AWS credentials found. Supply aws_access_key_id/'
    . 'aws_secret_access_key, set AWS_ACCESS_KEY_ID/'
    . 'AWS_SECRET_ACCESS_KEY environment variables, '
    . 'or install Amazon::Credentials for IAM role support.';
}

########################################################################
# HTTP::Tiny instance - one per object, keep-alive enabled
########################################################################
sub _init_ua {
########################################################################
  my ($self) = @_;

  $self->{ua} = HTTP::Tiny->new(
    timeout    => $self->{timeout},
    verify_SSL => $self->{secure},
  );

  return;
}

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

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 ) = @_;