Amazon-S3-2.0.2/0000755000175100017510000000000015103436527012601 5ustar rlauerrlauerAmazon-S3-2.0.2/META.json0000664000175100017510000000573215103436527014233 0ustar rlauerrlauer{ "abstract" : "Perl interface to AWS S3 API", "author" : [ "Rob Lauer " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Amazon-S3", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.64", "File::ShareDir::Install" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64", "File::ShareDir::Install" : "0" } }, "runtime" : { "requires" : { "Class::Accessor::Fast" : "0", "Digest::HMAC_SHA1" : "0", "Digest::MD5::File" : "0", "HTTP::Date" : "0", "IO::Scalar" : "0", "JSON::PP" : "0", "LWP" : "0", "LWP::Protocol::https" : "0", "LWP::UserAgent::Determined" : "0", "List::Util" : "1.5", "Net::Amazon::Signature::V4" : "0", "Net::HTTP" : "0", "Pod::Markdown" : "0", "Readonly" : "0", "URI" : "0", "URI::Escape" : "0", "XML::Simple" : "0", "perl" : "5.010000" } }, "test" : { "requires" : { "Digest::MD5::File" : "0.08", "Test::More" : "1.302190", "Test::Output" : "1.033" } } }, "provides" : { "Amazon::S3" : { "file" : "lib/Amazon/S3.pm", "version" : "v2.0.2" }, "Amazon::S3::Bucket" : { "file" : "lib/Amazon/S3/Bucket.pm", "version" : "v2.0.2" }, "Amazon::S3::BucketV2" : { "file" : "lib/Amazon/S3/BucketV2.pm", "version" : "v2.0.2" }, "Amazon::S3::Constants" : { "file" : "lib/Amazon/S3/Constants.pm", "version" : "v2.0.2" }, "Amazon::S3::Logger" : { "file" : "lib/Amazon/S3/Logger.pm", "version" : "v2.0.2" }, "Amazon::S3::Signature::V4" : { "file" : "lib/Amazon/S3/Signature/V4.pm", "version" : "0" }, "Amazon::S3::Util" : { "file" : "lib/Amazon/S3/Util.pm", "version" : "0" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "rlauer6@comcast.net", "web" : "http://github.com/rlauer6/perl-amazon-s3/issues" }, "homepage" : "http://github.com/rlauer6/perl-amazon-s3", "repository" : { "type" : "git", "url" : "git://github.com/rlauer6/perl-amazon-s3.git", "web" : "http://github.com/rlauer6/perl-amazon-s3" } }, "version" : "v2.0.2", "x_serialization_backend" : "JSON::PP version 4.16" } Amazon-S3-2.0.2/META.yml0000664000175100017510000000336615103436527014064 0ustar rlauerrlauer--- abstract: 'Perl interface to AWS S3 API' author: - 'Rob Lauer ' build_requires: Digest::MD5::File: '0.08' ExtUtils::MakeMaker: '6.64' File::ShareDir::Install: '0' Test::More: '1.302190' Test::Output: '1.033' configure_requires: ExtUtils::MakeMaker: '6.64' File::ShareDir::Install: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Amazon-S3 no_index: directory: - t - inc provides: Amazon::S3: file: lib/Amazon/S3.pm version: v2.0.2 Amazon::S3::Bucket: file: lib/Amazon/S3/Bucket.pm version: v2.0.2 Amazon::S3::BucketV2: file: lib/Amazon/S3/BucketV2.pm version: v2.0.2 Amazon::S3::Constants: file: lib/Amazon/S3/Constants.pm version: v2.0.2 Amazon::S3::Logger: file: lib/Amazon/S3/Logger.pm version: v2.0.2 Amazon::S3::Signature::V4: file: lib/Amazon/S3/Signature/V4.pm version: '0' Amazon::S3::Util: file: lib/Amazon/S3/Util.pm version: '0' requires: Class::Accessor::Fast: '0' Digest::HMAC_SHA1: '0' Digest::MD5::File: '0' HTTP::Date: '0' IO::Scalar: '0' JSON::PP: '0' LWP: '0' LWP::Protocol::https: '0' LWP::UserAgent::Determined: '0' List::Util: '1.5' Net::Amazon::Signature::V4: '0' Net::HTTP: '0' Pod::Markdown: '0' Readonly: '0' URI: '0' URI::Escape: '0' XML::Simple: '0' perl: '5.010000' resources: bugtracker: http://github.com/rlauer6/perl-amazon-s3/issues homepage: http://github.com/rlauer6/perl-amazon-s3 repository: git://github.com/rlauer6/perl-amazon-s3.git version: v2.0.2 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Amazon-S3-2.0.2/ChangeLog0000644000175100017510000004462315103436526014363 0ustar rlauerrlauerMon Jun 10 08:33:31 2024 Rob Lauer [2.0.2]: * src/main/perl/lib/Amazon/S3/Bucket.pm.in - issue #16 - Small fix for error when retrieving keys with charset spec in content-type * src/main/perl/lib/Amazon/S3.pm.in - issue #17 - Fixed a bug where encryption was impossible in special cases * VERSION: bump * README.md: version Mon Jun 10 07:30:59 2024 Rob Lauer [0.66]: * NEWS.md: updated * .gitignore: *.log * src/main/perl/run-test: new from test.localstack * src/main/perl/S3TestUtils.pm (set_s3_host): AMAZON_S3_SKIP_ACLS, not SKIP_PERMISSIONS * src/main/perl/t/01-api.t - likewise (like_acl_allrusers_read): - dump flag * src/main/perl/t/04-list-buckets.t: whitespace * src/main/perl/t/06-list-multipart-uploads.t - ignore case on status header (LocalStack <> AWS) Mon Apr 22 15:14:36 2024 Rob Lauer [2.0.1]: * VERSION: 2.0.1 * NEWS.md: notes on version 2 * README.md: generated * src/main/perl/lib/Amazon/S3/BucketV2.pm.in - pod tweaks and additions - whitespace Tue Dec 26 07:58:33 2023 Rob Lauer [0.66]: * README.md: generated * src/main/perl/lib/Amazon/S3/Constants.pm.in - + $HTTP_NO_CONTENT, $HTTP_PARTIAL_CONTENT * src/main/perl/lib/Amazon/S3/Bucket.pm.in (upload_part_of_multipart_upload): refactored, use create_api_uri() (get_key_v2): new (get_key): support list or hashref as args include uri_params (_get_key): refactored (get_key_filename): refactored, accept hash of args * src/main/perl/lib/Amazon/S3.pm.in - pod tweaks - refactoring, use methods from Amazon::S3::Util - some support for express one-zone (use_express_one_zone): new (add_bucket): refactored to use _add_bucket() (_add_bucket): new (list_directory_buckets): new (list_object_versions): refactored using create_api_uri() (signer): support for express one-zone (_make_request) - set Content-Length header - only set content if we have data * src/main/perl/lib/Amazon/S3/Util.pm.in (create_query_string): refactored (create_api_uri): new * s3-perl.pl - new options, availability-zone, modified-since (list_directory_buckets): new (create_bucket): support expresss one-zone (list_object_versions): new >>>>>>> master Thu Nov 30 13:56:08 2023 Rob Lauer [0.66]: * VERSION: bump * NEWS.md: updated * README.md: generated * src/main/perl/lib/Amazon/S3.pm.in: pod updates * README.md: generated * src/main/perl/lib/Amazon/S3/BucketV2.pm.in: new * src/main/perl/lib/Amazon/S3/Util.pm.in: new * src/main/perl/lib/Makefile.am: add above to build * src/main/perl/lib/Amazon/S3.pm.in - refactoring - updated pod (add_bucket): allow additional headers (delete_bucket): likewise (list_bucket) - likewise - allow query parameters (_validate_acl_short): refactored (_make_request): refactored (adjust_region): refactored (_do_http): refactored (_send_request_expect_nothing): refactored (_send_request_expect_nothing_probed): refactored (_remember_errors): refactored (_add_auth_header): refactored (_merge_meta): refactored (_encode): refactored * src/main/perl/lib/Amazon/S3/Bucket.pm.in - refactored (new): refactored (_uri): refactored (add_key): allow for additional headers (upload_mulipart_object) - refactored - allow additional headers (initiate_multipart_upload): likewise (upload_part_of_multipart_upload): likewise (make_xml_document_simple): replaced with _create_multipart_upload_request() (get_key): call _get_key() now (_get_key) - renamed from get_key() - allow additional headers (copy_object): refactored (delete_keys) - refactored - allow additional headers * src/main/perl/lib/Amazon/S3/Constants.pm.in - + $AWS_METADATA_BASE_URL - + markers for ListObjectVersions * src/main/perl/t/01-api.t - create private bucket first, then delete public access block (list_all) - refactored - allow additional headers (get_acl) - refactored - allow additional headers (get_location_constraint): refactored (_create_multipart_upload_request): new Tue Nov 28 17:42:44 2023 Rob Lauer [0.65]: * src/main/perl/lib/Amazon/S3.pm.in (signer) - get token from creds object always Thu Jul 20 07:47:36 2023 Rob Lauer [0.64 - get_location_constraint() ]: * VERSION: bump * NEWS.md: updated * src/main/perl/lib/Amazon/S3/Bucket.pm.in (get_location_constraint): content already decoded Mon Apr 17 08:07:13 2023 Rob Lauer [0.63 - pass -key to Crypt::CBC]: * src/mai/perl/lib/Amazon/S3.pm.in (_decrypt): pass encryption key as -key and -pass Fri Apr 14 08:29:32 2023 Rob Lauer [0.62 - list_bucket, buckets]: * VERSION: bump * NEWS.md: updated * README.md: generated * src/main/perl/lib/Amazon/S3.pm.in - minor pod updates (buckets) - return if null or error, not _remember_errors() (list_bucket): likewise * src/main/perl/t/01-api: diag before bailing out * src/main/perl/t/04-list-buckets.t - added test for listing non-existent bucket * src/main/perl/lib/Amazon/S3/Bucket.pm.in - minor pod tweak, alphabetize methods Wed Mar 29 08:12:48 2023 Rob Lauer [0.61 - delete_keys(), refactoring]: * s3-perl.pl - added ASCII table output, refactored * NEWS.md: updated * src/main/perl/lib/Amazon/S3.pm.in - some perlcritic refactoring - pod updates (list_bucket): use different markers for v1, v2 (list_bucket_all) - throw $EVAL_ERROR "The server has stopped responding" (_make_request): light refactoring (_sendrequest): accept keep_root and pass to _xpc_of_content() (_xpc_of_content): NoAttr => $TRUE (_remember_errors): return false if no error * src/main/perl/lib/Amazon/S3/Bucket.pm.in - some perlcritic refactoring (add_key): check reftype properly (set_acl): send conten-length * src/main/perl/lib/Amazon/S3/Constants.pm.in - additional constants for refactoring - move subs from t/01-api.t to S3TestUtils.pm * src/main/perl/t/01-api.t: refactoring * src/main/perl/t/02-logger.t: likewise * src/main/perl/t/03-region.t: likewise * src/main/perl/t/04-list-buckets.t: likewise * src/main/perl/t/05-multipart-upload.t: likewise * src/main/perl/t/06-list-multipart-uploads.t: likewise * src/main/perl/test.localstack: converted to bash script * src/main/perl/S3TestUtils.pm: new * cpan/buildspec.yml: add above to distribution Mon Mar 27 10:47:54 2023 Rob Lauer [0.61 - delete_keys()]: * VERSION: bump * NEWS.md: updated * README.md: generated * configure.ac: add check for make-cpan-dist.pl * cpan/Makefile.am: use automake var for above * src/main/perl/lib/Amazon/S3/.pm.in (_make_request): don't encode the query string twice (_send_request): precendence wrt regexp * src/main/perl/lib/Amazon/S3/Bucket.pm.in (delete_keys): new (_format_delete_keys): new * src/main/perl/lib/Amazon/S3/Constants.pm.in - new constants to support delete_keys() method * src/main/perl/lib/Makefile.am: stop make on error * src/main/perl/t/01-api.t: added tests for delete_keys() * src/main/perl/test.localstack: save logs Fri Feb 10 07:47:22 2023 Rob Lauer > [0.60 - logging]: * VERSION: bump * NEWS.md: updated * bootstrap: support M.rr style versions * src/main/perl/lib/Amazon/S3.pm.in - removed all end of block indicators inserted by perltidy (new) - only consider 'debug' flag when internal logger used * src/main/perl/lib/Amazon/S3.pm.in (new): new * configure.ac - fix email addres - remove -Wall to prevent warning during configure * s3-perl.pl: new * src/main/perl/test.localstack: new * .gitignore: added some of the files created by `make cpan` Wed Jan 25 11:54:59 2023 Rob Lauer [0.59 - copy_object]: * VERSION: bump * README.md: generated * src/main/perl/lib/Amazon/S3.pm.in - minor pod changes * src/main/perl/lib/Amazon/S3/Bucket.pm.in (copy_object): new * src/main/perl/Makefile.am: corrected comments re: make test * cpan/Makefile.am: PROJECT_HOME [unit tests]: * src/main/perl/t/01-api.t - added unit test for copy_object() * src/main/perl/t/04-list-buckets.t - use AMAZON_S3_HOST from environment not S3_HOST * README-TESTING.md - corrected way make test invoked Mon Dec 19 09:25:04 2022 Rob Lauer [0.58 - min perl required]: * VERSION: bump * cpan/buildspec.yml: min perl 5.10 * cpan/requires: JSON::PP Sat Dec 3 14:09:29 2022 Rob Lauer [0.57 - rpm packaging]: * VERSION: bump * perl-Amazon-S3.spec.in (Requires): Net::Amazon::Signature::V4 * src/main/perl/lib/Makefile.am - install Amazon::S3::Signature::V4 to correct directory Tue Nov 29 10:39:43 2022 Rob Lauer [0.56 - minor bug, 0.55 issues #8]: * buildspec.yml: files should be relative to project home * VERSION: bump * NEWS.md: updated * README-TESTING.md: more documentation * Makefile.am: rpm, not rpmbuild directory * src/main/perl/Makefile.am: comments re: testing * src/main/perl/t/04-list-buckets.t - enable debug mode if $ENV{DEBUG} - dump response if error * src/main/perl/lib/Amazon/S3.pm.in - pod tweaks (new) - set -key and -pass for legacy Crypt::CBC (buckets): avoid return explicit undef (list_bucket) - remove undefined hash members from input (_make_request) - use URI to set path, host, port if domain bucket ame * src/main/perl/lib/Amazon/S3/Bucket.pm.in (last_response): typo, should be last_response(), not last_reponse() (_uri): minor refactoring for clarity (add_key): likewise, return a return code (_add_key): minor refactoring (get_key): minor refactoring, do not return explicit undef (delete_key): minor refactoring for clarity (set_acl): likewise (get_acl) - likewise - return undef if 404 rather than croak * docker-compose.yml: new Mon Aug 1 15:44:04 2022 Rob Lauer [0.55 - bucket region]: * requires: latest version of most modules * src/main/perl/lib/Amazon/S3.pm.in - pod tweaks, corrections - don't specify a minimum version of perl (new): set default region to 'us-east-1', again (get_bucket_location): $bucket, not $self (buckets) - verify region option - pass hash of options and region to _send_request (add_bucket) - do not add region constraint if us-east-1 - refactored, send region to _send_request_expect_nothing (delete_bucket): likewise refactored (list_bucket): likewise refactored (_make_request): use region() method of signer (_do_http): debug statements, set last_reponse, reset_errors (_do_http_no_redirect): likewise (_send_request_expect_nothing): likewise (_send_request_expect_nothing_probed) - accept hash argument - debug statements - croak if redirect, but no Location (error): new (reset_errors): new (_remember_error): set error * src/main/perl/lib/Amazon/S3/Bucket.pm.in - pod tweaks, corrections (new) - + logger attribute - + verify_region attribute, verify region if true (_uri): remove leading '/' (add_key): correct region if 301 response (upload_multipart_object): debug messages (upload_part_of_multipart_upload): likewise (complete_multipart_upload): likewise (get_key): remove redundant debug message (delete_key): pass region to _send_request_expect_nothing (set_acl): likewise * src/main/perl/t/01-api.t: do not bailout on early tests (error): new (last_response): new * src/main/perl/t/03-region.t: default region is us-east-1 Fri Jul 22 14:47:30 2022 Rob Lauer [0.55 - testing, revert to XML::Simple]: * src/main/perl/t/01-api.t: remove /r option in regex * src/main/perl/t/04-list-buckets: likewise * src/main/perl/lib/Amazon/S3.pm: use XML::Simple * src/main/perl/lib/Amazon/S3/Bucket.pm.in: likewise (make_xml_document_simple): new * src/main/perl/t/06-list-multipart-uploads.t: XML::Simple * configure.ac: remove Lib::XML, Lib::XML::Simple, add XML::Simple * cpan/requires: likewise * TODO.md: new Thu Jul 21 11:14:16 2022 Rob Lauer [0.55 - CI/CD]: * .github/workflows/build.yml: remove make cpan * README.md: generated * src/main/perl/lib/Amazon/S3.pm.in: update badge Thu Jul 21 10:53:03 2022 Rob Lauer [0.55 - CI/CD]: * .github/workflows/build.yml * README.md: generated * configure.ac: typo, IO::Scalar * cpan/requires - IO::Scalar, JSON:PP, Pod::Markdown * src/main/perl/lib/Amazon/S3.pm.in: add badge * NEWS.md: update Mon Jul 18 16:27:41 2022 Rob Lauer [0.55 - regional buckets]: * NEWS.md: new * src/main/perl/lib/Amazon/S3/Constants.pm.in - + $MIN_MULTIPART_UPLOAD_CHUNK_SIZE * src/main/perl/lib/Amazon/S3.pm.in - document Signature V4 changes/implications - use new Amazon::S3::Signature::V4 object (_make_request): accept hash ref as argument (get_bucket_location): new (reset_signer_region): new * src/main/perl/lib/Amazon/S3/Bucket.pm.in - document multipart methods - send region in all _make_request calls (_send_request): check if arg is a request (new) - accept region argument - set bucket region if region not passed (upload_multipart_object): new * src/main/perl/lib/Amazon/S3/Signature/V4: new * src/main/perl/lib/Makefile.am: add above to build * src/main/perl/t/05-multpart-upload.t: new * src/main/perl/t/06-list-multpart-upload.t: new Thu Jul 14 06:34:56 2022 Rob Lauer > [0.55 - use XML::LibXML]: * VERSION: bump * src/main/perl/lib/Amazon/S3.pm.in: use XML::LibXML, not XML::Simple - perlcritic cleanups - pod cleanup (new) - cache_signer - encrypt credentials (get_default_region): new (get_aws_access_key_id): new (get_aws_secret_access_key): new (get_token): new (_decrypt): new (_encrypt): new (signer) - accesses _signer now - set default region to caller's value or default (buckets): set region to us-east-1 temporarily (debug): new convenience method for level => 'debug' (_make_request): allow disabling of domain buckets * src/main/perl/lib/Amazon/S3/Bucket.pm.in: comment tweak * src/main/perl/lib/Amazon/S3/Constant.pm.in: $DOT * src/main/perl/t/01-api.t: set $dns_bucket_names to true? * cpan/test-requires: +Test::Output * cpan/requires: -Test::Output * configure.ac - ads_PERL_MODULE XML::LibXML::Simple, XML::LibXML, Test::Output Wed Jul 13 13:09:04 2022 Rob Lauer [0.54 - merge timmullin changes]: * src/main/perl/lib/Amazon/S3.pm.in: see commit history - use XML::LibXML * src/main/perl/lib/Amazon/Bucket.pm.in: see commit history Tue Jun 21 12:57:31 2022 Rob Lauer [0.53 - unit test perl > 5.010]: * VERSION: bump * cpan/requires: sorted * src/main/perl/lib/Amazon/S3.pm.in - use 5.010 Sun Jun 19 08:19:19 2022 Rob Lauer [0.52 - specify version of List::Util required]: * cpan/requires: List::Util * cpan/Makefile.am: option of --no-core Sat Jun 18 07:05:14 2022 Rob Lauer [0.51 - unit tests]: * src/main/perl/t/02-logger.t: remove Log::Log4perl from test Fri Jun 17 09:48:16 2022 Rob Lauer [0.50 - version requirements]: * cpan/Makefile.am: --no-core * configure.ac: remove version requirements * cpan/test-requires: add without core modules * cpan/requires: remove core modules Fri Jun 17 07:21:22 2022 Rob Lauer [0.49]: * Makefile.am - make rpm - use abs_builddir - src, not dist now * configure.ac - get version from VERSION - don't treat warnings as errors - output package version - check for rpmbuild, pod2markdown, scandeps-static.pl - update dependencies * src/main/perl/lib/Amazon/S3.pm.in - new logging option - mv'd from dist/lib/Amazon/S3.pm - documenation updates - refactoring, perlcritic cleanups - use Amazon::S3::Constants - allow passing credentials class (_make_request): check dns_bucket_names option (dns_bucket_names): new (get_logger): new (level): new (get_credentials): new (new) - secure defaults to true (region): new (list_bucket_v2): new (list_bucket_all_v2): new (last_response): new * src/main/perl/lib/Amazon/S3/Bucket.pm.in - mv'd from dist/lib/Amazon/S3/Bucket.pm - revert using XML::Simple - use Amazon::S3::Constants - perlcritic cleanup - perltidy (_uri): support DNS bucket names (list_v2): new (list_all_v2): new * src/main/perl/lib/Makefile.am: new * src/main/perl/Makefile.am: new * src/main/Makefile.am: new * src/Makefile.am: new * cpan/Makfile.am: new * cpan/requires: new * cpan/test-requires: new * src/main/perl/t/01-api.t - env vars for controlling tests1 - mv'd from dist/t/01api.t - refactored test - support AWS mocking services - enable/disable regional testing - added list_vs test - create tempfile instead of using t/README * src/main/perl/t/02-logging.t: new * src/main/perl/t/03-region.t: new * src/main/perl/t/04-list-bucket.t: new * .gitignore: *.pm * ChangeLog: mv'd from dist/CHANGES * README-TESTING.md: new * README-BUILD.md: new * VERSION: new * bootstrap: new * autotools/ads_PERL_INCLUDES.m4: new * autotools/ads_PERL_LIBDIR.m4: new * autotools/ads_PERL_MODULE.m4: new * autotools/ads_PROG_PERL.m4: new * autotools/am_rpm_build_mode.m4: new * autotools/ax_am_conditional_example.m4: new * autotools/ax_deps_check.m4: new * autotools/ax_distcheck_hack.m4: new * autotools/ax_rpmbuild_check.m4: new Revision history for Perl module Amazon::S3: 0.48 Sep 17 2021 - remove leading '/' from bucket name - modify tests for not s3.amazonaws.com hosts (e.g. minio) 0.47 Feb 4 2019 - update dependencies (XML::LibXML) 0.46 Jan 19 2019 - use temporary credentials - error string - 0.45 Aug 14 2009 - Applied patch to support any S3 end points (Tokuhiro Matsuno) - Applied patches to not die when 0 or 1 buckets are return also (Tokuhiro Matsuno) 0.441 Jun 16 2008 - Added handling to get_key_filename where the key is used as the file name if one is not provided. 0.44 Jun 08 2008 - Applied patch for fixing non-xml error parsing (Harold Sinclair) - Ported changes from Net::Amazon::S3 0.42-0.44. These include: - Fix bug with storing files consisting of "0" (Martin Atkins) - Use of IO::File and binmode() to support Windows (Gabriel Weinberg) - Add exponential backoff upon temporary errors with the new retry option. (Leon Brocard) 0.41.2 Jan 20 2008 - Added documentation fixes that where causing 99-pod-coverage.t to fail. 0.411 Jan 19 2008 - initial release into CPAN - Fork of Net::Amazon::S3 0.41 - Renamed packages - Replaced XML::LibXML and XML::LibXML::XPathContext with XML::Simple - Ran perltidy over code - Removed deprecated methods from Amazon::S3 - Revised documentation and README Amazon-S3-2.0.2/README-TESTING.md0000644000175100017510000001641015103436526015174 0ustar rlauerrlauer# Testing This Module From the original documentation for `Net::Amazon::S3`... >Testing S3 is a tricky thing. Amazon wants to charge you a bit of money each time you use their service. And yes, testing counts as using. Because of this, the application's test suite by default, skips anything approaching a real test. I'm not so sure exactly how expensive creating a bucket and then reading and writing a few bytes from S3 really is nowadays. In any event, by default, the tests that actually create buckets and objects will not be executed unless you set the environment variable `AMAZON_S3_EXPENSIVE_TESTS` to some value. Testing can be controlled with additional environment variables described below. | Variable | Description | | -------- | ----------- | | `AMAZON_S3_EXPENSIVE_TESTS` | Doesn't matter what you set it to. Just has to be set | | `AWS_ACCESS_KEY_ID` | Your AWS access key | | `AWS_ACCESS_KEY_SECRET` | Your AWS sekkr1t passkey. Be forewarned that setting this environment variable on a shared system might leak that information to another user. Be careful. | | `AWS_SESSION_TOKEN` | Optional session token. | | `AMAZONS3_HOST` | Defaults to s3.amazonaws.com. Set this for example if you want to test the module against an API compatible service like minio. | | `AMAZON_S3_SKIP_ACL_TESTS` | Doesn't matter what you set it to. Just has to be set if you want to skip ACLs tests. | | `AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST` | Doesn't matter what you set it to. Just has to be set if you want to skip region constraint test. | | `AMAZON_S3_MINIO` | Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on minio. | | `AMAZON_S3_LOCALSTACK` | Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on minio. | | `AMAZON_S3_REGIONS` | Comma delimited list of regions to test | __CAUTION__ __In order to test ACLs, the test will create a public bucket and then make the bucket private. The test will perform the same kind of tests on objects. The test will also delete the bucket and the objects as well, however, stuff happens and you may be left with a public bucket or object should these tests fail.__ __Check your account to make sure the buckets and objects have been deleted. The bucket name will be have a prefix of `net-amazon-s3-test-` and a suffix of your `AWS_ACCESS_KEY_ID`.__ # Regional Constraints One of the original unit tests for this module attempted to create a bucket in the EU region to ostensibly test regional constraints and DNS based bucket names. The test would create a bucket in the default region, delete the bucket, then attempt to create a bucket with the same name in a different region. Today, this will fail consistently with a 409 error (Operation Aborted). This is due to the fact that you cannot immediately reclaim a bucket name after deletion as it may takes some time to free that bucket name in all regions. [Bucket restrictions and limitations](https://docs.aws.amazon.com/AmazonS3/latest/userguide/BucketRestrictions.html) To test regional constraints then, the current test will change the name of the bucket if it encounters a 409 error while creating the bucket. The test will then proceed to read the ACLs to determine if the constraint was successful. By default, the tests will only create a bucket in the default region (but it will check that the constraint is in place). If you want to test creation of buckets in alternate regions in addition to testing in the default region, set the environment variable `AMAZON_S3_REGIONS` to one or more comma separated regions. ``` cd src/main/perl make test AMAZON_S3_EXPENSIVE_TESTS=1 AMAZON_S3_REGIONS='eu-west-1' ``` # Credentials for Testing You should set the environment variables `AWS_ACCESS_KEY_ID` and `AWS_ACCESS_SECRET_KEY` to your AWS credential values that have the ability to create and write to buckets. If you set environment variable `AMAZON_S3_CREDENTIAL` to any value, the tests will use the `Amazon::Credentials` module to look for valid credentials in your environment, your credentials files or the instance role if you are running on an EC2. # Using S3 Mocking Services If you want to test *some* parts of this module but don't want to spend a few pennies (or don't have access to AWS credentials) you can try one of the S3 mocking services. The two of the most popular services seem to be: * [LocalStack](https://localstack.io) * [minio](https://min.io) Both of these implement a subset of the S3 API. __Note that Some tests will fail on both services (as of the writing of this document).__ To make it through the tests, try setting one or more of the environment variables above which will selectively skip some test. If you are using a mocking service, you might find it useful to set the environment variable AWS_EC2_METADATA_DISABLED to a true value. ``` export AWS_EC2_METADATA_DISABLED=true ``` This will prevent the AWS CLI from looking for metadata when you are not actually running on an EC2 instance or container. Without this variable set, the CLI attempts to access the metadata service at http://169.254.169.254/latest/meta-data/ until it eventually times out. ## Testing with LocalStack LocalStack seems to be the easiest to work with and supports a number of AWS APIs besides S3. It does not implement the full suite of APIs however. In particular, LocalStack does not enforce ACLs. Accordingly, those tests are skipped if the environment variable AMAZON_S3_LOCALSTACK is set to any value. A `docker-compose.yml` file is included now in the project. ``` version: "3.8" services: localstack: container_name: "${LOCALSTACK_DOCKER_NAME-localstack_main}" image: localstack/localstack hostname: s3 networks: default: aliases: - s3.localhost.localstack.cloud - net-amazon-s3-test-test.localhost.localstack.cloud ports: - "127.0.0.1:4510-4530:4510-4530" - "127.0.0.1:4566:4566" - "127.0.0.1:4571:4571" environment: - SERVICES=s3,ssm,secretsmanager,kms,sqs,ec2,events,sts,logs - DEBUG=${DEBUG-} - DATA_DIR=${DATA_DIR-} - LAMBDA_EXECUTOR=${LAMBDA_EXECUTOR-} - HOST_TMP_FOLDER=${TMPDIR:-/tmp/}localstack - DOCKER_HOST=unix:///var/run/docker.sock volumes: - "${LOCALSTACK_VOLUME_DIR:-./volume}:/var/lib/localstack" - "/var/run/docker.sock:/var/run/docker.sock" ``` When testing with LocalStack you'll need to set some environment variables to get through (the majority) of the tests. Environment Variable | Value | Description -------------------- | ----- | ----------- AMAZON_EXPENSIVE_TESTS | 1 | enables testing of S3 API AMAZONS3_HOST | localhost:4566 AMAZON_S3_LOCALSTACK | any | skips some tests that will fail on LocalStack AWS_ACCESS_KEY_ID | test | AWS access key for LocalStack AWS_ACCESS_KEY_SECRET | test | AWS secret access key for LocalStack In order to test domain name buckets, you will need to spoof a domain name for your bucket by setting the name of the bucket in your `/etc/hosts` file. ``` 127.0.0.1 localhost net-amazon-s3-test-test.s3.localhost.localstack.cloud ``` To run tests using LocalStack... ``` AMAZON_S3_EXPENSIVE_TESTS=1 \ AMAZON_S3_HOST=s3.localhost.localstack.cloud:4566 \ AMAZON_S3_LOCALSTACK=1 \ AWS_ACCESS_KEY_ID=test \ AWS_ACCESS_SECRET_KEY=test \ AMAZON_S3_DOMAIN_BUCKET_NAMES=1 make test ``` Amazon-S3-2.0.2/Makefile.PL0000644000175100017510000000643315103436526014560 0ustar rlauerrlauer# autogenerated by /home/rlauer/bin/make-cpan-dist.pl on Fri Nov 7 13:41:26 2025 use strict; use warnings; use ExtUtils::MakeMaker; use File::ShareDir::Install; if ( -d 'share' ) { install_share 'share'; } WriteMakefile( NAME => 'Amazon::S3', MIN_PERL_VERSION => '5.10.0', AUTHOR => 'Rob Lauer ', VERSION_FROM => 'lib/Amazon/S3.pm', ABSTRACT => 'Perl interface to AWS S3 API', LICENSE => 'perl', PL_FILES => {}, EXE_FILES => [], PREREQ_PM => { 'Class::Accessor::Fast' => '0', 'Digest::HMAC_SHA1' => '0', 'Digest::MD5::File' => '0', 'HTTP::Date' => '0', 'IO::Scalar' => '0', 'JSON::PP' => '0', 'LWP' => '0', 'LWP::Protocol::https' => '0', 'LWP::UserAgent::Determined' => '0', 'List::Util' => '1.5', 'Net::Amazon::Signature::V4' => '0', 'Net::HTTP' => '0', 'Pod::Markdown' => '0', 'Readonly' => '0', 'URI' => '0', 'URI::Escape' => '0', 'XML::Simple' => '0' }, BUILD_REQUIRES => { 'ExtUtils::MakeMaker' => '6.64', 'File::ShareDir::Install' => 0, }, CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => '6.64', 'File::ShareDir::Install' => 0, }, TEST_REQUIRES => { 'Digest::MD5::File' => '0.08', 'Test::More' => '1.302190', 'Test::Output' => '1.033' }, META_MERGE => { 'meta-spec' => { 'version' => 2 }, 'provides' => { 'Amazon::S3' => { 'file' => 'lib/Amazon/S3.pm', 'version' => '2.0.2' }, 'Amazon::S3::Bucket' => { 'file' => 'lib/Amazon/S3/Bucket.pm', 'version' => '2.0.2' }, 'Amazon::S3::BucketV2' => { 'file' => 'lib/Amazon/S3/BucketV2.pm', 'version' => '2.0.2' }, 'Amazon::S3::Constants' => { 'file' => 'lib/Amazon/S3/Constants.pm', 'version' => '2.0.2' }, 'Amazon::S3::Logger' => { 'file' => 'lib/Amazon/S3/Logger.pm', 'version' => '2.0.2' }, 'Amazon::S3::Signature::V4' => { 'file' => 'lib/Amazon/S3/Signature/V4.pm', 'version' => 'undef' }, 'Amazon::S3::Util' => { 'file' => 'lib/Amazon/S3/Util.pm', 'version' => 'undef' } }, 'resources' => { 'bugtracker' => { 'mailto' => 'rlauer6@comcast.net', 'web' => 'http://github.com/rlauer6/perl-amazon-s3/issues' }, 'homepage' => 'http://github.com/rlauer6/perl-amazon-s3', 'repository' => { 'type' => 'git', 'url' => 'git://github.com/rlauer6/perl-amazon-s3.git', 'web' => 'http://github.com/rlauer6/perl-amazon-s3' } } } ); package MY; use File::ShareDir::Install; use English qw(-no_match_vars); sub postamble { my $self = shift; my @ret = File::ShareDir::Install::postamble($self); my $postamble = join "\n", @ret; if ( -e 'postamble' ) { local $RS = undef; open my $fh, '<', 'postamble' or die "could not open postamble\n"; $postamble .= <$fh>; close $fh; } return $postamble; } 1; Amazon-S3-2.0.2/MANIFEST0000644000175100017510000000104215103436527013727 0ustar rlauerrlauerChangeLog lib/Amazon/S3.pm lib/Amazon/S3/Bucket.pm lib/Amazon/S3/BucketV2.pm lib/Amazon/S3/Constants.pm lib/Amazon/S3/Logger.pm lib/Amazon/S3/Signature/V4.pm lib/Amazon/S3/Util.pm Makefile.PL MANIFEST This list of files README-TESTING.md README.md S3TestUtils.pm t/01-api.t t/02-logger.t t/03-region.t t/04-list-buckets.t t/05-multipart-upload.t t/06-list-multipart-uploads.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Amazon-S3-2.0.2/S3TestUtils.pm0000644000175100017510000001332315103436526015306 0ustar rlauerrlauerpackage S3TestUtils; use strict; use warnings; use Data::Dumper; use English qw(-no_match_vars); use List::Util qw(any); use Readonly; use Test::More; use parent qw(Exporter); # chars Readonly our $EMPTY => q{}; Readonly our $SLASH => q{/}; # booleans Readonly our $TRUE => 1; Readonly our $FALSE => 0; # mocking services Readonly our $DEFAULT_LOCAL_STACK_HOST => 'localhost:4566'; Readonly our $DEFAULT_MINIO_HOST => 'localhost:9000'; # http codes Readonly our $HTTP_OK => '200'; Readonly our $HTTP_FORBIDDEN => '403'; Readonly our $HTTP_CONFLICT => '409'; # misc Readonly our $TEST_BUCKET_PREFIX => 'net-amazon-s3-test'; # create a domain name for this if AMAZON_S3_DNS_BUCKET_NAMES is true Readonly our $MOCK_SERVICES_BUCKET_NAME => $TEST_BUCKET_PREFIX . '-test'; Readonly our $PUBLIC_READ_POLICY => < http://acs.amazonaws.com/groups/global/AllUsers READ END_OF_POLICY our %EXPORT_TAGS = ( constants => [ qw( $EMPTY $SLASH $TRUE $FALSE $DEFAULT_LOCAL_STACK_HOST $HTTP_OK $HTTP_CONFLICT $HTTP_FORBIDDEN $TEST_BUCKET_PREFIX $MOCK_SERVICES_BUCKET_NAME $PUBLIC_READ_POLICY ) ], subs => [ qw( add_keys check_test_bucket create_bucket get_s3_service is_aws make_bucket_name set_s3_host ) ], ); our @EXPORT_OK = map { @{ $EXPORT_TAGS{$_} } } ( keys %EXPORT_TAGS ); ######################################################################## sub make_bucket_name { ######################################################################## return $MOCK_SERVICES_BUCKET_NAME if !is_aws(); my $suffix = eval { require Data::UUID; return lc Data::UUID->new->create_str(); }; $suffix //= join $EMPTY, map { ( 'A' .. 'Z', 'a' .. 'z', 0 .. 9 )[$_] } map { int rand 62 } ( 0 .. 15 ); my $bucket_name = sprintf '%s-%s', $TEST_BUCKET_PREFIX, $suffix; return $bucket_name; } ######################################################################## sub is_aws { ######################################################################## return ( $ENV{AMAZON_S3_LOCALSTACK} || $ENV{AMAZON_S3_MINIO} ) ? $FALSE : $TRUE; } ######################################################################## sub check_test_bucket { ######################################################################## my ($s3) = @_; # list all buckets that I own my $response = eval { return $s3->buckets; }; if ( $EVAL_ERROR || !$response ) { diag( Dumper( [ error => [ $response, $s3->err, $s3->errstr, $s3->error ] ] ) ); BAIL_OUT($EVAL_ERROR); } my ( $owner_id, $owner_displayname ) = @{$response}{qw(owner_id owner_displayname)}; my $bucket_name = make_bucket_name(); my @buckets = map { $_->{bucket} } @{ $response->{buckets} }; if ( any { $_ =~ /$bucket_name/xsm } @buckets ) { BAIL_OUT( 'test bucket already exists: ' . $bucket_name ); } return ( $owner_id, $owner_displayname ); } ######################################################################## sub set_s3_host { ######################################################################## my $host = $ENV{AMAZON_S3_HOST}; $host //= 's3.amazonaws.com'; ## no critic (RequireLocalizedPunctuationVars) if ( $ENV{AMAZON_S3_LOCALSTACK} ) { $host //= $DEFAULT_LOCAL_STACK_HOST; $ENV{AWS_ACCESS_KEY_ID} = 'test'; $ENV{AWS_SECRET_ACCESS_KEY} = 'test'; $ENV{AMAZON_S3_SKIP_ACLS} = $TRUE; $ENV{AMAZON_S3_EXPENSIVE_TESTS} = $TRUE; } elsif ( exists $ENV{AMAZON_S3_MINIO} ) { $host //= $DEFAULT_MINIO_HOST; $ENV{AMAZON_S3_SKIP_ACLS} = $TRUE; $ENV{AMAZON_S3_EXPENSIVE_TESTS} = $TRUE; $ENV{AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST} = $TRUE; } return $host; } ######################################################################## sub get_s3_service { ######################################################################## my ($host) = @_; my $s3 = eval { if ( $ENV{AMAZON_S3_CREDENTIALS} ) { require Amazon::Credentials; return Amazon::S3->new( { credentials => Amazon::Credentials->new, host => $host, secure => is_aws(), dns_bucket_names => $ENV{AMAZON_S3_DNS_BUCKET_NAMES}, level => $ENV{DEBUG} ? 'trace' : 'error', } ); } else { return Amazon::S3->new( { aws_access_key_id => $ENV{AWS_ACCESS_KEY_ID}, aws_secret_access_key => $ENV{AWS_SECRET_ACCESS_KEY}, token => $ENV{AWS_SESSION_TOKEN}, host => $host, secure => is_aws(), dns_bucket_names => $ENV{AMAZON_S3_DNS_BUCKET_NAMES}, level => $ENV{DEBUG} ? 'trace' : 'error', } ); } }; return $s3; } ######################################################################## sub create_bucket { ######################################################################## my ( $s3, $bucket_name ) = @_; $bucket_name = $SLASH . $bucket_name; my $bucket_obj = eval { return $s3->add_bucket( { bucket => $bucket_name } ); }; return $bucket_obj; } ######################################################################## sub add_keys { ######################################################################## my ( $bucket_obj, $max_keys, $prefix ) = @_; $prefix //= q{}; foreach my $key ( 1 .. $max_keys ) { my $keyname = sprintf '%stesting-%02d.txt', $prefix, $key; my $value = 'T'; $bucket_obj->add_key( $keyname, $value ); } return $max_keys; } 1; Amazon-S3-2.0.2/t/0000755000175100017510000000000015103436527013044 5ustar rlauerrlauerAmazon-S3-2.0.2/t/01-api.t0000644000175100017510000004517715103436526014235 0ustar rlauerrlauer#!/usr/bin/env perl -w use warnings; use strict; use lib qw( . .. lib); use Data::Dumper; use Digest::MD5::File qw(file_md5_hex); use English qw(-no_match_vars); use File::Temp qw( tempfile ); use List::Util qw(any); use Test::More; use S3TestUtils qw(:constants :subs); our @REGIONS = (undef); if ( $ENV{AMAZON_S3_REGIONS} ) { push @REGIONS, split /\s*,\s*/xsm, $ENV{AMAZON_S3_REGIONS}; } my $host = set_s3_host(); my $bucket_name = make_bucket_name(); if ( !$ENV{AMAZON_S3_EXPENSIVE_TESTS} ) { plan skip_all => 'Testing this module for real costs money.'; } else { plan tests => 85 * scalar(@REGIONS) + 2; } ######################################################################## # BEGIN TESTS ######################################################################## use_ok('Amazon::S3'); use_ok('Amazon::S3::Bucket'); my $s3 = get_s3_service($host); if ( !$s3 || $EVAL_ERROR ) { BAIL_OUT( 'could not initialize s3 object: ' . $EVAL_ERROR ); } # bail if test bucket already exists our ( $OWNER_ID, $OWNER_DISPLAYNAME ) = check_test_bucket($s3); for my $location (@REGIONS) { # this test formerly used the same bucket name for both regions, # however when you delete a bucket it may take up to an hour for # that bucket name to be available again when using AWS as the host. # To test the bucket constraint policy below then we need to use a # different bucket name. The old comment here was... # # > create a bucket # > make sure it's a valid hostname for EU testing # > we use the same bucket name for both in order to force one or the # > other to have stale DNS $s3->region($location); $host = $s3->host; my $bucket_name_raw; my $bucket_name; my $bucket_obj; my $bucket_suffix; while ($TRUE) { $bucket_name_raw = make_bucket_name(); $bucket_name = $SLASH . $bucket_name_raw; $bucket_obj = eval { $s3->add_bucket( { bucket => $bucket_name, acl_short => 'private', location_constraint => $location } ); }; if ( $EVAL_ERROR || !$bucket_obj ) { diag( Dumper( [ $EVAL_ERROR, $s3->err, $s3->errstr, $s3->error ] ) ); } last if $bucket_obj; # 409 indicates bucket name not yet available... if ( $s3->last_response->code ne $HTTP_CONFLICT ) { BAIL_OUT("could not create $bucket_name"); } $bucket_suffix = '-2'; } is( ref $bucket_obj, 'Amazon::S3::Bucket', sprintf 'create bucket (%s) in %s ', $bucket_name, $location // 'DEFAULT_REGION' ) or BAIL_OUT("could not create bucket $bucket_name"); SKIP: { if ( $ENV{AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST} ) { skip 'No region constraints', 1; } is( $bucket_obj->get_location_constraint, $location ); } SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} || !$bucket_obj ) { skip 'ACLs only for Amazon S3', 3; } eval { $s3->delete_public_access_block($bucket_obj); }; BAIL_OUT($EVAL_ERROR) if $EVAL_ERROR; my $rsp = $bucket_obj->set_acl( { acl_short => 'public-read' } ); like_acl_allusers_read($bucket_obj); $rsp = $bucket_obj->set_acl( { acl_short => 'private' } ); ok( $rsp, 'set_acl - private' ) or diag( Dumper( [ response => $rsp, $s3->err, $s3->errstr, $s3->error ] ) ); unlike_acl_allusers_read($bucket_obj); } # another way to get a bucket object (does no network I/O, # assumes it already exists). Read Amazon::S3::Bucket. $bucket_obj = $s3->bucket($bucket_name); is( ref $bucket_obj, 'Amazon::S3::Bucket' ); # fetch contents of the bucket # note prefix, marker, max_keys options can be passed in my $response = $bucket_obj->list(); if ( !$response ) { BAIL_OUT( sprintf 'could not list bucket: %s', $bucket_name ); } SKIP: { if ( !$response ) { skip 'invalid response to "list"'; } is( $response->{bucket}, $bucket_name_raw ) or BAIL_OUT( Dumper [$response] ); ok( !$response->{prefix} ); ok( !$response->{marker}, ); is( $response->{max_keys}, 1_000 ) or BAIL_OUT( Dumper [$response] ); is( $response->{is_truncated}, 0 ); is_deeply( $response->{keys}, [] ) or diag( Dumper( [$response] ) ); is( undef, $bucket_obj->get_key('non-existing-key') ); } my $keyname = 'testing.txt'; { # Create a publicly readable key, then turn it private with a short acl. # This key will persist past the end of the block. my $value = 'T'; $bucket_obj->add_key( $keyname, $value, { content_type => 'text/plain', 'x-amz-meta-colour' => 'orange', acl_short => 'public-read', } ); my $url = $s3->dns_bucket_names ? "http://$bucket_name_raw.$host/$keyname" : "http://$host/$bucket_name/$keyname"; SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} ) { skip 'ACLs only for Amazon S3', 3; } is_request_response_code( $url, $HTTP_OK, 'can access the publicly readable key' ); like_acl_allusers_read( $bucket_obj, $keyname ); ok( $bucket_obj->set_acl( { key => $keyname, acl_short => 'private' } ) ); } SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} ) { skip 'Mocking service does not enforce ACLs', 1; } is_request_response_code( $url, $HTTP_FORBIDDEN, 'cannot access the private key' ); } SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} ) { skip 'ACLs only for Amazon S3', 5; } unlike_acl_allusers_read( $bucket_obj, $keyname ); ok( $bucket_obj->set_acl( { key => $keyname, acl_xml => acl_xml_from_acl_short('public-read') } ) ); is_request_response_code( $url, $HTTP_OK, 'can access the publicly readable key after acl_xml set' ); like_acl_allusers_read( $bucket_obj, $keyname ); ok( $bucket_obj->set_acl( { key => $keyname, acl_xml => acl_xml_from_acl_short('private') } ) ); } SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} ) { skip 'Mocking service does not enforce ACLs', 2; } is_request_response_code( $url, $HTTP_FORBIDDEN, 'cannot access the private key after acl_xml set' ); unlike_acl_allusers_read( $bucket_obj, $keyname ); } } { # Create a private key, then make it publicly readable with a short # acl. Delete it at the end so we're back to having a single key in # the bucket. my $keyname2 = 'testing2.txt'; my $value = 'T2'; $bucket_obj->add_key( $keyname2, $value, { content_type => 'text/plain', 'x-amz-meta-colour' => 'blue', acl_short => 'private', } ); my $url = $s3->dns_bucket_names ? "http://$bucket_name_raw.$host/$keyname2" : "http://$host/$bucket_name/$keyname2"; SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} ) { skip 'Mocking service does not enforce ACLs', 1; } is_request_response_code( $url, $HTTP_FORBIDDEN, 'cannot access the private key' ); } SKIP: { if ( $ENV{AMAZON_S3_SKIP_ACLS} ) { skip 'ACLs only for Amazon S3', 4; } unlike_acl_allusers_read( $bucket_obj, $keyname2 ); ok( $bucket_obj->set_acl( { key => $keyname2, acl_short => 'public-read' } ) ); is_request_response_code( $url, $HTTP_OK, 'can access the publicly readable key' ); like_acl_allusers_read( $bucket_obj, $keyname2 ); } $bucket_obj->delete_key($keyname2); } # list keys in the bucket foreach my $v ( 1 .. 2 ) { if ( $v eq '2' ) { $response = $bucket_obj->list_v2( { 'fetch-owner' => 'true' } ); } else { $response = $bucket_obj->list; } if ( !$response ) { BAIL_OUT( $s3->err . ': ' . $s3->errstr ); } is( $response->{bucket}, $bucket_name_raw, sprintf 'list(%s) - %s', $v, $bucket_name ); ok( !$response->{prefix}, "list($v) - prefix empty" ) or diag( Dumper [$response] ); ok( !$response->{marker}, "list($v) - marker empty" ); is( $response->{max_keys}, 1_000, "list($v) - max keys 1000 " ); is( $response->{is_truncated}, 0, "list($v) - is_truncated 0" ) or diag( Dumper [$response] ); my @keys = @{ $response->{keys} }; is( @keys, 1, "list($v) - keys == 1 " ) or diag( Dumper \@keys ); my $key = $keys[0]; is( $key->{key}, $keyname, "list($v) - keyname" ); # the etag is the MD5 of the value is( $key->{etag}, 'b9ece18c950afbfa6b0fdbfa4ff731d3', "list($v) - etag" ); is( $key->{size}, 1, "list($v) - size == 1" ); SKIP: { if ( $ENV{AMAZON_S3_SKIP_OWNER_ID_TEST} ) { skip 'mocking service has different owner for bucket', 1; } is( $key->{owner_id}, $OWNER_ID, "list($v) - owner id " ) or diag( Dumper [$key] ); } is( $key->{owner_displayname}, $OWNER_DISPLAYNAME, "list($v) - owner display name" ); } # You can't delete a bucket with things in it ok( !$bucket_obj->delete_bucket(), 'delete bucket' ); $bucket_obj->delete_key($keyname); # now play with the file methods my ( $fh, $lorem_ipsum ) = tempfile(); print {$fh} <<'EOT'; Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. EOT close $fh; my $lorem_ipsum_md5 = file_md5_hex($lorem_ipsum); my $lorem_ipsum_size = -s $lorem_ipsum; $keyname .= '2'; $bucket_obj->add_key_filename( $keyname, $lorem_ipsum, { content_type => 'text/plain', 'x-amz-meta-colour' => 'orangy', } ); $response = $bucket_obj->get_key($keyname); is( $response->{content_type}, 'text/plain', 'get_key - content_type' ); like( $response->{value}, qr/Lorem\sipsum/xsm, 'get_key - Lorem ipsum' ); is( $response->{etag}, $lorem_ipsum_md5, 'get_key - etag' ) or diag( Dumper [$response] ); is( $response->{'x-amz-meta-colour'}, 'orangy', 'get_key - metadata' ); is( $response->{content_length}, $lorem_ipsum_size, 'get_key - content_type' ); eval { unlink $lorem_ipsum }; $response = $bucket_obj->get_key_filename( $keyname, undef, $lorem_ipsum ); is( $response->{content_type}, 'text/plain', 'get_key_filename - content_type' ); is( $response->{value}, $EMPTY, 'get_key_filename - value empty' ); is( $response->{etag}, $lorem_ipsum_md5, 'get_key_filename - etag == md5' ); is( file_md5_hex($lorem_ipsum), $lorem_ipsum_md5, 'get_key_filename - file md5' ); is( $response->{'x-amz-meta-colour'}, 'orangy', 'get_key_filename - metadata' ); is( $response->{content_length}, $lorem_ipsum_size, 'get_key_filename - content_length' ); # before we delete this key... my $copy_result = $bucket_obj->copy_object( key => "$keyname.bak", source => "$keyname", ); isa_ok( $copy_result, 'HASH', 'copy_object returns a hash reference' ); $response = $bucket_obj->list; ok( ( grep {"$keyname.bak"} @{ $response->{keys} } ), 'found the copy' ); if ( !$ENV{AMAZON_S3_KEEP_BUCKET} ) { $bucket_obj->delete_key($keyname); $bucket_obj->delete_key("$keyname.bak"); } # try empty files $keyname .= '3'; $bucket_obj->add_key( $keyname, $EMPTY ); $response = $bucket_obj->get_key($keyname); is( $response->{value}, $EMPTY, 'empty object - value empty' ); is( $response->{etag}, 'd41d8cd98f00b204e9800998ecf8427e', 'empty object - etag' ); is( $response->{content_type}, 'binary/octet-stream', 'empty object - content_type' ); is( $response->{content_length}, 0, 'empty object - content_length == 0' ); $bucket_obj->delete_key($keyname); # fetch contents of the bucket # note prefix, marker, max_keys options can be passed in $response = $bucket_obj->list or die $s3->err . ': ' . $s3->errstr; $bucket_name =~ s/^\///xsm; is( $response->{bucket}, $bucket_name, 'delete key from bucket - ' . $bucket_name ); ok( !$response->{prefix}, 'delete key from bucket - prefix empty' ); ok( !$response->{marker}, 'delete key from bucket - marker empty' ); is( $response->{max_keys}, 1_000, 'delete key from bucket - max keys 1000' ); is( $response->{is_truncated}, 0, 'delete key from bucket - is_truncated 0' ); is_deeply( $response->{keys}, [], 'delete key from bucket - empty list of keys' ); ###################################################################### # delete multiple keys from bucket # TODO: test deleting specific versions # SKIP: { if ( $ENV{AMAZON_S3_KEEP_BUCKET} ) { skip 'keeping bucket', 9; } $keyname = 'foo-'; for ( 1 .. 8 ) { $bucket_obj->add_key( "$keyname$_", $EMPTY ); } $response = $bucket_obj->list or die $s3->err . ': ' . $s3->errstr; my @key_list = @{ $response->{keys} }; is( 8, scalar @key_list, 'wrote 8 keys for delete_keys() test' ); ###################################################################### # quietly delete version keys - first two ###################################################################### my $delete_rsp = $bucket_obj->delete_keys( { quiet => 1, keys => [ map { $_->{key} } @key_list[ ( 0, 1 ) ] ] } ); ok( !$delete_rsp, 'delete_keys() quiet response - empty' ) or BAIL_OUT( 'could not delete quietly ' . Dumper( [ response => $delete_rsp, last_request => $s3->last_request, last_response => $s3->last_response, ] ) ); $response = $bucket_obj->list or die $s3->err . ': ' . $s3->errstr; is( scalar @{ $response->{keys} }, -2 + scalar(@key_list), 'delete versioned keys' ); shift @key_list; shift @key_list; ###################################################################### # delete list of keys - next two keys ###################################################################### $delete_rsp = $bucket_obj->delete_keys( map { $_->{key} } @key_list[ ( 0, 1 ) ] ); ok( $delete_rsp, 'delete_keys() response' ); $response = $bucket_obj->list or die $s3->err . ': ' . $s3->errstr; is( scalar @{ $response->{keys} }, -2 + scalar(@key_list), 'delete list of keys' ); shift @key_list; shift @key_list; ###################################################################### # delete array of keys - next two keys ##################################################################### $delete_rsp = $bucket_obj->delete_keys( map { $_->{key} } @key_list[ ( 0, 1 ) ] ); ok( $delete_rsp, 'delete_keys() response' ); $response = $bucket_obj->list or die $s3->err . ': ' . $s3->errstr; is( scalar @{ $response->{keys} }, -2 + scalar(@key_list), 'delete array of keys' ); shift @key_list; shift @key_list; ###################################################################### # callback - last two keys ###################################################################### $delete_rsp = $bucket_obj->delete_keys( sub { my $key = shift @key_list; return ( $key->{key} ); } ); ok( $delete_rsp, 'delete_keys() response' ); $response = $bucket_obj->list or die $s3->err . ': ' . $s3->errstr; is( scalar @{ $response->{keys} }, 0, 'delete keys from callback' ) or diag( Dumper( [ response => $response, key_list => \@key_list ] ) ); # # delete multiple keys from bucket ###################################################################### } SKIP: { if ( $ENV{AMAZON_S3_KEEP_BUCKET} ) { skip 'keeping bucket', 1; } ok( $bucket_obj->delete_bucket(), 'delete bucket' ); } } # see more docs in Amazon::S3::Bucket # local test methods ######################################################################## sub is_request_response_code { ######################################################################## my ( $url, $code, $message ) = @_; my $request = HTTP::Request->new( 'GET', $url ); my $response = $s3->ua->request($request); is( $response->code, $code, $message ) or diag( Dumper( [ response_code => $response ] ) ); return; } ######################################################################## sub like_acl_allusers_read { ######################################################################## my ( $bucket_obj, $keyname, $dump ) = @_; my $message = acl_allusers_read_message( 'like', $bucket_obj, $keyname ); my $acl = $bucket_obj->get_acl($keyname); diag( Dumper( [ acl => $acl ] ) ) if $dump; like( $acl, qr/AllUsers.+READ/xsm, $message ) or diag( Dumper( [ acl => $acl ] ) ); return; } ######################################################################## sub unlike_acl_allusers_read { ######################################################################## my ( $bucket_obj, $keyname ) = @_; my $message = acl_allusers_read_message( 'unlike', $bucket_obj, $keyname ); my $acl = $bucket_obj->get_acl($keyname); unlike( $bucket_obj->get_acl($keyname), qr/AllUsers.+READ/xsm, $message ) or diag( Dumper( [ acl => $acl ] ) ); return; } ######################################################################## sub acl_allusers_read_message { ######################################################################## my ( $like_or_unlike, $bucket_obj, $keyname ) = @_; my $message = sprintf '%s_acl_allusers_read: %s', $like_or_unlike, $bucket_obj->bucket; if ($keyname) { $message .= " - $keyname"; } return $message; } ######################################################################## sub acl_xml_from_acl_short { ######################################################################## my ($acl_short) = @_; $acl_short //= 'private'; my $public_read = $acl_short eq 'public-read' ? $PUBLIC_READ_POLICY : $EMPTY; my $policy = <<"END_OF_POLICY"; $OWNER_ID $OWNER_DISPLAYNAME $OWNER_ID $OWNER_DISPLAYNAME FULL_CONTROL $public_read END_OF_POLICY return $policy; } 1; Amazon-S3-2.0.2/t/03-region.t0000644000175100017510000000172115103436526014734 0ustar rlauerrlauer#!/usr/bin/perl -w ## no critic use warnings; use strict; use lib qw(lib); use English qw{-no_match_vars}; use Test::More; plan tests => 7; use_ok('Amazon::S3'); my $s3 = Amazon::S3->new( { aws_access_key_id => 'test', aws_secret_access_key => 'test', log_level => $ENV{DEBUG} ? 'debug' : undef, } ); ok( $s3->region, 'us-east-1' ); is( $s3->host, 's3.us-east-1.amazonaws.com', 'default host is s3.us-east-1.amazonaws.com' ); $s3 = Amazon::S3->new( { aws_access_key_id => 'test', aws_secret_access_key => 'test', region => 'us-west-2', log_level => $ENV{DEBUG} ? 'debug' : undef, } ); is( $s3->region, 'us-west-2', 'region is set' ); is( $s3->host, 's3.us-west-2.amazonaws.com', 'host is modified during creation' ); $s3->region('us-east-1'); is( $s3->region, 'us-east-1', 'region is set' ); is( $s3->host, 's3.us-east-1.amazonaws.com', 'host is modified when region changes' ); Amazon-S3-2.0.2/t/04-list-buckets.t0000644000175100017510000001401715103436526016065 0ustar rlauerrlauer#!/usr/bin/perl -w ## no critic use warnings; use strict; use lib qw(. .. lib); use English qw(-no_match_vars); use S3TestUtils qw(:constants :subs); use Test::More; use Data::Dumper; my $host = set_s3_host(); if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) { plan skip_all => 'Testing this module for real costs money.'; } else { plan tests => 11; } ######################################################################## # BEGIN TESTS ######################################################################## use_ok('Amazon::S3'); use_ok('Amazon::S3::Bucket'); my $s3 = get_s3_service($host); my $bucket_name = make_bucket_name(); my $bucket_obj = create_bucket( $s3, $bucket_name ); ok( ref $bucket_obj, 'created bucket - ' . $bucket_name ); if ( $EVAL_ERROR || !$bucket_obj ) { BAIL_OUT( $s3->err . ": " . $s3->errstr ); } my $bad_bucket = $s3->bucket( { bucket => 'does-not-exists' } ); my $response = $bad_bucket->list( { bucket => $bad_bucket } ); ok( !defined $response, 'undef returned on non-existent bucket' ); like( $bad_bucket->errstr, qr/does\snot\sexist/xsm, 'errstr populated' ) or diag( Dumper( [ response => $response, errstr => $bad_bucket->errstr, err => $bad_bucket->err, ] ) ); my $max_keys = 25; ######################################################################## subtest 'list (check response elements)' => sub { ######################################################################## my $response = $bucket_obj->list or BAIL_OUT( $s3->err . ": " . $s3->errstr ); is( $response->{bucket}, $bucket_name, 'no bucket name in list response' ) or do { diag( Dumper( [$response] ) ); BAIL_OUT( Dumper [$response] ); }; ok( !$response->{prefix}, 'no prefix in list response' ); ok( !$response->{marker}, 'no marker in list response' ); is( $response->{max_keys}, 1_000, 'max keys default = 1000' ) or BAIL_OUT( Dumper [$response] ); is( $response->{is_truncated}, 0, 'is_truncated 0' ); is_deeply( $response->{keys}, [], 'no keys in bucket yet' ) or BAIL_OUT( Dumper( [$response] ) ); }; ######################################################################## subtest 'list_all' => sub { ######################################################################## add_keys( $bucket_obj, $max_keys ); my $response = $bucket_obj->list_all; is( ref $response, 'HASH', 'response isa HASH' ) or diag( Dumper( [$response] ) ); is( ref $response->{keys}, 'ARRAY', 'keys element is an ARRAY' ) or diag( Dumper( [$response] ) ); is( @{ $response->{keys} }, $max_keys, $max_keys . ' keys returned' ) or diag( Dumper( [$response] ) ); foreach my $key ( @{ $response->{keys} } ) { is( ref $key, 'HASH', 'array element isa HASH' ) or diag( Dumper( [$key] ) ); like( $key->{key}, qr/testing-\d{2}[.]txt/xsm, 'keyname' ) or diag( Dumper( [$key] ) ); } }; ######################################################################## subtest 'list' => sub { ######################################################################## my $marker = ''; my $iter = 0; # so we don't loop forever if this is busted my @key_list; my $page_size = int $max_keys / 2; while ( $marker || !$iter ) { last if $iter++ > $max_keys; my $response = $bucket_obj->list( { 'max-keys' => $page_size, marker => $marker, delimiter => '/', } ); if ( !$response ) { BAIL_OUT( $s3->err . ": " . $s3->errstr ); } is( $response->{bucket}, $bucket_name, 'no bucket name' ); ok( !$response->{prefix}, 'no prefix' ) or diag( Dumper [$response] ); is( $response->{max_keys}, $page_size, 'max-keys ' . $page_size ); is( ref $response->{keys}, 'ARRAY' ) or BAIL_OUT( Dumper( [$response] ) ); push @key_list, @{ $response->{keys} }; $marker = $response->{next_marker}; last if !$marker; } is( @key_list, $max_keys, $max_keys . ' returned' ) or diag( Dumper( [ key_list => \@key_list ] ) ); }; ######################################################################## subtest 'list_v2' => sub { ######################################################################## my $marker = ''; my $iter = 0; # so we don't loop forever if this is busted my @key_list; my $page_size = int $max_keys / 2; while ( $marker || !$iter ) { last if $iter++ > $max_keys; my $response = $bucket_obj->list_v2( { 'max-keys' => $page_size, $marker ? ( 'marker' => $marker ) : (), delimiter => '/', } ); if ( !$response ) { BAIL_OUT( $s3->err . ": " . $s3->errstr ); } is( $response->{bucket}, $bucket_name, 'no bucket name' ); ok( !$response->{prefix}, 'no prefix' ) or diag( Dumper [$response] ); is( $response->{max_keys}, $page_size, 'max-keys ' . $page_size ); is( ref $response->{keys}, 'ARRAY' ) or BAIL_OUT( Dumper( [$response] ) ); push @key_list, @{ $response->{keys} }; $marker = $response->{next_marker}; last if !$marker; } is( @key_list, $max_keys, $max_keys . ' returned' ) or diag( Dumper( \@key_list ) ); }; ######################################################################## subtest 'list_bucket_all' => sub { ######################################################################## $max_keys += add_keys( $bucket_obj, $max_keys, 'foo/' ); my $response = $s3->list_bucket_all( { bucket => $bucket_name } ); is( ref $response, 'HASH', 'list_bucket_all response is a HASH' ); is( @{ $response->{keys} }, $max_keys, $max_keys . ' returned' ); }; ######################################################################## subtest 'list_bucket_all_v2' => sub { ######################################################################## my $response = $s3->list_bucket_all_v2( { bucket => $bucket_name } ); is( ref $response, 'HASH', 'list_bucket_all_v2 response is a HASH' ); is( @{ $response->{keys} }, $max_keys, $max_keys . ' returned' ); foreach ( @{ $response->{keys} } ) { $bucket_obj->delete_key( $_->{key} ); } }; $bucket_obj->delete_bucket; 1; Amazon-S3-2.0.2/t/05-multipart-upload.t0000644000175100017510000000756715103436526016774 0ustar rlauerrlauer#!/usr/bin/perl -w ## no critic use warnings; use strict; use lib qw( . lib); use Carp; use Data::Dumper; use Digest::MD5::File qw(file_md5_hex); use English qw{-no_match_vars}; use File::Temp qw{ tempfile }; use Test::More; use S3TestUtils qw(:constants :subs); my $host = set_s3_host(); if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) { plan skip_all => 'Testing this module for real costs money.'; } else { plan tests => 7; } use_ok('Amazon::S3'); use_ok('Amazon::S3::Bucket'); my $s3 = get_s3_service($host); if ( !$s3 ) { BAIL_OUT('could not initialize s3 object'); } my $bucket_name = make_bucket_name(); my $bucket_obj = create_bucket( $s3, $bucket_name ); ok( ref $bucket_obj, 'created bucket - ' . $bucket_name ); if ( $EVAL_ERROR || !$bucket_obj ) { BAIL_OUT( $s3->err . ": " . $s3->errstr ); } ## end if ( $EVAL_ERROR || !$bucket_obj) ######################################################################## subtest 'multipart-manual' => sub { ######################################################################## my $key = 'big-object-1'; my $id = $bucket_obj->initiate_multipart_upload($key); my $part_list = {}; my $part = 0; my $data = 'x' x ( 1024 * 1024 * 5 ); # 5 MB part my $etag = $bucket_obj->upload_part_of_multipart_upload( $key, $id, ++$part, $data, length $data ); $part_list->{$part} = $etag; $bucket_obj->complete_multipart_upload( $key, $id, $part_list ); my $head = $bucket_obj->head_key($key); ok( $head, 'uploaded file' ); ok( $head->{content_length} == 5 * 1024 * 1024, 'uploaded 1 part' ) or diag( Dumper( [$head] ) ); ok( $bucket_obj->delete_key($key) ); }; ######################################################################## subtest 'multipart-file' => sub { ######################################################################## my ( $fh, $file ) = tempfile(); my $buffer = 'x' x ( 1024 * 1024 ); # 11MB foreach ( 0 .. 10 ) { $fh->syswrite($buffer); } $fh->close; if ( !open( $fh, '<', $file ) ) { carp "could not open $file after writing"; return; } my $key = 'big-object-2'; $bucket_obj->upload_multipart_object( fh => $fh, key => $key ); close $fh; my $head = $bucket_obj->head_key($key); ok( $head, 'uploaded file' ); isa_ok( $head, 'HASH', 'head is a hash' ); ok( $head->{content_length} == 11 * 1024 * 1024, 'uploaded all parts' ); $bucket_obj->delete_key($key); unlink $file; }; ######################################################################## subtest 'multipart-2-parts' => sub { ######################################################################## my $length = 1024 * 1024 * 7; my $data = 'x' x $length; my $key = 'big-object-3'; $bucket_obj->upload_multipart_object( key => $key, data => $data ); my $head = $bucket_obj->head_key($key); isa_ok( $head, 'HASH', 'head is a hash' ); ok( $head, 'uploaded data' ); ok( $head->{content_length} == $length, 'uploaded all parts' ); $bucket_obj->delete_key($key); }; ######################################################################## subtest 'multipart-callback' => sub { ######################################################################## my $key = 'big-object-4'; my @part = ( 5, 5, 5, 1 ); my $size; $bucket_obj->upload_multipart_object( key => $key, callback => sub { return ( q{}, 0 ) unless @part; my $length = shift @part; $length *= 1024 * 1024; $size += $length; my $data = 'x' x $length; return ( \$data, $length ); } ); my $head = $bucket_obj->head_key($key); isa_ok( $head, 'HASH', 'head is a hash' ); ok( $head, 'uploaded data' ); ok( $head->{content_length} == $size, 'uploaded all parts' ); $bucket_obj->delete_key($key); }; ######################################################################## $bucket_obj->delete_bucket() or diag( $s3->errstr ); 1; Amazon-S3-2.0.2/t/02-logger.t0000644000175100017510000000452715103436526014736 0ustar rlauerrlauer#!/usr/bin/perl -w ## no critic use warnings; use strict; use lib qw(lib); use English qw{-no_match_vars}; use Test::More; use Test::Output; plan tests => 12; use_ok('Amazon::S3'); ######################################################################## sub test_levels { ######################################################################## my ($s3) = @_; print {*STDERR} "\n---[" . $s3->level . "]---\n"; $s3->get_logger->trace("test trace\n"); $s3->get_logger->debug("test debug\n"); $s3->get_logger->info("test info\n"); $s3->get_logger->warn("test warn\n"); $s3->get_logger->error("test error\n"); $s3->get_logger->fatal("test fatal\n"); return; } ## end sub test_levels ######################################################################## sub test_all_levels { ######################################################################## my ($s3) = @_; $s3->level('trace'); stderr_like( sub { test_levels($s3); }, qr/trace\n.*debug\n.*info\n.*warn\n.*error\n.*fatal\n/xsm, 'trace' ); $s3->level('debug'); stderr_like( sub { test_levels($s3); }, qr/debug\n.*info\n.*warn\n.*error\n.*fatal\n/xsm, 'debug' ); stderr_unlike( sub { test_levels($s3); }, qr/trace/, 'debug - not like trace' ); $s3->level('info'); stderr_like( sub { test_levels($s3); }, qr/info\n.*warn\n.*error\n.*fatal\n/xsm, 'info' ); stderr_unlike( sub { test_levels($s3); }, qr/trace|debug/, 'info - not like trace, debug' ); $s3->level('warn'); stderr_like( sub { test_levels($s3); }, qr/warn\n.*error\n.*fatal\n/xsm, 'warn' ); stderr_unlike( sub { test_levels($s3); }, qr/trace|debug|info/, 'warn - not like trace, debug, info' ); $s3->level('error'); stderr_like( sub { test_levels($s3); }, qr/error\n.*fatal\n/xsm, 'error' ); stderr_unlike( sub { test_levels($s3); }, qr/trace|debug|info|warn/, 'error - not like trace, debug, info, warn' ); $s3->level('fatal'); stderr_like( sub { test_levels($s3); }, qr/fatal\n/xsm, 'fatal' ); stderr_unlike( sub { test_levels($s3); }, qr/trace|debug|info|warn|error/, 'fatal - not like trace, debug, info, warn, error' ); } ## end sub test_all_levels ######################################################################## my $s3 = Amazon::S3->new( { aws_access_key_id => 'test', aws_secret_access_key => 'test', } ); test_all_levels($s3); Amazon-S3-2.0.2/t/06-list-multipart-uploads.t0000644000175100017510000000735315103436526020122 0ustar rlauerrlauer#!/usr/bin/perl -w ## no critic use warnings; use strict; use lib qw(. lib); use Carp; use Data::Dumper; use Digest::MD5::File qw(file_md5_hex); use English qw(-no_match_vars); use File::Temp qw( tempfile ); use S3TestUtils qw(:constants :subs); use Test::More; use XML::Simple qw{XMLin}; my $host = set_s3_host(); if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'} ) { plan skip_all => 'Testing this module for real costs money.'; } ## end if ( !$ENV{'AMAZON_S3_EXPENSIVE_TESTS'...}) else { plan tests => 6; } use_ok('Amazon::S3'); use_ok('Amazon::S3::Bucket'); my $s3 = get_s3_service($host); my $bucket_name = make_bucket_name(); my $bucket_obj = create_bucket( $s3, $bucket_name ); ok( ref $bucket_obj, 'created bucket - ' . $bucket_name ); if ( $EVAL_ERROR || !$bucket_obj ) { BAIL_OUT( $s3->err . ": " . $s3->errstr ); } ## end if ( $EVAL_ERROR || !$bucket_obj) my $id; my $key = 'big-object-1'; ######################################################################## subtest 'list-multipart-uploads' => sub { ######################################################################## my $upload_list = list_multipart_uploads($bucket_obj); ok( !defined $upload_list, 'no in-progress uploads' ) or diag( Dumper( [$upload_list] ) ); $id = partial_upload( $key, $bucket_obj ); $upload_list = list_multipart_uploads($bucket_obj); ok( $upload_list->{UploadId} eq $id, 'UploadId eq $id' ); }; ######################################################################## subtest 'abort-multipart-upload' => sub { ######################################################################## $bucket_obj->abort_multipart_upload( $key, $id ); my $upload_list = list_multipart_uploads($bucket_obj); ok( !defined $upload_list, 'aborted upload' ); }; ######################################################################## subtest 'abort-on-error' => sub { ######################################################################## my $id = $bucket_obj->initiate_multipart_upload($key); my $part_list = {}; my $part = 0; my $data = 'x' x ( 1024 * 1024 * 1 ); # should be too small # do this twice... foreach ( 0 .. 1 ) { my $etag = $bucket_obj->upload_part_of_multipart_upload( $key, $id, ++$part, $data, length $data ); $part_list->{$part} = $etag; } eval { $bucket_obj->complete_multipart_upload( $key, $id, $part_list ); }; ok( $EVAL_ERROR =~ /Bad Request/i, 'abort-on-error successful' ) or diag( Dumper( [ $EVAL_ERROR, $id ] ) ); $bucket_obj->abort_multipart_upload( $key, $id ); }; ######################################################################## $bucket_obj->delete_bucket() or diag( $s3->errstr ); ######################################################################## sub partial_upload { ######################################################################## my ( $key, $bucket_obj, $size_in_mb ) = @_; my $id = $bucket_obj->initiate_multipart_upload($key); my $length = ( $size_in_mb || 5 ) * 1024 * 1024; my $data = 'x' x $length; my $etag = $bucket_obj->upload_part_of_multipart_upload( $key, $id, 1, $data, $length ); return $id; } ######################################################################## sub list_multipart_uploads { ######################################################################## my ($bucket_obj) = @_; my $xml = $bucket_obj->list_multipart_uploads; ok( $xml =~ /^ $TRUE ); isa_ok( $uploads, 'HASH', 'made a hash object' ) or diag($uploads); ok( defined $uploads->{ListMultipartUploadsResult}, 'looks like a results object' ) or diag($xml); my $upload_list = $uploads->{ListMultipartUploadsResult}->{Upload}; return $upload_list; } 1; Amazon-S3-2.0.2/README.md0000644000175100017510000011766515103436526014077 0ustar rlauerrlauer# NAME Amazon::S3 - A portable client library for working with and managing Amazon S3 buckets and keys. ![Amazon::S3](https://github.com/rlauer6/perl-amazon-s3/actions/workflows/build.yml/badge.svg?event=push) # SYNOPSIS use Amazon::S3; my $aws_access_key_id = "Fill me in!"; my $aws_secret_access_key = "Fill me in too!"; my $s3 = Amazon::S3->new( { aws_access_key_id => $aws_access_key_id, aws_secret_access_key => $aws_secret_access_key, retry => 1 } ); my $response = $s3->buckets; # create a bucket my $bucket_name = $aws_access_key_id . '-net-amazon-s3-test'; my $bucket = $s3->add_bucket( { bucket => $bucket_name } ) or die $s3->err . ": " . $s3->errstr; # store a key with a content-type and some optional metadata my $keyname = 'testing.txt'; my $value = 'T'; $bucket->add_key( $keyname, $value, { content_type => 'text/plain', 'x-amz-meta-colour' => 'orange', } ); # copy an object $bucket->copy_object( source => $source, key => $new_keyname ); # list keys in the bucket $response = $bucket->list or die $s3->err . ": " . $s3->errstr; print $response->{bucket}."\n"; for my $key (@{ $response->{keys} }) { print "\t".$key->{key}."\n"; } # delete key from bucket $bucket->delete_key($keyname); # delete multiple keys from bucket $bucket->delete_keys([$key1, $key2, $key3]); # delete bucket $bucket->delete_bucket; # DESCRIPTION This documentation refers to version 2.0.2. `Amazon::S3` provides a portable client interface to Amazon Simple Storage System (S3). This module is rather dated, however with some help from a few contributors it has had some recent updates. Recent changes include implementations of: - ListObjectsV2 - CopyObject - DeleteObjects - ListObjectVersions Additionally, this module now implements Signature Version 4 signing, unit tests have been updated and more documentation has been added or corrected. Credentials are encrypted if you have encryption modules installed. _NEW!_ The `Amazon::S3` modules have been heavily refactored over the last few releases to increase maintainability and to add new features. New features include: - [Amazon::S3::BucketV2](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucketV2) This new module implements a mechanism to invoke _almost_ all of the S3 APIs using a standard calling method. The module will format your Perl objects as XML payloads and enable you to provide all of the parameters required to make an API call. Headers and URI parameters can also be passed to the methods. [Amazon::S3::BucketV2](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucketV2) is a subclass of [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket), meaning you can still invoke all of the same methods found there. See [Amazon::S3::BucketV2](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucketV2) for more details. - Limited Support for Directory Buckets This version include limited support for directory buckets. You can create and list directory buckets. _Directory buckets use the S3 Express One Zone storage class, which is recommended if your application is performance sensitive and benefits from single-digit millisecond PUT and GET latencies._ - [https://docs.aws.amazon.com/AmazonS3/latest/userguide/directory-buckets-overview.html](https://docs.aws.amazon.com/AmazonS3/latest/userguide/directory-buckets-overview.html) - list\_directory\_buckets List the directory buckets. Note this only returns a list of you directory buckets, not their contents. In order to list the contents of a directory bucket you must first create a session that establishes temporary credentials used to acces the Zonal endpoints. You then use those credentials for signing requests using the ListObjectV2 API. This process is currently **not supported** by this class. [https://docs.aws.amazon.com/AmazonS3/latest/API/API\_CreateSession.html](https://docs.aws.amazon.com/AmazonS3/latest/API/API_CreateSession.html) - add\_bucket You can add a regin and availability zone to this call in order to create a directory bucket. $bucket->add_bucket({ bucket => $bucket_name, availability_zone => 'use1-az5' }); Note that your bucket name must conform to the naming conventions for directory buckets. - [https://docs.aws.amazon.com/AmazonS3/latest/userguide/directory-buckets-overview.html#directory-buckets-name](https://docs.aws.amazon.com/AmazonS3/latest/userguide/directory-buckets-overview.html#directory-buckets-name) - Addition of version parameter for `delete_key` You can now delete a version of a key by including its verion ID. $bucket->delete_key($key, $version_id); - Methods that accept a hash reference can now accept a `headers` object that may contain any additional headers you might want to send with a request. Some of the methods that now allow you to pass a header object include: - add\_bucket - add\_key - get\_key Can now be called with a hashref which may include both a `headers` and `uri_params` object. - delete\_bucket - list\_bucket - list\_object\_versions - upload\_multipart\_object ## Comparison to Other Perl S3 Modules Other implementations for accessing Amazon's S3 service include `Net::Amazon::S3` and the `Paws` project. `Amazon::S3` ostensibly was intended to be a drop-in replacement for `Net:Amazon::S3` that "traded some performance in return for portability". That statement is no longer accurate as `Amazon::S3` may have changed the interface in ways that might break your applications if you are relying on compatibility with `Net::Amazon::S3`. However, `Net::Amazon::S3` and `Paws::S3` today, are dependent on `Moose` which may in fact level the playing field in terms of performance penalties that may have been introduced by recent updates to `Amazon::S3`. Changes to `Amazon::S3` include the use of more Perl modules in lieu of raw Perl code to increase maintainability and stability as well as some refactoring. `Amazon::S3` also strives now to adhere to best practices as much as possible. `Paws::S3` may be a much more robust implementation of a Perl S3 interface, however this module may still appeal to those that favor simplicity of the interface and a lower number of dependencies. The new [Amazon::S3::BucketV2](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucketV2) module now provides access to nearly all of the main S3 API metods. Below is the original description of the module. > Amazon S3 is storage for the Internet. It is designed to > make web-scale computing easier for developers. Amazon S3 > provides a simple web services interface that can be used to > store and retrieve any amount of data, at any time, from > anywhere on the web. It gives any developer access to the > same highly scalable, reliable, fast, inexpensive data > storage infrastructure that Amazon uses to run its own > global network of web sites. The service aims to maximize > benefits of scale and to pass those benefits on to > developers. > > To sign up for an Amazon Web Services account, required to > use this library and the S3 service, please visit the Amazon > Web Services web site at http://www.amazonaws.com/. > > You will be billed accordingly by Amazon when you use this > module and must be responsible for these costs. > > To learn more about Amazon's S3 service, please visit: > http://s3.amazonaws.com/. > > The need for this module arose from some work that needed > to work with S3 and would be distributed, installed and used > on many various environments where compiled dependencies may > not be an option. [Net::Amazon::S3](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3AS3) used [XML::LibXML](https://metacpan.org/pod/XML%3A%3ALibXML) > tying it to that specific and often difficult to install > option. In order to remove this potential barrier to entry, > this module is forked and then modified to use [XML::SAX](https://metacpan.org/pod/XML%3A%3ASAX) > via [XML::Simple](https://metacpan.org/pod/XML%3A%3ASimple). # LIMITATIONS AND DIFFERENCES WITH EARLIER VERSIONS As noted, this module is no longer a _drop-in_ replacement for `Net::Amazon::S3` and has limitations and differences that may impact the use of this module in your applications. Additionally, one of the original intents of this fork of `Net::Amazon::S3` was to reduce the number of dependencies and make it _easy to install_. Recent changes to this module have introduced new dependencies in order to improve the maintainability and provide additional features. Installing CPAN modules is never easy, especially when the dependencies of the dependencies are impossible to control and include may include XS modules. - MINIMUM PERL Technically, this module should run on versions 5.10 and above, however some of the dependencies may require higher versions of `perl` or some lower versions of the dependencies due to conflicts with other versions of dependencies...it's a crapshoot when dealing with older `perl` versions and CPAN modules. You may however, be able to build this module by installing older versions of those dependencies and take your chances that those older versions provide enough working features to support `Amazon::S3`. It is likely they do...and this module has recently been tested on version 5.10.0 `perl` using some older CPAN modules to resolve dependency issues. To build this module on an earlier version of `perl` you may need to downgrade some modules. In particular I have found this recipe to work for building and testing on 5.10.0. In this order install: HTML::HeadParser 2.14 LWP 6.13 Amazon::S3 ...other versions _may_ work...YMMV. If you do decide to run on an earlier version of `perl`, you are encouraged to run the test suite. See the ["TESTING"](#testing) section for more details. - API Signing Making calls to AWS APIs requires that the calls be signed. Amazon has added a new signing method (Signature Version 4) to increase security around their APIs. This module no longer utilizes Signature Version V2. **New regions after January 30, 2014 will only support Signature Version 4.** See ["Signature Version V4"](#signature-version-v4) below for important details. - Signature Version 4 [https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html](https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html) _IMPORTANT NOTE:_ Unlike Signature Version 2, Version 4 requires a regional parameter. This implies that you need to supply the bucket's region when signing requests for any API call that involves a specific bucket. Starting with version 0.55 of this module, `Amazon::S3::Bucket` provides a new method (`region()`) and accepts in the constructor a `region` parameter. If a region is not supplied, the region for the bucket will be set to the region set in the `account` object (`Amazon::S3`) that you passed to the bucket's new constructor. Alternatively, you can request that the bucket's new constructor determine the bucket's region for you by calling the `get_location_constraint()` method. When signing API calls, the region for the specific bucket will be used. For calls that are not regional (`buckets()`, e.g.) the default region ('us-east-1') will be used. - Signature Version 2 [https://docs.aws.amazon.com/AmazonS3/latest/userguide/RESTAuthentication.html](https://docs.aws.amazon.com/AmazonS3/latest/userguide/RESTAuthentication.html) - Multipart Upload Support There are some recently added unit tests for multipart uploads that seem to indicate this feature is working as expected. Please report any deviation from expected results if you are using those methods. For more information regarding multipart uploads visit the link below. [https://docs.aws.amazon.com/AmazonS3/latest/API/API\_CreateMultipartUpload.html](https://docs.aws.amazon.com/AmazonS3/latest/API/API_CreateMultipartUpload.html) # METHODS AND SUBROUTINES Unless otherwise noted methods will return an `undef` if an error occurs. You can get more information about the error by calling `err()` and `errstr()`. ## new Create a new S3 client object. Takes some arguments: - credentials (optional) Reference to a class (like `Amazon::Credentials`) that can provide credentials via the methods: get_aws_access_key_id() get_aws_secret_access_key() get_token() If you do not provide a credential class you must provide the keys when you instantiate the object. See below. _You are strongly encourage to use a class that provides getters. If you choose to provide your credentials to this class then they will be stored in this object. If you dump the class you will likely expose those credentials._ - aws\_access\_key\_id Use your Access Key ID as the value of the AWSAccessKeyId parameter in requests you send to Amazon Web Services (when required). Your Access Key ID identifies you as the party responsible for the request. - aws\_secret\_access\_key Since your Access Key ID is not encrypted in requests to AWS, it could be discovered and used by anyone. Services that are not free require you to provide additional information, a request signature, to verify that a request containing your unique Access Key ID could only have come from you. **DO NOT INCLUDE THIS IN SCRIPTS OR APPLICATIONS YOU DISTRIBUTE. YOU'LL BE SORRY.** _Consider using a credential class as described above to provide credentials, otherwise this class will store your credentials for signing the requests. If you dump this object to logs your credentials could be discovered._ - token An optional temporary token that will be inserted in the request along with your access and secret key. A token is used in conjunction with temporary credentials when your EC2 instance has assumed a role and you've scraped the temporary credentials from _http://169.254.169.254/latest/meta-data/iam/security-credentials_ - secure Set this to a true value if you want to use SSL-encrypted connections when connecting to S3. Starting in version 0.49, the default is true. default: true - timeout Defines the time, in seconds, your script should wait or a response before bailing. default: 30s - retry Enables or disables the library to retry upon errors. This uses exponential backoff with retries after 1, 2, 4, 8, 16, 32 seconds, as recommended by Amazon. default: off - host Defines the S3 host endpoint to use. default: s3.amazonaws.com Note that requests are made to domain buckets when possible. You can prevent that behavior if either the bucket name does not conform to DNS bucket naming conventions or you preface the bucket name with '/' or explicitly turn off domain buckets by setting `dns_bucket_names` to false. If you set a region then the host name will be modified accordingly if it is an Amazon endpoint. - region The AWS region you where your bucket is located. default: us-east-1 - buffer\_size The default buffer size when reading or writing files. default: 4096 ## signer Sets or retrieves the signer object. API calls must be signed using your AWS credentials. By default, starting with version 0.54 the module will use [Net::Amazon::Signature::V4](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3ASignature%3A%3AV4) as the signer and instantiate a signer object in the constructor. Note however, that signers need your credentials and they _will_ get stored by that class, making them susceptible to inadvertant exfiltration. You have a few options here: - 1. Use your own signer. You may have noticed that you can also provide your own credentials object forcing this module to use your object for retrieving credentials. Likewise, you can use your own signer so that this module's signer never sees or stores those credentials. - 2. Pass the credentials object and set `cache_signer` to a false value. If you pass a credentials object and set `cache_signer` to a false value, the module will use the credentials object to retrieve credentials and create a new signer each time an API call is made that requires signing. This prevents your credentials from being stored inside of the signer class. _Note that using your own credentials object that stores your credentials in plaintext is also going to expose your credentials when someone dumps the class._ - 3. Pass credentials, set `cache_signer` to a false value. Unfortunately, while this will prevent [Net::Amazon::Signature::V4](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3ASignature%3A%3AV4) from hanging on to your credentials, you credentials will be stored in the `Amazon::S3` object. Starting with version 0.55 of this module, if you have installed [Crypt::CBC](https://metacpan.org/pod/Crypt%3A%3ACBC) and [Crypt::Blowfish](https://metacpan.org/pod/Crypt%3A%3ABlowfish), your credentials will be encrypted using a random key created when the class is instantiated. While this is more secure than leaving them in plaintext, if the key is discovered (the key however is not stored in the object's hash) and the object is dumped, your _encrypted_ credentials can be exposed. - 4. Use very granular credentials for bucket access only. Use credentials that only allow access to a bucket or portions of a bucket required for your application. This will at least limit the _blast radius_ of any potential security breach. - 5. Do nothing...send the credentials, use the default signer. In this case, both the `Amazon::S3` class and the [Net::Amazon::Signature::V4](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3ASignature%3A%3AV4) have your credentials. Caveat Emptor. See also [Amazon::Credentials](https://metacpan.org/pod/Amazon%3A%3ACredentials) for more information about safely storing your credentials and preventing exfiltration. ## region Sets the region for the API calls. This will also be the default when instantiating the bucket object unless you pass the region parameter in the `bucket` method or use the `verify_region` flag that will _always_ verify the region of the bucket using the `get_location_constraint` method. default: us-east-1 ## buckets buckets([verify-region]) - verify-region (optional) `verify-region` is a boolean value that indicates if the bucket's region should be verified when the bucket object is instantiated. If set to true, this method will call the `bucket` method with `verify_region` set to true causing the constructor to call the `get_location_constraint` for each bucket to set the bucket's region. This will cause a significant decrease in the peformance of the `buckets()` method. Setting the region for each bucket is necessary since API operations on buckets require the region of the bucket when signing API requests. If all of your buckets are in the same region and you have passed a region parameter to your S3 object, then that region will be used when calling the constructor of your bucket objects. default: false Returns a reference to a hash containing the metadata for all of the buckets owned by the accout or (see below) or `undef` on error. - owner\_id The owner ID of the bucket's owner. - owner\_display\_name The name of the owner account. - buckets An array of [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) objects for the account. Returns `undef` if there are not buckets or an error occurs. ## add\_bucket add_bucket(bucket-configuration) `bucket-configuration` is a reference to a hash with bucket configuration parameters. _Note that since April of 2023, new buckets are created that block public access by default. If you attempt to set an ACL with public permissions the create operation will fail. To create a public bucket you must first create the bucket with private permissions, remove the public block and subsequently apply public permissions._ See ["delete\_public\_access\_block"](#delete_public_access_block). - bucket The name of the bucket. See [Bucket name rules](https://docs.aws.amazon.com/AmazonS3/latest/userguide/bucketnamingrules.html) for more details on bucket naming rules. - acl\_short (optional) See the set\_acl subroutine for documenation on the acl\_short options. Note that starting in April of 2023 new buckets are configured to automatically block public access. Trying to create a bucket with public permissions will fail. In order to create a public bucket you must first create a private bucket, then call the DeletePublicAccessBlock API. You can then set public permissions for your bucket using ACLs or a bucket policy. - location\_constraint - region The region the bucket is to be created in. - headers Additional headers to send with request. Returns a [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) object on success or `undef` on failure. ## bucket bucket(bucket, [region]) bucket({ bucket => bucket-name, verify_region => boolean, region => region }); Takes a scalar argument or refernce to a hash of arguments. You can pass the region or set `verify_region` indicating that you want the bucket constructor to detemine the bucket region. If you do not pass the region or set the `verify_region` value, the region will be set to the default region set in your `Amazon::S3` object. See [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) for a complete description of the `bucket` method. ## delete\_bucket Takes either a [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket) object or a reference to a hash containing: - bucket The name of the bucket to remove - region Region the bucket is located in. If not provided, the method will determine the bucket's region by calling `get_bucket_location`. Returns a boolean indicating the success or failure of the API call. Check `err` or `errstr` for error messages. Note from the [Amazon's documentation](https://docs.aws.amazon.com/AmazonS3/latest/userguide/BucketRestrictions.html) > If a bucket is empty, you can delete it. After a bucket is deleted, > the name becomes available for reuse. However, after you delete the > bucket, you might not be able to reuse the name for various reasons. > > For example, when you delete the bucket and the name becomes available > for reuse, another AWS account might create a bucket with that > name. In addition, **some time might pass before you can reuse the name > of a deleted bucket**. If you want to use the same bucket name, we > recommend that you don't delete the bucket. ## delete\_public\_access\_block delete_public_access_block(bucket-obj) Removes the public access block flag for the bucket. ## dns\_bucket\_names Set or get a boolean that indicates whether to use DNS bucket names. default: true ## err Returns the last error. Usually this is the error code returned from an API call or a short message that the describes the error. Use `errstr` for a more descriptive explanation of the error condition. ## errstr Detailed error description. ## list\_bucket, list\_bucket\_v2 List keys in a bucket. Note that this method will only return `max-keys`. If you want all of the keys you should use `list_bucket_all` or `list_bucket_all_v2`. _See the note in the `delimiter` and `max-keys` descriptions below regarding how keys are counted against the `max-keys` value._ Takes a reference to a hash of arguments: - bucket (required) The name of the bucket you want to list keys on. - prefix Restricts the response to only contain results that begin with the specified prefix. If you omit this optional argument, the value of prefix for your query will be the empty string. In other words, the results will be not be restricted by prefix. - delimiter If this optional, Unicode string parameter is included with your request, then keys that contain the same string between the prefix and the first occurrence of the delimiter will be rolled up into a single result element in the CommonPrefixes collection. These rolled-up keys are not returned elsewhere in the response. For example, with prefix="USA/" and delimiter="/", the matching keys "USA/Oregon/Salem" and "USA/Oregon/Portland" would be summarized in the response as a single "USA/Oregon" element in the CommonPrefixes collection. If an otherwise matching key does not contain the delimiter after the prefix, it appears in the Contents collection. Each element in the CommonPrefixes collection counts as one against the `MaxKeys` limit. The rolled-up keys represented by each CommonPrefixes element do not. In other words, key below the delimiter are not considered in the count. Remember that S3 keys do not represent a file system hierarchy although it might look like that depending on how you choose to store objects. Using the `prefix` and `delimiter` parameters essentially allows you to restrict the return set to parts of your key "hierarchy". So in the example above If all I wanted was the very top level of the hierarchy I would set my `delimiter to` '/' and omit the `prefix` parameter. If the `Delimiter` parameter is not present in your request, keys in the result set will not be rolled-up and neither the CommonPrefixes collection nor the NextMarker element will be present in the response. NOTE: CommonPrefixes isn't currently supported by Amazon::S3. Example: Suppose I have the keys: bar/baz bar/buz bar/buz/biz bar/buz/zip And I'm only interest in object directly below 'bar' prefix=bar/ delimiter=/ Would yield: bar/baz bar/buz Omitting the delimiter would yield: bar/baz bar/buz bar/buz/biz bar/buz/zip - max-keys This optional argument limits the number of results returned in response to your query. Amazon S3 will return no more than this number of results, but possibly less. Even if max-keys is not specified, Amazon S3 will limit the number of results in the response. Check the IsTruncated flag to see if your results are incomplete. If so, use the `Marker` parameter to request the next page of results. For the purpose of counting `max-key`s, a 'result' is either a key in the 'Contents' collection, or a delimited prefix in the 'CommonPrefixes' collection. So for delimiter requests, max-keys limits the total number of list results, not just the number of keys. - marker This optional parameter enables pagination of large result sets. `marker` specifies where in the result set to resume listing. It restricts the response to only contain results that occur alphabetically after the value of marker. To retrieve the next page of results, use the last key from the current page of results as the marker in your next request. See also `next_marker`, below. If `marker` is omitted,the first page of results is returned. Returns `undef` on error and a reference to a hash of data on success: The return value looks like this: { bucket => $bucket_name, prefix => $bucket_prefix, marker => $bucket_marker, next_marker => $bucket_next_available_marker, max_keys => $bucket_max_keys, is_truncated => $bucket_is_truncated_boolean keys => [$key1,$key2,...] } - is\_truncated Boolean flag that indicates whether or not all results of your query were returned in this response. If your results were truncated, you can make a follow-up paginated request using the Marker parameter to retrieve the rest of the results. - next\_marker A convenience element, useful when paginating with delimiters. The value of `next_marker`, if present, is the largest (alphabetically) of all key names and all CommonPrefixes prefixes in the response. If the `is_truncated` flag is set, request the next page of results by setting `marker` to the value of `next_marker`. This element is only present in the response if the `delimiter` parameter was sent with the request. Each key is a reference to a hash that looks like this: { key => $key, last_modified => $last_mod_date, etag => $etag, # An MD5 sum of the stored content. size => $size, # Bytes storage_class => $storage_class # Doc? owner_id => $owner_id, owner_displayname => $owner_name } ## get\_bucket\_location get_bucket_location(bucket-name) get_bucket_locaiton(bucket-obj) This is a convenience routines for the `get_location_constraint()` of the bucket object. This method will return the default region of 'us-east-1' when `get_location_constraint()` returns a null value. my $region = $s3->get_bucket_location('my-bucket'); Starting with version 0.55, `Amazon::S3::Bucket` will call this `get_location_constraint()` to determine the region for the bucket. You can get the region for the bucket by using the `region()` method of the bucket object. my $bucket = $s3->bucket('my-bucket'); my $bucket_region = $bucket->region; ## get\_logger Returns the logger object. If you did not set a logger when you created the object then an instance of `Amazon::S3::Logger` is returned. You can log to STDERR using this logger. For example: $s3->get_logger->debug('this is a debug message'); $s3->get_logger->trace(sub { return Dumper([$response]) }); ## list\_bucket\_all, list\_bucket\_all\_v2 List all keys in this bucket without having to worry about 'marker'. This is a convenience method, but may make multiple requests to S3 under the hood. Takes the same arguments as `list_bucket`. _You are encouraged to use the newer `list_bucket_all_v2` method._ ## list\_object\_versions list_object_versions( args ) Returns metadata about all versions of the objects in a bucket. You can also use request parameters as selection criteria to return metadata about a subset of all the object versions. This method will only return the raw result set and does not perform pagination or unravel common prefixes as do other methods like `list_bucket`. This may change in the future. See [https://docs.aws.amazon.com/AmazonS3/latest/API/API\_ListObjectVersions.html](https://docs.aws.amazon.com/AmazonS3/latest/API/API_ListObjectVersions.html) for more information about the request parameters and the result body. `args` is hash reference containing the following parameters: - bucket Name of the bucket. This method is not vailable for directory buckets. - headers Optional headers. See [https://docs.aws.amazon.com/AmazonS3/latest/API/API\_ListObjectVersions.html](https://docs.aws.amazon.com/AmazonS3/latest/API/API_ListObjectVersions.html) for more details regarding optional headers. - delimiter A delimiter is a character that you specify to group keys. All keys that contain the same string between the prefix and the first occurrence of the delimiter are grouped under a single result element in CommonPrefixes. These groups are counted as one result against the max-keys limitation. These keys are not returned elsewhere in the response. - encoding-type Requests Amazon S3 to encode the object keys in the response and specifies the encoding method to use. - key-marker Specifies the key to start with when listing objects in a bucket. - max-keys Sets the maximum number of keys returned in the response. By default, the action returns up to 1,000 key names. The response might contain fewer keys but will never contain more. If additional keys satisfy the search criteria, but were not returned because max-keys was exceeded, the response contains <isTruncated>true</isTruncated>. To return the additional keys, see key-marker and version-id-marker. default: 1000 - prefix Use this parameter to select only those keys that begin with the specified prefix. You can use prefixes to separate a bucket into different groupings of keys. (You can think of using prefix to make groups in the same way that you'd use a folder in a file system.) You can use prefix with delimiter to roll up numerous objects into a single result under CommonPrefixes. - version-id-marker Specifies the object version you want to start listing from. ## err The S3 error code for the last error encountered. ## errstr A human readable error string for the last error encountered. ## error The decoded XML string as a hash object of the last error. ## last\_response Returns the last [HTTP::Response](https://metacpan.org/pod/HTTP%3A%3AResponse) object. ## last\_request Returns the last [HTTP::Request](https://metacpan.org/pod/HTTP%3A%3ARequest) object. ## level Set the logging level. default: error ## turn\_on\_special\_retry Called to add extra retry codes if retry has been set ## turn\_off\_special\_retry Called to turn off special retry codes when we are deliberately triggering them # ABOUT This module contains code modified from Amazon that contains the following notice: # This software code is made available "AS IS" without warranties of any # kind. You may copy, display, modify and redistribute the software # code either by itself or as incorporated into your code; provided that # you do not remove any proprietary notices. Your use of this software # code is at your own risk and you waive any claim against Amazon # Digital Services, Inc. or its affiliates with respect to your use of # this software code. (c) 2006 Amazon Digital Services, Inc. or its # affiliates. # TESTING Testing S3 is a tricky thing. Amazon wants to charge you a bit of money each time you use their service. And yes, testing counts as using. Because of this, the application's test suite skips anything approaching a real test unless you set certain environment variables. For more on testing this module see [README-TESTING.md](https://github.com/rlauer6/perl-amazon-s3/blob/master/README-TESTING.md) - AMAZON\_S3\_EXPENSIVE\_TESTS Doesn't matter what you set it to. Just has to be set - AMAZON\_S3\_HOST Sets the host to use for the API service. default: s3.amazonaws.com Note that if this value is set, DNS bucket name usage will be disabled for testing. Most likely, if you set this variable, you are using a mocking service and your bucket names are probably not resolvable. You can override this behavior by setting `AWS_S3_DNS_BUCKET_NAMES` to any value. - AWS\_S3\_DNS\_BUCKET\_NAMES Set this to any value to override the default behavior of disabling DNS bucket names during testing. - AWS\_ACCESS\_KEY\_ID Your AWS access key - AWS\_SECRET\_ACCESS\_KEY Your AWS sekkr1t passkey. Be forewarned that setting this environment variable on a shared system might leak that information to another user. Be careful. - AMAZON\_S3\_SKIP\_ACL\_TESTS Doesn't matter what you set it to. Just has to be set if you want to skip ACLs tests. - AMAZON\_S3\_SKIP\_PERMISSIONS Skip tests that check for enforcement of ACLs...as of this version, LocalStack for example does not support enforcement of ACLs. - AMAZON\_S3\_SKIP\_REGION\_CONSTRAINT\_TEST Doesn't matter what you set it to. Just has to be set if you want to skip region constraint test. - AMAZON\_S3\_MINIO Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on minio. - AMAZON\_S3\_LOCALSTACK Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on LocalStack. - AMAZON\_S3\_REGIONS A comma delimited list of regions to use for testing. The default will only test creating a bucket in the local region. _Consider using an S3 mocking service like `minio` or `LocalStack` if you want to create real tests for your applications or this module._ Here's bash script for testing using LocalStack #!/bin/bash # -*- mode: sh; -*- BUCKET=net-amazon-s3-test-test ENDPOINT_URL=s3.localhost.localstack.cloud:4566 AMAZON_S3_EXPENSIVE_TESTS=1 \ AMAZON_S3_HOST=$ENDPOINT_URL \ AMAZON_S3_LOCALSTACK=1 \ AWS_ACCESS_KEY_ID=test \ AWS_ACCESS_SECRET_KEY=test \ AMAZON_S3_DOMAIN_BUCKET_NAMES=1 make test 2>&1 | tee test.log To run the tests...clone the project and build the software. cd src/main/perl ./test.localstack # ADDITIONAL INFORMATION ## LOGGING AND DEBUGGING Additional debugging information can be output to STDERR by setting the `level` option when you instantiate the `Amazon::S3` object. Levels are represented as a string. The valid levels are: fatal error warn info debug trace You can set an optionally pass in a logger that implements a subset of the `Log::Log4perl` interface. Your logger should support at least these method calls. If you do not supply a logger the default logger (`Amazon::S3::Logger`) will be used. get_logger() fatal() error() warn() info() debug() trace() level() At the `trace` level, every HTTP request and response will be output to STDERR. At the `debug` level information regarding the higher level methods will be output to STDERR. There currently is no additional information logged at lower levels. ## S3 LINKS OF INTEREST - [Bucket restrictions and limitations](https://docs.aws.amazon.com/AmazonS3/latest/userguide/BucketRestrictions.html) - [Bucket naming rules](https://docs.aws.amazon.com/AmazonS3/latest/userguide/bucketnamingrules.html) - [Amazon S3 REST API](https://docs.aws.amazon.com/AmazonS3/latest/API/Welcome.html) - [Authenticating Requests (AWS Signature Version 4)](https://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-authenticating-requests.html) - [Authenticating Requests (AWS Signature Version 2)](https://docs.aws.amazon.com/AmazonS3/latest/userguide/RESTAuthentication.html) - [LocalStack](https://localstack.io) # SUPPORT Bugs should be reported via the CPAN bug tracker at [http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Amazon-S3](http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Amazon-S3) For other issues, contact the author. # REPOSITORY [https://github.com/rlauer6/perl-amazon-s3](https://github.com/rlauer6/perl-amazon-s3) # AUTHOR Original author: Timothy Appnel Current maintainer: Rob Lauer # SEE ALSO [Amazon::S3::Bucket](https://metacpan.org/pod/Amazon%3A%3AS3%3A%3ABucket), [Net::Amazon::S3](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3AS3) # COPYRIGHT AND LICENCE This module was initially based on [Net::Amazon::S3](https://metacpan.org/pod/Net%3A%3AAmazon%3A%3AS3) 0.41, by Leon Brocard. Net::Amazon::S3 was based on example code from Amazon with this notice: _This software code is made available "AS IS" without warranties of any kind. You may copy, display, modify and redistribute the software code either by itself or as incorporated into your code; provided that you do not remove any proprietary notices. Your use of this software code is at your own risk and you waive any claim against Amazon Digital Services, Inc. or its affiliates with respect to your use of this software code. (c) 2006 Amazon Digital Services, Inc. or its affiliates._ The software is released under the Artistic License. The terms of the Artistic License are described at http://www.perl.com/language/misc/Artistic.html. Except where otherwise noted, `Amazon::S3` is Copyright 2008, Timothy Appnel, tima@cpan.org. All rights reserved. Amazon-S3-2.0.2/lib/0000755000175100017510000000000015103436527013347 5ustar rlauerrlauerAmazon-S3-2.0.2/lib/Amazon/0000755000175100017510000000000015103436527014574 5ustar rlauerrlauerAmazon-S3-2.0.2/lib/Amazon/S3.pm0000644000175100017510000024511415103436526015425 0ustar rlauerrlauerpackage Amazon::S3; use strict; use warnings; use Amazon::S3::Bucket; use Amazon::S3::BucketV2; use Amazon::S3::Constants qw(:all); use Amazon::S3::Util qw( set_md5_header urlencode get_parameters create_xml_request create_api_uri create_query_string ); use Amazon::S3::Logger; use Amazon::S3::Signature::V4; use Carp; use Data::Dumper; use Digest::HMAC_SHA1; use Digest::MD5 qw(md5_hex); use English qw(-no_match_vars); use HTTP::Date; use LWP::UserAgent::Determined; use List::Util qw( any pairs none ); use MIME::Base64 qw(encode_base64 decode_base64); use Scalar::Util qw( reftype blessed ); use URI; use XML::Simple; use parent qw(Class::Accessor::Fast Exporter); __PACKAGE__->mk_accessors( qw( aws_access_key_id aws_secret_access_key token buffer_size cache_signer credentials dns_bucket_names digest err errstr error express host last_request last_response logger log_level retry _region secure _signer timeout ua ), ); our $VERSION = '2.0.2'; ## no critic (RequireInterpolation) our @EXPORT_OK = qw(is_domain_bucket); ######################################################################## sub new { ######################################################################## my ( $class, @args ) = @_; my %options = ref $args[0] ? %{ $args[0] } : @args; $options{timeout} //= $DEFAULT_TIMEOUT; $options{secure} //= $TRUE; $options{host} //= $DEFAULT_HOST; $options{dns_bucket_names} //= $TRUE; $options{cache_signer} //= $FALSE; $options{retry} //= $FALSE; $options{express} //= $FALSE; $options{_region} = delete $options{region}; $options{_signer} = delete $options{signer}; # convenience for level => 'debug' & for consistency with # Amazon::Credentials only do this if we are using internal logger, # call should NOT use debug flag but rather use their own logger's # level to turn on higher levels of logging... if ( !$options{logger} ) { if ( delete $options{debug} ) { $options{level} = 'debug'; } $options{log_level} = delete $options{level}; $options{log_level} //= $DEFAULT_LOG_LEVEL; $options{logger} = Amazon::S3::Logger->new( log_level => $options{log_level} ); } my $self = $class->SUPER::new( \%options ); # setup logger internal logging $self->get_logger->debug( sub { my %safe_options = %options; if ( $safe_options{aws_secret_access_key} ) { $safe_options{aws_secret_access_key} = '****'; $safe_options{aws_access_key_id} = '****'; } return Dumper( [ options => \%safe_options ] ); }, ); if ( !$self->credentials ) { croak 'No aws_access_key_id' if !$self->aws_access_key_id; croak 'No aws_secret_access_key' if !$self->aws_secret_access_key; # encrypt credentials $self->aws_access_key_id( _encrypt( $self->aws_access_key_id ) ); $self->aws_secret_access_key( _encrypt( $self->aws_secret_access_key ) ); $self->token( _encrypt( $self->token ) ); } my $ua; if ( $self->retry ) { $ua = LWP::UserAgent::Determined->new( keep_alive => $KEEP_ALIVE_CACHESIZE, requests_redirectable => [qw(GET HEAD DELETE)], ); $ua->timing( join $COMMA, map { 2**$_ } 0 .. $MAX_RETRIES ); } else { $ua = LWP::UserAgent->new( keep_alive => $KEEP_ALIVE_CACHESIZE, requests_redirectable => [qw(GET HEAD DELETE)], ); } $ua->timeout( $self->timeout ); $ua->env_proxy; $self->ua($ua); $self->region( $self->_region // $DEFAULT_REGION ); if ( !$self->_signer && $self->cache_signer ) { $self->_signer( $self->signer ); } if ( $self->express ) { $self->use_express_one_zone(); } $self->turn_on_special_retry(); return $self; } ######################################################################## sub use_express_one_zone { ######################################################################## my ($self) = @_; my $express = $self->express; $self->express($TRUE); $self->host( sprintf 's3express-control.%s.amazonaws.com', $self->region ); $self->dns_bucket_names($FALSE); return $express; } ######################################################################## { my $encryption_key; ######################################################################## sub _encrypt { ######################################################################## my ($text) = @_; return $text if !$text; if ( !defined $encryption_key ) { $encryption_key = eval { if ( !defined $encryption_key ) { require Crypt::Blowfish; require Crypt::CBC; return md5_hex( rand $PID ); } }; return $text if $EVAL_ERROR; } return $text if !$encryption_key; my $cipher = Crypt::CBC->new( -pass => $encryption_key, -key => $encryption_key, -cipher => 'Crypt::Blowfish', -nodeprecate => $TRUE, ); return $cipher->encrypt($text); } ######################################################################## sub _decrypt { ######################################################################## my ($secret) = @_; return $secret if !$secret || !$encryption_key; my $cipher = Crypt::CBC->new( -pass => $encryption_key, -key => $encryption_key, -cipher => 'Crypt::Blowfish', ); return $cipher->decrypt($secret); } } ######################################################################## sub get_bucket_location { ######################################################################## my ( $self, $bucket ) = @_; my $region; if ( !ref $bucket || ref $bucket !~ /Amazon::S3::Bucket/xsm ) { $bucket = Amazon::S3::Bucket->new( bucket => $bucket, account => $self ); } return $bucket->get_location_constraint // $DEFAULT_REGION; } ######################################################################## sub get_default_region { ######################################################################## my ($self) = @_; my $region = $ENV{AWS_REGION} || $ENV{AWS_DEFAULT_REGION}; return $region if $region; my $url = $AWS_METADATA_BASE_URL . 'placement/availability-zone'; my $request = HTTP::Request->new( 'GET', $url ); my $ua = LWP::UserAgent->new; $ua->timeout(0); my $response = eval { return $ua->request($request); }; if ( $response && $response->is_success ) { if ( $response->content =~ /\A([[:lower:]]+[-][[:lower:]]+[-]\d+)/xsm ) { $region = $1; } } return $region || $DEFAULT_REGION; } # Amazon::Credentials compatibility methods ######################################################################## sub get_aws_access_key_id { ######################################################################## my ($self) = @_; return _decrypt( $self->aws_access_key_id ); } ######################################################################## sub get_aws_secret_access_key { ######################################################################## my ($self) = @_; return _decrypt( $self->aws_secret_access_key ); } ######################################################################## sub get_token { ######################################################################## my ($self) = @_; return _decrypt( $self->token ); } ######################################################################## sub turn_on_special_retry { ######################################################################## my ($self) = @_; return if !$self->retry; # In the field we are seeing issue of Amazon returning with a 400 # code in the case of timeout. From AWS S3 logs: REST.PUT.PART # Backups/2017-05-04/.tar.gz "PUT # /Backups?partNumber=27&uploadId= - HTTP/1.1" 400 # RequestTimeout 360 20971520 20478 - "-" "libwww-perl/6.15" my $http_codes_hr = $self->ua->codes_to_determinate(); $http_codes_hr->{$HTTP_BAD_REQUEST} = $TRUE; return; } ######################################################################## sub turn_off_special_retry { ######################################################################## my ($self) = @_; return if !$self->retry; # In the field we are seeing issue with Amazon returning a 400 # code in the case of timeout. From AWS S3 logs: REST.PUT.PART # Backups/2017-05-04/.tar.gz "PUT # /Backups?partNumber=27&uploadId= - HTTP/1.1" 400 # RequestTimeout 360 20971520 20478 - "-" "libwww-perl/6.15" my $http_codes_hr = $self->ua->codes_to_determinate(); delete $http_codes_hr->{$HTTP_BAD_REQUEST}; return; } ######################################################################## sub region { ######################################################################## my ( $self, @args ) = @_; if (@args) { $self->_region( $args[0] ); } $self->get_logger->debug( sub { return 'region: ' . ( $self->_region // $EMPTY ) } ); if ( $self->_region ) { my $host = $self->host; $self->get_logger->debug( sub { return 'host: ' . $self->host } ); if ( $host =~ /\As3[.](.*)?amazonaws/xsm ) { $self->host( sprintf 's3.%s.amazonaws.com', $self->_region ); } } return $self->_region; } ######################################################################## sub buckets { ######################################################################## my ( $self, $verify_region ) = @_; # The "default" region for Amazon is us-east-1 # This is the region to set it to for listing buckets # You may need to reset the signer's endpoint to 'us-east-1' # temporarily cache signer my $region = $self->_region; my $bucket_list; $self->reset_signer_region($DEFAULT_REGION); # default region for buckets op my $r = $self->_send_request( { method => 'GET', path => $EMPTY, headers => {}, region => $DEFAULT_REGION, }, ); return $bucket_list if !$r || $self->errstr; my $owner_id = $r->{Owner}{ID}; my $owner_displayname = $r->{Owner}{DisplayName}; my @buckets; if ( ref $r->{Buckets} ) { my $buckets = $r->{Buckets}{Bucket}; if ( !ref $buckets || reftype($buckets) ne 'ARRAY' ) { $buckets = [$buckets]; } 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; my $retval = $self->_send_request_expect_nothing( { method => 'PUT', path => "$bucket/", headers => $headers, data => $data, region => $region, }, ); my $bucket_obj = $retval ? $self->bucket($bucket) : undef; return $bucket_obj; } ######################################################################## sub bucket { ######################################################################## my ( $self, @args ) = @_; my ( $bucketname, $region, $verify_region ); if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) { ( $bucketname, $region, $verify_region ) = @{ $args[0] }{qw(bucket region verify_region)}; } else { ( $bucketname, $region ) = @args; } # only set to default region if a region wasn't passed or region # verification not requested if ( !$region && !$verify_region ) { $region = $self->region; } return Amazon::S3::Bucket->new( { bucket => $bucketname, account => $self, region => $region, verify_region => $verify_region, }, ); } ######################################################################## sub delete_bucket { ######################################################################## my ( $self, $conf ) = @_; my $bucket; my $region; my $headers; if ( eval { return $conf->isa('Amazon::S3::Bucket'); } ) { $bucket = $conf->bucket; $region = $conf->region; } else { $bucket = $conf->{bucket}; $region = $conf->{region} || $self->get_bucket_location($bucket); $headers = $conf->{headers}; } croak 'must specify bucket' if !$bucket; return $self->_send_request_expect_nothing( { method => 'DELETE', path => $bucket . $SLASH, headers => $headers // {}, region => $region, }, ); } ######################################################################## sub list_directory_buckets { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my $express = $self->use_express_one_zone; my $result = $self->_send_request( { method => 'GET', headers => {}, path => $SLASH, uri_params => $parameters->{uri_params} // {}, region => $self->region, } ); $self->express($express); return $result; } ######################################################################## sub list_bucket_v2 { ######################################################################## my ( $self, $conf ) = @_; $conf->{'list-type'} = '2'; goto &list_bucket; } ######################################################################## sub list_bucket { ######################################################################## my ( $self, $conf ) = @_; my $bucket = delete $conf->{bucket}; croak 'must specify bucket' if !$bucket; $conf //= {}; my $bucket_list; # return this my $path = $bucket . $SLASH; my $headers = delete $conf->{headers}; my $list_type = $conf->{'list-type'} // '1'; my ( $marker, $next_marker, $query_next ) = @{ $LIST_OBJECT_MARKERS{$list_type} }; if ( $conf->{marker} ) { $conf->{$query_next} = delete $conf->{marker}; } if ( %{$conf} ) { my @vars = keys %{$conf}; # remove undefined elements foreach (@vars) { next if defined $conf->{$_}; delete $conf->{$_}; } my $query_string = $QUESTION_MARK . join $AMPERSAND, map { $_ . $EQUAL_SIGN . urlencode( $conf->{$_} ) } keys %{$conf}; $path .= $query_string; } $self->get_logger->debug( sprintf 'PATH: %s', $path ); my $r = $self->_send_request( { method => 'GET', path => $path, headers => $headers // {}, # { 'Content-Length' => 0 }, region => $self->region, }, ); $self->get_logger->trace( Dumper( [ r => $r, errstr => $self->errstr, ] ) ); return $bucket_list if !$r || $self->errstr; $self->get_logger->trace( sub { return Dumper( [ marker => $marker, next_marker => $next_marker, response => $r, ], ); }, ); $bucket_list = { bucket => $r->{Name}, prefix => $r->{Prefix} // $EMPTY, marker => $r->{$marker} // $EMPTY, next_marker => $r->{$next_marker} // $EMPTY, max_keys => $r->{MaxKeys}, is_truncated => ( ( defined $r->{IsTruncated} && scalar $r->{IsTruncated} eq 'true' ) ? $TRUE : $FALSE ), }; my @keys; foreach my $node ( @{ $r->{Contents} } ) { my $etag = $node->{ETag}; if ( defined $etag ) { $etag =~ s{(^"|"$)}{}gxsm; } push @keys, { key => $node->{Key}, last_modified => $node->{LastModified}, etag => $etag, size => $node->{Size}, storage_class => $node->{StorageClass}, owner_id => $node->{Owner}{ID}, owner_displayname => $node->{Owner}{DisplayName}, }; } $bucket_list->{keys} = \@keys; if ( $conf->{delimiter} ) { my @common_prefixes; my $strip_delim = qr/$conf->{delimiter}$/xsm; foreach my $node ( $r->{CommonPrefixes} ) { if ( ref $node ne 'ARRAY' ) { $node = [$node]; } foreach my $n ( @{$node} ) { next if !exists $n->{Prefix}; my $prefix = $n->{Prefix}; # strip delimiter from end of prefix if ($prefix) { $prefix =~ s/$strip_delim//xsm; } push @common_prefixes, $prefix; } } $bucket_list->{common_prefixes} = \@common_prefixes; } $self->get_logger->trace( Dumper( [ bucket_list => $bucket_list ] ) ); return $bucket_list; } ######################################################################## sub list_bucket_all_v2 { ######################################################################## my ( $self, $conf ) = @_; $conf ||= {}; $conf->{'list-type'} = '2'; return $self->list_bucket_all($conf); } ######################################################################## sub list_bucket_all { ######################################################################## my ( $self, $conf ) = @_; $conf ||= {}; my $bucket = $conf->{bucket}; croak 'must specify bucket' if !$bucket; my $response = $self->list_bucket($conf); croak $EVAL_ERROR if !$response; return $response if !$response->{is_truncated}; my $all = $response; while ($TRUE) { my $next_marker = $response->{next_marker} || $response->{keys}->[-1]->{key}; $conf->{marker} = $next_marker; $conf->{bucket} = $bucket; $response = $self->list_bucket($conf); croak $EVAL_ERROR if !$response; push @{ $all->{keys} }, @{ $response->{keys} }; last if !$response->{is_truncated}; } delete $all->{is_truncated}; delete $all->{next_marker}; return $all; } ######################################################################## # API: ListObjectVersions ######################################################################### # Documentation: # https://docs.aws.amazon.com/AmazonS3/latest/API/API_ListObjectVersions.html # # Request: # GET /?versions # HOST: Bucket.s3.amazonaws.com # x-amz-expected-bucket-owner: ExpectedBucketOwner # x-amz-request-payer: RequestPayer # x-amz-optional-object-attributes: OptionalObjectAtttributes # # Parameters: # delimiter => Delimiter # encoding-type => EncodingType # key-marker => KeyMarker # max-keys => MaxKeys # prefix => Prefix # version-id-marker => VersionIdMarker # # Response ######################################################################## sub list_object_versions { ######################################################################## my ( $self, $conf ) = @_; my $bucket = delete $conf->{bucket}; die 'no bucket' if !$bucket; my $headers = delete $conf->{headers}; croak 'must specify bucket' if !$bucket; $conf ||= {}; my ( $marker, $next_marker, $query_next ) = @{ $LIST_OBJECT_MARKERS{'3'} }; if ( $conf->{'key-marker'} ) { $conf->{$query_next} = delete $conf->{'key-marker'}; } if ( %{$conf} ) { # remove undefined elements foreach ( keys %{$conf} ) { next if defined $conf->{$_}; delete $conf->{$_}; } } my $path = create_api_uri( path => "$bucket/", api => 'versions', %{$conf} ); my $r = $self->_send_request( { method => 'GET', path => $path, headers => $headers // {}, region => $self->region, }, ); return if !$r || $self->errstr; $self->get_logger->debug( sub { return Dumper( [ marker => $marker, next_marker => $next_marker, response => $r, ], ); }, ); return $r; } ######################################################################## sub get_credentials { ######################################################################## my ($self) = @_; my $aws_access_key_id; my $aws_secret_access_key; my $token; if ( $self->credentials ) { $aws_access_key_id = $self->credentials->get_aws_access_key_id; $aws_secret_access_key = $self->credentials->get_aws_secret_access_key; $token = $self->credentials->get_token; } 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; croak 'must specify path' if !defined $path; $headers //= {}; $metadata //= {}; $data //= $EMPTY; $headers->{'Content-Length'} //= length $data; my $http_headers = $self->_merge_meta( $headers, $metadata ); my $protocol = $self->secure ? 'https' : 'http'; my $host = $self->host; $path =~ s/\A\///xsm; my $url = sprintf '%s://%s/%s', $protocol, $host, $path; # if ( $path =~ m{\A([^/?]+)([^?]+)(.*)}xsm if ( $path =~ /\A([^\/?]+)([^?]+)(.*)/xsm && $self->dns_bucket_names && is_domain_bucket($1) ) { my $bucket = $1; $path = $2; my $query_string = $3; $self->logger->debug( sub { return Dumper( [ bucket => $bucket, path => $path, query_string => $query_string, ] ); } ); if ( $host =~ /([^:]+):([^:]\d+)$/xsm ) { my $port; $url = eval { $port = $2; $host = $1; my $uri = URI->new; $uri->scheme('http'); $uri->host("$bucket.$host"); $uri->port($port); $uri->path($path); return $uri . $query_string; }; die sprintf "error creating uri for bucket: [%s], host: [%s], path: [%s], port: [%s]\n%s", $bucket, $host, $path, $port, $EVAL_ERROR if !$url || $EVAL_ERROR; } else { $url = sprintf '%s://%s.%s%s%s', $protocol, $bucket, $host, $path, $query_string; } } my $request = HTTP::Request->new( $method, $url, $http_headers ); $self->last_request($request); if ($data) { $request->content($data); } $self->signer->region($region); # always set regional endpoint for signing $self->signer->sign($request); return $request; } # $self->_send_request($HTTP::Request) # $self->_send_request(@params_to_make_request) # $self->_send_request($params_to_make_request) ######################################################################## sub _send_request { ######################################################################## my ( $self, @args ) = @_; my $logger = $self->get_logger; $logger->trace( sub { return Dumper( [ args => \@args ] ); }, ); my $keep_root = $FALSE; my $request = eval { return $args[0] if ref( $args[0] ) =~ /HTTP::Request/xsm; return {@args} if @args > 1 && !@args % 2; return $args[0] if ref $args[0]; croak 'invalid argument to _send_request'; }; if ( ref($request) !~ /HTTP::Request/xsm ) { $keep_root = delete $request->{keep_root}; $request = $self->_make_request($request); } my $response = $self->_do_http($request); $self->last_response($response); $logger->debug( sub { return Dumper( [ response => $response ] ); } ); return $self->_decode_response( $response, $keep_root ); } ######################################################################## sub _decode_response { ######################################################################## my ( $self, $response, $keep_root ) = @_; my $content; if ( $response->code !~ /\A2\d{2}\z/xsm ) { $self->_remember_errors( $response->content, 1 ); $content = undef; } elsif ( is_xml_response($response) ) { $content = $self->_xpc_of_content( $response->content, $keep_root ); } return $content; } ######################################################################## sub is_xml_response { ######################################################################## my ($rsp) = @_; return $FALSE if !$rsp->content; return $TRUE if $rsp->content_type eq 'application/xml'; return $TRUE if $rsp->content =~ /\A\s*<[?]xml/xsm; return $FALSE; } # # This is the necessary to find the region for a specific bucket # and set the signer object to use that region when signing requests ######################################################################## sub adjust_region { ######################################################################## my ( $self, $bucket, $called_from_redirect ) = @_; my $url = sprintf 'https://%s.%s', $bucket, $self->host; my $request = HTTP::Request->new( GET => $url ); $self->{'signer'}->sign($request); # We have to turn off our special retry since this will deliberately # trigger that code $self->turn_off_special_retry(); # If the bucket name has a period in it, the certificate validation # will fail since it will expect a certificate for a subdomain. # Setting it to verify against the expected host guards against # that while still being secure since we will have verified # the response as coming from the expected server. $self->ua->ssl_opts( SSL_verifycn_name => $self->host ); my $response = $self->_do_http($request); # Turn this off, since all other requests have the bucket after # the host in the URL, and the host may change depending on the region $self->ua->ssl_opts( SSL_verifycn_name => undef ); $self->turn_on_special_retry(); # If No error, then nothing to do return $TRUE if $response->is_success(); # If the error is due to the wrong region, then we will get # back a block of XML with the details return $FALSE if !is_xml_response($response); my $error_hash = $self->_xpc_of_content( $response->content ); my ( $endpoint, $code, $region, $message ) = @{$error_hash}{qw(Endpoint Code Region Message)}; my $condition = eval { return 'PermanentRedirect' if $code eq 'PermanentRedirect' && $endpoint; return 'AuthorizationHeaderMalformed' if $code eq 'AuthorizationHeaderMalformed' && $region; return 'IllegalLocationConstraintException' if $code eq 'IllegalLocationConstraintException'; return 'Other'; }; my %error_handlers = ( PermanentRedirect => sub { # Don't recurse through multiple redirects return $FALSE if $called_from_redirect; # With a permanent redirect error, they are telling us the explicit # host to use. The endpoint will be in the form of bucket.host my $host = $endpoint; # Remove the bucket name from the front of the host name # All the requests will need to be of the form https://host/bucket $host =~ s/\A$bucket[.]//xsm; $self->host($host); # We will need to call ourselves again in order to trigger the # AuthorizationHeaderMalformed error in order to get the region return $self->adjust_region( $bucket, $TRUE ); }, AuthorizationHeaderMalformed => sub { # Set the signer to use the correct reader evermore $self->{signer}->{endpoint} = $region; # Only change the host if we haven't been called as a redirect # where an exact host has been given if ( !$called_from_redirect ) { $self->host( sprintf 's3-%s-amazonaws.com', $region ); } return $TRUE; }, IllegalLocationConstraintException => sub { # This is hackish; but in this case the region name only appears in the message if ( $message =~ /The (\S+) location/xsm ) { my $new_region = $1; # Correct the region for the signer $self->{signer}->{endpoint} = $new_region; # Set the proper host for the region $self->host( sprintf 's3.%s.amazonaws.com', $new_region ); return $TRUE; } }, 'Other' => sub { # Some other error $self->_remember_errors( $response->content, 1 ); return $FALSE; }, ); return $error_handlers{$condition}->(); } ######################################################################## sub reset_errors { ######################################################################## my ($self) = @_; $self->err(undef); $self->errstr(undef); $self->error(undef); return $self; } ######################################################################## sub _do_http { ######################################################################## my ( $self, $request, $filename ) = @_; # convenient time to reset any error conditions $self->reset_errors; my $response = $self->ua->request( $request, $filename ); # For new buckets at non-standard locations, amazon will sometimes # respond with a temporary redirect. In this case it is necessary # to try again with the new URL my $location = $response->header('Location'); if ( $response->code =~ /\A3/xsm and defined $location ) { $self->get_logger->debug( sub { return { sprintf 'Redirecting to: %s', $location }; } ); $request->uri($location); $response = $self->ua->request( $request, $filename ); } $self->get_logger->debug( sub { return Dumper( [$response] ) } ); $self->last_response($response); return $response; } # Call this if handling any temporary redirect issues # (Like needing to probe with a HEAD request when file handle are involved) ######################################################################## sub _do_http_no_redirect { ######################################################################## my ( $self, $request, $filename ) = @_; # convenient time to reset any error conditions $self->reset_errors; my $response = $self->ua->request( $request, $filename ); $self->get_logger->debug( sub { return Dumper( [$response] ) } ); $self->last_response($response); return $response; } ######################################################################## sub _send_request_expect_nothing { ######################################################################## my ( $self, @args ) = @_; my $request = $self->_make_request(@args); my $response = $self->_do_http($request); my $content = $response->content; return $TRUE if $response->code =~ /^2\d\d$/xsm; # anything else is a failure, and we save the parsed result $self->_remember_errors( $response->content, $TRUE ); return $FALSE; } # Send a HEAD request first, to find out if we'll be hit with a 307 redirect. # Since currently LWP does not have true support for 100 Continue, it simply # slams the PUT body into the socket without waiting for any possible redirect. # Thus when we're reading from a filehandle, when LWP goes to reissue the request # having followed the redirect, the filehandle's already been closed from the # first time we used it. Thus, we need to probe first to find out what's going on, # before we start sending any actual data. ######################################################################## sub _send_request_expect_nothing_probed { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my ( $method, $path, $conf, $value, $region ) = @{$parameters}{qw(method path headers data region)}; $region = $region // $self->region; my $request = $self->_make_request( { method => 'HEAD', path => $path, region => $region, }, ); my $override_uri; my $old_redirectable = $self->ua->requests_redirectable; $self->ua->requests_redirectable( [] ); my $response = $self->_do_http_no_redirect($request); if ( $response->code =~ /^3/xsm ) { if ( defined $response->header('Location') ) { $override_uri = $response->header('Location'); } else { $self->_croak_if_response_error($response); } $self->get_logger->debug( sub { return sprintf 'setting override URI: [%s]', $override_uri; } ); } $request = $self->_make_request( { method => $method, path => $path, headers => $conf, data => $value, region => $region, }, ); if ( defined $override_uri ) { $request->uri($override_uri); } $response = $self->_do_http_no_redirect($request); $self->ua->requests_redirectable($old_redirectable); my $content = $response->content; return $TRUE if $response->code =~ /^2\d\d$/xsm; # anything else is a failure, and we save the parsed result $self->_remember_errors( $response->content, $TRUE ); return $FALSE; } ######################################################################## sub _croak_if_response_error { ######################################################################## my ( $self, $response ) = @_; if ( $response->code !~ /^2\d{2}$/xsm ) { $self->err('network_error'); $self->errstr( $response->status_line ); croak $response->status_line; } return; } ######################################################################## sub _xpc_of_content { ######################################################################## my ( $self, $src, $keep_root ) = @_; my $xml_hr = eval { XMLin( $src, SuppressEmpty => $EMPTY, ForceArray => ['Contents'], KeepRoot => $keep_root, NoAttr => $TRUE, ); }; if ( !$xml_hr && $EVAL_ERROR ) { confess "Error parsing $src: $EVAL_ERROR"; } return $xml_hr; } # returns 1 if errors were found ######################################################################## sub _remember_errors { ######################################################################## my ( $self, $src, $keep_root ) = @_; return if !$src; if ( !ref $src && $src !~ /^[[:space:]]*err($code); $self->errstr($src); return $TRUE; } my $r = ref $src ? $src : $self->_xpc_of_content( $src, $keep_root ); $self->error($r); # apparently buckets() does not keep_root if ( $r->{Error} ) { $r = $r->{Error}; } my ( $code, $message ) = @{$r}{qw(Code Message)}; return $FALSE if !$code; $self->err($code); $self->errstr($message); return $TRUE; } # Deprecated - this adds a header for the old V2 auth signatures ######################################################################## sub _add_auth_header { ## no critic (ProhibitUnusedPrivateSubroutines) ######################################################################## my ( $self, $headers, $method, $path ) = @_; my ( $aws_access_key_id, $aws_secret_access_key, $token ) = $self->get_credentials; if ( not $headers->header('Date') ) { $headers->header( Date => time2str(time) ); } if ($token) { $headers->header( $AMAZON_HEADER_PREFIX . 'security-token' => $token ); } my $canonical_string = $self->_canonical_string( $method, $path, $headers ); $self->get_logger->trace( sub { return Dumper( [ headers => $headers, canonincal_sring => $canonical_string, ] ); } ); my $encoded_canonical = $self->_encode( $aws_secret_access_key, $canonical_string ); $headers->header( Authorization => sprintf 'AWS %s:%s', $aws_access_key_id, $encoded_canonical ); return; } # generates an HTTP::Headers objects given one hash that represents http # headers to set and another hash that represents an object's metadata. ######################################################################## sub _merge_meta { ######################################################################## my ( $self, $headers, $metadata ) = @_; $headers //= {}; $metadata //= {}; my $http_header = HTTP::Headers->new; foreach my $p ( pairs %{$headers} ) { my ( $k, $v ) = @{$p}; $http_header->header( $k => $v ); } foreach my $p ( pairs %{$metadata} ) { my ( $k, $v ) = @{$p}; $http_header->header( "$METADATA_PREFIX$k" => $v ); } return $http_header; } # generate a canonical string for the given parameters. expires is optional and is # only used by query string authentication. ######################################################################## sub _canonical_string { ######################################################################## my ( $self, $method, $path, $headers, $expires ) = @_; # initial / meant to force host/bucket-name instead of DNS based name $path =~ s/^\///xsm; my %interesting_headers = (); foreach my $p ( pairs %{$headers} ) { my ( $key, $value ) = @{$p}; my $lk = lc $key; if ( $lk eq 'content-md5' or $lk eq 'content-type' or $lk eq 'date' or $lk =~ /^$AMAZON_HEADER_PREFIX/xsm ) { $interesting_headers{$lk} = $self->_trim($value); } } # these keys get empty strings if they don't exist $interesting_headers{'content-type'} ||= $EMPTY; $interesting_headers{'content-md5'} ||= $EMPTY; # just in case someone used this. it's not necessary in this lib. if ( $interesting_headers{'x-amz-date'} ) { $interesting_headers{'date'} = $EMPTY; } # if you're using expires for query string auth, then it trumps date # (and x-amz-date) if ($expires) { $interesting_headers{'date'} = $expires; } my $buf = "$method\n"; foreach my $key ( sort keys %interesting_headers ) { if ( $key =~ /^$AMAZON_HEADER_PREFIX/xsm ) { $buf .= "$key:$interesting_headers{$key}\n"; } else { $buf .= "$interesting_headers{$key}\n"; } } # don't include anything after the first ? in the resource... # $path =~ /^([^?]*)/xsm; # $buf .= "/$1"; $path =~ /\A([^?]*)/xsm; $buf .= "/$1"; # ...unless there any parameters we're interested in... if ( $path =~ /[&?](acl|torrent|location|uploads|delete)([=&]|$)/xsm ) { # if ( $path =~ /[&?](acl|torrent|location|uploads|delete)([=&])?/xsm ) { $buf .= "?$1"; } elsif ( my %query_params = URI->new($path)->query_form ) { # see if the remaining parsed query string provides us with any # query string or upload id if ( $query_params{partNumber} && $query_params{uploadId} ) { # re-evaluate query string, the order of the params is important # for request signing, so we can't depend on URI to do the right # thing $buf .= sprintf '?partNumber=%s&uploadId=%s', $query_params{partNumber}, $query_params{uploadId}; } elsif ( $query_params{uploadId} ) { $buf .= sprintf '?uploadId=%s', $query_params{uploadId}; } } return $buf; } ######################################################################## sub _trim { ######################################################################## my ( $self, $value ) = @_; $value =~ s/^\s+//xsm; $value =~ s/\s+$//xsm; return $value; } # finds the hmac-sha1 hash of the canonical string and the aws secret access key and then # base64 encodes the result (optionally urlencoding after that). ######################################################################## sub _encode { ######################################################################## my ( $self, $aws_secret_access_key, $str, $urlencode ) = @_; my $hmac = Digest::HMAC_SHA1->new($aws_secret_access_key); $hmac->add($str); my $b64 = encode_base64( $hmac->digest, $EMPTY ); return $urlencode ? urlencode($b64) : return $b64; } ######################################################################## sub bucketv2 { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my ( $bucketname, $region, $verify_region ) = @{$parameters}{qw(bucket region verify_region)}; # only set to default region if a region wasn't passed or region # verification not requested if ( !$region && !$verify_region ) { $region = $self->region; } return Amazon::S3::BucketV2->new( { bucket => $bucketname, account => $self, region => $region, verify_region => $verify_region, }, ); } ######################################################################## sub delete_public_access_block { ######################################################################## my ( $self, $bucket ) = @_; my $bucketv2 = bless $bucket, 'Amazon::S3::BucketV2'; return $bucketv2->DeletePublicAccessBlock; } 1; __END__ =pod =head1 NAME Amazon::S3 - A portable client library for working with and managing Amazon S3 buckets and keys. =begin markdown ![Amazon::S3](https://github.com/rlauer6/perl-amazon-s3/actions/workflows/build.yml/badge.svg?event=push) =end markdown =head1 SYNOPSIS use Amazon::S3; my $aws_access_key_id = "Fill me in!"; my $aws_secret_access_key = "Fill me in too!"; my $s3 = Amazon::S3->new( { aws_access_key_id => $aws_access_key_id, aws_secret_access_key => $aws_secret_access_key, retry => 1 } ); my $response = $s3->buckets; # create a bucket my $bucket_name = $aws_access_key_id . '-net-amazon-s3-test'; my $bucket = $s3->add_bucket( { bucket => $bucket_name } ) or die $s3->err . ": " . $s3->errstr; # store a key with a content-type and some optional metadata my $keyname = 'testing.txt'; my $value = 'T'; $bucket->add_key( $keyname, $value, { content_type => 'text/plain', 'x-amz-meta-colour' => 'orange', } ); # copy an object $bucket->copy_object( source => $source, key => $new_keyname ); # list keys in the bucket $response = $bucket->list or die $s3->err . ": " . $s3->errstr; print $response->{bucket}."\n"; for my $key (@{ $response->{keys} }) { print "\t".$key->{key}."\n"; } # delete key from bucket $bucket->delete_key($keyname); # delete multiple keys from bucket $bucket->delete_keys([$key1, $key2, $key3]); # delete bucket $bucket->delete_bucket; =head1 DESCRIPTION This documentation refers to version 2.0.2. C provides a portable client interface to Amazon Simple Storage System (S3). This module is rather dated, however with some help from a few contributors it has had some recent updates. Recent changes include implementations of: =over 5 =item ListObjectsV2 =item CopyObject =item DeleteObjects =item ListObjectVersions =back Additionally, this module now implements Signature Version 4 signing, unit tests have been updated and more documentation has been added or corrected. Credentials are encrypted if you have encryption modules installed. I The C modules have been heavily refactored over the last few releases to increase maintainability and to add new features. New features include: =over 5 =item L This new module implements a mechanism to invoke I all of the S3 APIs using a standard calling method. The module will format your Perl objects as XML payloads and enable you to provide all of the parameters required to make an API call. Headers and URI parameters can also be passed to the methods. L is a subclass of L, meaning you can still invoke all of the same methods found there. See L for more details. =item Limited Support for Directory Buckets This version include limited support for directory buckets. You can create and list directory buckets. I - L =over 10 =item list_directory_buckets List the directory buckets. Note this only returns a list of you directory buckets, not their contents. In order to list the contents of a directory bucket you must first create a session that establishes temporary credentials used to acces the Zonal endpoints. You then use those credentials for signing requests using the ListObjectV2 API. This process is currently B by this class. L =item add_bucket You can add a regin and availability zone to this call in order to create a directory bucket. $bucket->add_bucket({ bucket => $bucket_name, availability_zone => 'use1-az5' }); Note that your bucket name must conform to the naming conventions for directory buckets. - L =back =item Addition of version parameter for C You can now delete a version of a key by including its verion ID. $bucket->delete_key($key, $version_id); =item Methods that accept a hash reference can now accept a C object that may contain any additional headers you might want to send with a request. Some of the methods that now allow you to pass a header object include: =over 10 =item add_bucket =item add_key =item get_key Can now be called with a hashref which may include both a C and C object. =item delete_bucket =item list_bucket =item list_object_versions =item upload_multipart_object =back =back =head2 Comparison to Other Perl S3 Modules Other implementations for accessing Amazon's S3 service include C and the C project. C ostensibly was intended to be a drop-in replacement for C that "traded some performance in return for portability". That statement is no longer accurate as C may have changed the interface in ways that might break your applications if you are relying on compatibility with C. However, C and C today, are dependent on C which may in fact level the playing field in terms of performance penalties that may have been introduced by recent updates to C. Changes to C include the use of more Perl modules in lieu of raw Perl code to increase maintainability and stability as well as some refactoring. C also strives now to adhere to best practices as much as possible. C may be a much more robust implementation of a Perl S3 interface, however this module may still appeal to those that favor simplicity of the interface and a lower number of dependencies. The new L module now provides access to nearly all of the main S3 API metods. Below is the original description of the module. =over 10 Amazon S3 is storage for the Internet. It is designed to make web-scale computing easier for developers. Amazon S3 provides a simple web services interface that can be used to store and retrieve any amount of data, at any time, from anywhere on the web. It gives any developer access to the same highly scalable, reliable, fast, inexpensive data storage infrastructure that Amazon uses to run its own global network of web sites. The service aims to maximize benefits of scale and to pass those benefits on to developers. To sign up for an Amazon Web Services account, required to use this library and the S3 service, please visit the Amazon Web Services web site at http://www.amazonaws.com/. You will be billed accordingly by Amazon when you use this module and must be responsible for these costs. To learn more about Amazon's S3 service, please visit: http://s3.amazonaws.com/. The need for this module arose from some work that needed to work with S3 and would be distributed, installed and used on many various environments where compiled dependencies may not be an option. L used L tying it to that specific and often difficult to install option. In order to remove this potential barrier to entry, this module is forked and then modified to use L via L. =back =head1 LIMITATIONS AND DIFFERENCES WITH EARLIER VERSIONS As noted, this module is no longer a I replacement for C and has limitations and differences that may impact the use of this module in your applications. Additionally, one of the original intents of this fork of C was to reduce the number of dependencies and make it I. Recent changes to this module have introduced new dependencies in order to improve the maintainability and provide additional features. Installing CPAN modules is never easy, especially when the dependencies of the dependencies are impossible to control and include may include XS modules. =over 5 =item MINIMUM PERL Technically, this module should run on versions 5.10 and above, however some of the dependencies may require higher versions of C or some lower versions of the dependencies due to conflicts with other versions of dependencies...it's a crapshoot when dealing with older C versions and CPAN modules. You may however, be able to build this module by installing older versions of those dependencies and take your chances that those older versions provide enough working features to support C. It is likely they do...and this module has recently been tested on version 5.10.0 C using some older CPAN modules to resolve dependency issues. To build this module on an earlier version of C you may need to downgrade some modules. In particular I have found this recipe to work for building and testing on 5.10.0. In this order install: HTML::HeadParser 2.14 LWP 6.13 Amazon::S3 ...other versions I work...YMMV. If you do decide to run on an earlier version of C, you are encouraged to run the test suite. See the L section for more details. =item API Signing Making calls to AWS APIs requires that the calls be signed. Amazon has added a new signing method (Signature Version 4) to increase security around their APIs. This module no longer utilizes Signature Version V2. B See L below for important details. =over 10 =item Signature Version 4 L I Unlike Signature Version 2, Version 4 requires a regional parameter. This implies that you need to supply the bucket's region when signing requests for any API call that involves a specific bucket. Starting with version 0.55 of this module, C provides a new method (C) and accepts in the constructor a C parameter. If a region is not supplied, the region for the bucket will be set to the region set in the C object (C) that you passed to the bucket's new constructor. Alternatively, you can request that the bucket's new constructor determine the bucket's region for you by calling the C method. When signing API calls, the region for the specific bucket will be used. For calls that are not regional (C, e.g.) the default region ('us-east-1') will be used. =item Signature Version 2 L =back =item Multipart Upload Support There are some recently added unit tests for multipart uploads that seem to indicate this feature is working as expected. Please report any deviation from expected results if you are using those methods. For more information regarding multipart uploads visit the link below. L =back =head1 METHODS AND SUBROUTINES Unless otherwise noted methods will return an C if an error occurs. You can get more information about the error by calling C and C. =head2 new Create a new S3 client object. Takes some arguments: =over =item credentials (optional) Reference to a class (like C) that can provide credentials via the methods: get_aws_access_key_id() get_aws_secret_access_key() get_token() If you do not provide a credential class you must provide the keys when you instantiate the object. See below. I =item aws_access_key_id Use your Access Key ID as the value of the AWSAccessKeyId parameter in requests you send to Amazon Web Services (when required). Your Access Key ID identifies you as the party responsible for the request. =item aws_secret_access_key Since your Access Key ID is not encrypted in requests to AWS, it could be discovered and used by anyone. Services that are not free require you to provide additional information, a request signature, to verify that a request containing your unique Access Key ID could only have come from you. B I =item token An optional temporary token that will be inserted in the request along with your access and secret key. A token is used in conjunction with temporary credentials when your EC2 instance has assumed a role and you've scraped the temporary credentials from I =item secure Set this to a true value if you want to use SSL-encrypted connections when connecting to S3. Starting in version 0.49, the default is true. default: true =item timeout Defines the time, in seconds, your script should wait or a response before bailing. default: 30s =item retry Enables or disables the library to retry upon errors. This uses exponential backoff with retries after 1, 2, 4, 8, 16, 32 seconds, as recommended by Amazon. default: off =item host Defines the S3 host endpoint to use. default: s3.amazonaws.com Note that requests are made to domain buckets when possible. You can prevent that behavior if either the bucket name does not conform to DNS bucket naming conventions or you preface the bucket name with '/' or explicitly turn off domain buckets by setting C to false. If you set a region then the host name will be modified accordingly if it is an Amazon endpoint. =item region The AWS region you where your bucket is located. default: us-east-1 =item buffer_size The default buffer size when reading or writing files. default: 4096 =back =head2 signer Sets or retrieves the signer object. API calls must be signed using your AWS credentials. By default, starting with version 0.54 the module will use L as the signer and instantiate a signer object in the constructor. Note however, that signers need your credentials and they I get stored by that class, making them susceptible to inadvertant exfiltration. You have a few options here: =over 5 =item 1. Use your own signer. You may have noticed that you can also provide your own credentials object forcing this module to use your object for retrieving credentials. Likewise, you can use your own signer so that this module's signer never sees or stores those credentials. =item 2. Pass the credentials object and set C to a false value. If you pass a credentials object and set C to a false value, the module will use the credentials object to retrieve credentials and create a new signer each time an API call is made that requires signing. This prevents your credentials from being stored inside of the signer class. I =item 3. Pass credentials, set C to a false value. Unfortunately, while this will prevent L from hanging on to your credentials, you credentials will be stored in the C object. Starting with version 0.55 of this module, if you have installed L and L, your credentials will be encrypted using a random key created when the class is instantiated. While this is more secure than leaving them in plaintext, if the key is discovered (the key however is not stored in the object's hash) and the object is dumped, your I credentials can be exposed. =item 4. Use very granular credentials for bucket access only. Use credentials that only allow access to a bucket or portions of a bucket required for your application. This will at least limit the I of any potential security breach. =item 5. Do nothing...send the credentials, use the default signer. In this case, both the C class and the L have your credentials. Caveat Emptor. See also L for more information about safely storing your credentials and preventing exfiltration. =back =head2 region Sets the region for the API calls. This will also be the default when instantiating the bucket object unless you pass the region parameter in the C method or use the C flag that will I verify the region of the bucket using the C method. default: us-east-1 =head2 buckets buckets([verify-region]) =over =item verify-region (optional) C is a boolean value that indicates if the bucket's region should be verified when the bucket object is instantiated. If set to true, this method will call the C method with C set to true causing the constructor to call the C for each bucket to set the bucket's region. This will cause a significant decrease in the peformance of the C method. Setting the region for each bucket is necessary since API operations on buckets require the region of the bucket when signing API requests. If all of your buckets are in the same region and you have passed a region parameter to your S3 object, then that region will be used when calling the constructor of your bucket objects. default: false =back Returns a reference to a hash containing the metadata for all of the buckets owned by the accout or (see below) or C on error. =over =item owner_id The owner ID of the bucket's owner. =item owner_display_name The name of the owner account. =item buckets An array of L objects for the account. Returns C if there are not buckets or an error occurs. =back =head2 add_bucket add_bucket(bucket-configuration) C is a reference to a hash with bucket configuration parameters. I See L. =over =item bucket The name of the bucket. See L for more details on bucket naming rules. =item acl_short (optional) See the set_acl subroutine for documenation on the acl_short options. Note that starting in April of 2023 new buckets are configured to automatically block public access. Trying to create a bucket with public permissions will fail. In order to create a public bucket you must first create a private bucket, then call the DeletePublicAccessBlock API. You can then set public permissions for your bucket using ACLs or a bucket policy. =item location_constraint =item region The region the bucket is to be created in. =item headers Additional headers to send with request. =back Returns a L object on success or C on failure. =head2 bucket bucket(bucket, [region]) bucket({ bucket => bucket-name, verify_region => boolean, region => region }); Takes a scalar argument or refernce to a hash of arguments. You can pass the region or set C indicating that you want the bucket constructor to detemine the bucket region. If you do not pass the region or set the C value, the region will be set to the default region set in your C object. See L for a complete description of the C method. =head2 delete_bucket Takes either a L object or a reference to a hash containing: =over =item bucket The name of the bucket to remove =item region Region the bucket is located in. If not provided, the method will determine the bucket's region by calling C. =back Returns a boolean indicating the success or failure of the API call. Check C or C for error messages. Note from the L =over 10 If a bucket is empty, you can delete it. After a bucket is deleted, the name becomes available for reuse. However, after you delete the bucket, you might not be able to reuse the name for various reasons. For example, when you delete the bucket and the name becomes available for reuse, another AWS account might create a bucket with that name. In addition, B. If you want to use the same bucket name, we recommend that you don't delete the bucket. =back =head2 delete_public_access_block delete_public_access_block(bucket-obj) Removes the public access block flag for the bucket. =head2 dns_bucket_names Set or get a boolean that indicates whether to use DNS bucket names. default: true =head2 err Returns the last error. Usually this is the error code returned from an API call or a short message that the describes the error. Use C for a more descriptive explanation of the error condition. =head2 errstr Detailed error description. =head2 list_bucket, list_bucket_v2 List keys in a bucket. Note that this method will only return C. If you want all of the keys you should use C or C. I and C descriptions below regarding how keys are counted against the C value.> Takes a reference to a hash of arguments: =over =item bucket (required) The name of the bucket you want to list keys on. =item prefix Restricts the response to only contain results that begin with the specified prefix. If you omit this optional argument, the value of prefix for your query will be the empty string. In other words, the results will be not be restricted by prefix. =item delimiter If this optional, Unicode string parameter is included with your request, then keys that contain the same string between the prefix and the first occurrence of the delimiter will be rolled up into a single result element in the CommonPrefixes collection. These rolled-up keys are not returned elsewhere in the response. For example, with prefix="USA/" and delimiter="/", the matching keys "USA/Oregon/Salem" and "USA/Oregon/Portland" would be summarized in the response as a single "USA/Oregon" element in the CommonPrefixes collection. If an otherwise matching key does not contain the delimiter after the prefix, it appears in the Contents collection. Each element in the CommonPrefixes collection counts as one against the C limit. The rolled-up keys represented by each CommonPrefixes element do not. In other words, key below the delimiter are not considered in the count. Remember that S3 keys do not represent a file system hierarchy although it might look like that depending on how you choose to store objects. Using the C and C parameters essentially allows you to restrict the return set to parts of your key "hierarchy". So in the example above If all I wanted was the very top level of the hierarchy I would set my C '/' and omit the C parameter. If the C parameter is not present in your request, keys in the result set will not be rolled-up and neither the CommonPrefixes collection nor the NextMarker element will be present in the response. NOTE: CommonPrefixes isn't currently supported by Amazon::S3. Example: Suppose I have the keys: bar/baz bar/buz bar/buz/biz bar/buz/zip And I'm only interest in object directly below 'bar' prefix=bar/ delimiter=/ Would yield: bar/baz bar/buz Omitting the delimiter would yield: bar/baz bar/buz bar/buz/biz bar/buz/zip =item max-keys This optional argument limits the number of results returned in response to your query. Amazon S3 will return no more than this number of results, but possibly less. Even if max-keys is not specified, Amazon S3 will limit the number of results in the response. Check the IsTruncated flag to see if your results are incomplete. If so, use the C parameter to request the next page of results. For the purpose of counting Cs, a 'result' is either a key in the 'Contents' collection, or a delimited prefix in the 'CommonPrefixes' collection. So for delimiter requests, max-keys limits the total number of list results, not just the number of keys. =item marker This optional parameter enables pagination of large result sets. C specifies where in the result set to resume listing. It restricts the response to only contain results that occur alphabetically after the value of marker. To retrieve the next page of results, use the last key from the current page of results as the marker in your next request. See also C, below. If C is omitted,the first page of results is returned. =back Returns C on error and a reference to a hash of data on success: The return value looks like this: { bucket => $bucket_name, prefix => $bucket_prefix, marker => $bucket_marker, next_marker => $bucket_next_available_marker, max_keys => $bucket_max_keys, is_truncated => $bucket_is_truncated_boolean keys => [$key1,$key2,...] } =over =item is_truncated Boolean flag that indicates whether or not all results of your query were returned in this response. If your results were truncated, you can make a follow-up paginated request using the Marker parameter to retrieve the rest of the results. =item next_marker A convenience element, useful when paginating with delimiters. The value of C, if present, is the largest (alphabetically) of all key names and all CommonPrefixes prefixes in the response. If the C flag is set, request the next page of results by setting C to the value of C. This element is only present in the response if the C parameter was sent with the request. =back Each key is a reference to a hash that looks like this: { key => $key, last_modified => $last_mod_date, etag => $etag, # An MD5 sum of the stored content. size => $size, # Bytes storage_class => $storage_class # Doc? owner_id => $owner_id, owner_displayname => $owner_name } =head2 get_bucket_location get_bucket_location(bucket-name) get_bucket_locaiton(bucket-obj) This is a convenience routines for the C of the bucket object. This method will return the default region of 'us-east-1' when C returns a null value. my $region = $s3->get_bucket_location('my-bucket'); Starting with version 0.55, C will call this C to determine the region for the bucket. You can get the region for the bucket by using the C method of the bucket object. my $bucket = $s3->bucket('my-bucket'); my $bucket_region = $bucket->region; =head2 get_logger Returns the logger object. If you did not set a logger when you created the object then an instance of C is returned. You can log to STDERR using this logger. For example: $s3->get_logger->debug('this is a debug message'); $s3->get_logger->trace(sub { return Dumper([$response]) }); =head2 list_bucket_all, list_bucket_all_v2 List all keys in this bucket without having to worry about 'marker'. This is a convenience method, but may make multiple requests to S3 under the hood. Takes the same arguments as C. I method.> =head2 list_object_versions list_object_versions( args ) Returns metadata about all versions of the objects in a bucket. You can also use request parameters as selection criteria to return metadata about a subset of all the object versions. This method will only return the raw result set and does not perform pagination or unravel common prefixes as do other methods like C. This may change in the future. See L for more information about the request parameters and the result body. C is hash reference containing the following parameters: =over 5 =item bucket Name of the bucket. This method is not vailable for directory buckets. =item headers Optional headers. See L for more details regarding optional headers. =item delimiter A delimiter is a character that you specify to group keys. All keys that contain the same string between the prefix and the first occurrence of the delimiter are grouped under a single result element in CommonPrefixes. These groups are counted as one result against the max-keys limitation. These keys are not returned elsewhere in the response. =item encoding-type Requests Amazon S3 to encode the object keys in the response and specifies the encoding method to use. =item key-marker Specifies the key to start with when listing objects in a bucket. =item max-keys Sets the maximum number of keys returned in the response. By default, the action returns up to 1,000 key names. The response might contain fewer keys but will never contain more. If additional keys satisfy the search criteria, but were not returned because max-keys was exceeded, the response contains true. To return the additional keys, see key-marker and version-id-marker. default: 1000 =item prefix Use this parameter to select only those keys that begin with the specified prefix. You can use prefixes to separate a bucket into different groupings of keys. (You can think of using prefix to make groups in the same way that you'd use a folder in a file system.) You can use prefix with delimiter to roll up numerous objects into a single result under CommonPrefixes. =item version-id-marker Specifies the object version you want to start listing from. =back =head2 err The S3 error code for the last error encountered. =head2 errstr A human readable error string for the last error encountered. =head2 error The decoded XML string as a hash object of the last error. =head2 last_response Returns the last L object. =head2 last_request Returns the last L object. =head2 level Set the logging level. default: error =head2 turn_on_special_retry Called to add extra retry codes if retry has been set =head2 turn_off_special_retry Called to turn off special retry codes when we are deliberately triggering them =head1 ABOUT This module contains code modified from Amazon that contains the following notice: # This software code is made available "AS IS" without warranties of any # kind. You may copy, display, modify and redistribute the software # code either by itself or as incorporated into your code; provided that # you do not remove any proprietary notices. Your use of this software # code is at your own risk and you waive any claim against Amazon # Digital Services, Inc. or its affiliates with respect to your use of # this software code. (c) 2006 Amazon Digital Services, Inc. or its # affiliates. =head1 TESTING Testing S3 is a tricky thing. Amazon wants to charge you a bit of money each time you use their service. And yes, testing counts as using. Because of this, the application's test suite skips anything approaching a real test unless you set certain environment variables. For more on testing this module see L =over =item AMAZON_S3_EXPENSIVE_TESTS Doesn't matter what you set it to. Just has to be set =item AMAZON_S3_HOST Sets the host to use for the API service. default: s3.amazonaws.com Note that if this value is set, DNS bucket name usage will be disabled for testing. Most likely, if you set this variable, you are using a mocking service and your bucket names are probably not resolvable. You can override this behavior by setting C to any value. =item AWS_S3_DNS_BUCKET_NAMES Set this to any value to override the default behavior of disabling DNS bucket names during testing. =item AWS_ACCESS_KEY_ID Your AWS access key =item AWS_SECRET_ACCESS_KEY Your AWS sekkr1t passkey. Be forewarned that setting this environment variable on a shared system might leak that information to another user. Be careful. =item AMAZON_S3_SKIP_ACL_TESTS Doesn't matter what you set it to. Just has to be set if you want to skip ACLs tests. =item AMAZON_S3_SKIP_PERMISSIONS Skip tests that check for enforcement of ACLs...as of this version, LocalStack for example does not support enforcement of ACLs. =item AMAZON_S3_SKIP_REGION_CONSTRAINT_TEST Doesn't matter what you set it to. Just has to be set if you want to skip region constraint test. =item AMAZON_S3_MINIO Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on minio. =item AMAZON_S3_LOCALSTACK Doesn't matter what you set it to. Just has to be set if you want to skip tests that would fail on LocalStack. =item AMAZON_S3_REGIONS A comma delimited list of regions to use for testing. The default will only test creating a bucket in the local region. =back I or C if you want to create real tests for your applications or this module.> Here's bash script for testing using LocalStack #!/bin/bash # -*- mode: sh; -*- BUCKET=net-amazon-s3-test-test ENDPOINT_URL=s3.localhost.localstack.cloud:4566 AMAZON_S3_EXPENSIVE_TESTS=1 \ AMAZON_S3_HOST=$ENDPOINT_URL \ AMAZON_S3_LOCALSTACK=1 \ AWS_ACCESS_KEY_ID=test \ AWS_ACCESS_SECRET_KEY=test \ AMAZON_S3_DOMAIN_BUCKET_NAMES=1 make test 2>&1 | tee test.log To run the tests...clone the project and build the software. cd src/main/perl ./test.localstack =head1 ADDITIONAL INFORMATION =head2 LOGGING AND DEBUGGING Additional debugging information can be output to STDERR by setting the C option when you instantiate the C object. Levels are represented as a string. The valid levels are: fatal error warn info debug trace You can set an optionally pass in a logger that implements a subset of the C interface. Your logger should support at least these method calls. If you do not supply a logger the default logger (C) will be used. get_logger() fatal() error() warn() info() debug() trace() level() At the C level, every HTTP request and response will be output to STDERR. At the C level information regarding the higher level methods will be output to STDERR. There currently is no additional information logged at lower levels. =head2 S3 LINKS OF INTEREST =over 5 =item L =item L =item L =item L =item L =item L =back =head1 SUPPORT Bugs should be reported via the CPAN bug tracker at L For other issues, contact the author. =head1 REPOSITORY L =head1 AUTHOR Original author: Timothy Appnel Current maintainer: Rob Lauer =head1 SEE ALSO L, L =head1 COPYRIGHT AND LICENCE This module was initially based on L 0.41, by Leon Brocard. Net::Amazon::S3 was based on example code from Amazon with this notice: I The software is released under the Artistic License. The terms of the Artistic License are described at http://www.perl.com/language/misc/Artistic.html. Except where otherwise noted, C is Copyright 2008, Timothy Appnel, tima@cpan.org. All rights reserved. =cut Amazon-S3-2.0.2/lib/Amazon/S3/0000755000175100017510000000000015103436527015061 5ustar rlauerrlauerAmazon-S3-2.0.2/lib/Amazon/S3/Logger.pm0000644000175100017510000000362415103436526016642 0ustar rlauerrlauerpackage Amazon::S3::Logger; use strict; use warnings; use Amazon::S3::Constants qw{ :chars }; use English qw{-no_match_vars}; use POSIX; use Readonly; use Scalar::Util qw{ reftype }; our $VERSION = '2.0.2'; ## no critic (RequireInterpolationOfMetachars) Readonly::Hash our %LOG_LEVELS => ( trace => 5, debug => 4, info => 3, warn => 2, error => 1, fatal => 0, ); { no strict 'refs'; ## no critic (ProhibitNoStrict) foreach my $level (qw{fatal error warn info debug trace}) { *{ __PACKAGE__ . $DOUBLE_COLON . $level } = sub { my ( $self, @message ) = @_; $self->_log_message( $level, @message ); }; } } ######################################################################## sub new { ######################################################################## my ( $class, @args ) = @_; my $options = ref $args[0] ? $args[0] : {@args}; return bless $options, $class; } ######################################################################## sub level { ######################################################################## my ( $self, @args ) = @_; if (@args) { $self->{log_level} = $args[0]; } return $self->{log_level}; } ######################################################################## sub _log_message { ######################################################################## my ( $self, $level, @message ) = @_; return if $LOG_LEVELS{ lc $level } > $LOG_LEVELS{ lc $self->{log_level} }; return if !@message; my $log_message; if ( defined $message[0] && ref $message[0] && reftype( $message[0] ) eq 'CODE' ) { $log_message = $message[0]->(); } else { $log_message = join $EMPTY, @message; } chomp $log_message; my @tm = localtime time; my $timestamp = POSIX::strftime '%Y/%m/%d %H:%M:%S', @tm; return print {*STDERR} sprintf qq{%s: %s %s %s\n}, uc $level, $timestamp, $PROCESS_ID, $log_message; } 1; Amazon-S3-2.0.2/lib/Amazon/S3/BucketV2.pm0000644000175100017510000005111215103436526017043 0ustar rlauerrlauerpackage Amazon::S3::BucketV2; use strict; use warnings; use Amazon::S3::Constants qw(:all); use Amazon::S3::Util qw(:all); use Carp; use Data::Dumper; use English qw(-no_match_vars); use List::Util qw(pairs); use Scalar::Util qw(reftype); use parent qw(Amazon::S3::Bucket); our $VERSION = '2.0.2'; ## no critic (RequireInterpolation) ###################################################################### our @GET_OBJECT_METHODS = ( ###################################################################### get_object_acl => 'acl', get_object_attributes => 'attributes', get_object_legal_hold => 'legal-hold', get_object_lock_configuration => 'object-lock', get_object_retention => 'retention', get_object_tagging => 'tagging', get_object_torrent => 'torrent', get_public_access_block => 'publicAccessBlock', ); create_methods( type => 'object', method => 'GET', method_def => \@GET_OBJECT_METHODS ); ###################################################################### our @HEAD_OBJECT_METHODS = ( get_object_head => 'head', ); ###################################################################### create_methods( type => 'object', method => 'HEAD', method_def => [ head_object => $EMPTY ] ); create_methods( type => 'bucket', method => 'HEAD', method_def => [ head_bucket => $EMPTY ] ); ###################################################################### our @GET_BUCKET_METHODS = ( ###################################################################### get_bucket_accelerate_configuration => 'accelerate', get_bucket_acl => 'acl', get_bucket_analytics => 'analytics', get_bucket_cors => 'cors', get_bucket_encryption => 'encryption', get_bucket_intelligent_tiering_configuration => 'intelligent_tiering', get_bucket_inventory_configuration => 'inventory', get_bucket_lifecycle_configuration => 'lifecycle', get_bucket_location => 'location', get_bucket_logging => 'logging', get_bucket_metrics_configuration => 'metrics', get_bucket_notification_configuration => 'notification', get_bucket_ownership_controls => 'ownershipControls', get_bucket_policy => 'policy', get_bucket_policy_status => 'policyStatus', get_bucket_replication => 'replication', get_bucket_request_payment => 'requestPayment', get_bucket_tagging => 'tagging', get_bucket_versioning => 'versioning', get_bucket_website => 'website', ); create_methods( type => 'bucket', method => 'GET', method_def => \@GET_BUCKET_METHODS, ); ####################################################################### our @PUT_BUCKET_METHODS = ( ####################################################################### put_bucket_intelligent_tiering_configuration => 'intelligent-tiering', put_bucket_cors => 'cors', put_bucket_replication_configuration => 'replication', put_bucket_versioning => 'versioning', put_bucket_encryption => 'encryption', put_bucket_lifecycle_configuration => 'lifecycle', put_bucket_lifecycle => 'lifecycle', put_bucket_tagging => 'tagging', ); create_methods( type => 'bucket', method => 'PUT', method_def => \@PUT_BUCKET_METHODS ); ###################################################################### our @PUT_OBJECT_METHODS = ( ####################################################################### put_object => $EMPTY, put_object_acl => 'acl', put_object_tagging => 'tagging', put_object_retention => 'retention', put_object_legal_hold => 'legal-hold', put_object_lock_configuraiton => 'lock-object', put_public_access_block => 'publicAccessBlock', restore_object => sub { return { method => 'POST', api => 'restore' }; }, upload_part => $EMPTY, upload_part_copy => $EMPTY, ); create_methods( type => 'object', method => 'PUT', method_def => \@PUT_OBJECT_METHODS, ); ###################################################################### our @DELETE_OBJECT_METHODS = ( ###################################################################### delete_object => $EMPTY, delete_objects => sub { return { method => 'POST', api => 'delete' }; }, delete_object_tagging => 'tagging', ); create_methods( type => 'object', method => 'DELETE', method_def => \@DELETE_OBJECT_METHODS, ); ###################################################################### our @DELETE_BUCKET_METHODS = ( ###################################################################### delete_bucket => $EMPTY, delete_bucket_analytics_configuration => 'analytics', delete_bucket_cors => 'cors', delete_bucket_encryption => 'encryption', delete_bucket_intelligent_tiering => 'intelligent-tiering', delete_bucket_inventory_configuration => 'inventory', delete_bucket_lifecycle => 'lifecycle', delete_bucket_metrics_configuration => 'metrics', delete_bucket_ownership_controls => 'ownershipControls', delete_bucket_policy => 'policy', delete_bucket_replication => 'replication', delete_bucket_tagging => 'tagging', delete_bucket_website => 'website', delete_public_access_block => 'publicAccessBlock', ); create_methods( type => 'bucket', method => 'DELETE', method_def => \@DELETE_BUCKET_METHODS ); ######################################################################## sub new { ######################################################################## my ( $class, @args ) = @_; return $class->SUPER::new(@args); } ######################################################################## sub to_camel_case { ######################################################################## my ($method) = @_; return join $EMPTY, map { ucfirst $_ } split /_/xsm, $method; } ######################################################################## # send_request() ######################################################################## # This is a general purpose method to send requests that may include an # XML payload. These requests may also accept headers or query string # parameters. # # args is a hash ref or list of key/value pairs # api => name of the API to invoke (example: 'versioning') # content_key => optional root element for XML serialzation # headers => optional headers - create a Content-MD5 key in the headers # object if you want to add the MD5 value # bucket => optional bucket name # key => optional key value for APIs that accept a key # data => optional object that will be converted to an XML payload # method => HTTP method # # NOTES: # 1. If the 'data' object is included, the default method is 'PUT' # 2. If no 'data' object is included, the default method is 'GET' # 3. If 'content_key' is not provided when including a 'data' object # the method will attempt to guess the root element (content_key) # when serializing the data object to XML. If you include # additional elements to be used as query string parameters, # you should specify 'content_key'.. ######################################################################## sub send_request { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my $account = $self->account; my $headers = delete $parameters->{headers}; $headers //= {}; my $bucket = delete $parameters->{bucket}; $bucket //= $self->bucket; croak 'no bucket' if !$bucket; my $key = delete $parameters->{key} // $EMPTY; my $api = delete $parameters->{api}; croak 'no api' if !defined $api; my $path = delete $parameters->{path}; my $method = delete $parameters->{method}; # see if we need to send an XML payload my $data = delete $parameters->{data}; if ($data) { my $content_key = delete $parameters->{content_key}; # if we are sending data, include MD5 by default my $md5 = delete $parameters->{md5}; $md5 //= $TRUE; if ( !$content_key ) { ($content_key) = keys %{$parameters}; } $data = create_xml_request($data); if ( $md5 || exists $headers->{'Content-MD5'} ) { set_md5_header( data => $data, headers => $headers ); } } # create the URI from bucket, key, api and possibly additional parameters $path //= sprintf '%s/%s?%s', $bucket, $key, $api; if ( keys %{$parameters} ) { my $query_string = create_query_string( %{$parameters} ); if ( $path !~ /[?]$/xsm ) { $query_string = "&$query_string"; } $path .= $query_string; } return $account->_send_request( { region => $self->region, method => $method // 'GET', path => $path, headers => $headers, $data ? ( data => $data ) : (), } ); } ######################################################################## sub create_methods { ######################################################################## my (%args) = @_; my ( $type, $method, $method_def ) = @args{qw( type method method_def)}; no strict 'refs'; ## no critic foreach my $p ( pairs @{$method_def} ) { my ( $sub_name, $api ) = @{$p}; if ( ref($api) && reftype($api) eq 'CODE' ) { my $api_params = $api->(); ( $method, $api ) = @{$api_params}{qw(method api)}; } my $anon = sub { my ( $self, %args ) = @_; my ( $key, $body, $uri_params, $headers ) = @args{qw(key body uri_param headers)}; $uri_params //= {}; return $self->send_request( method => $method, api => $api, headers => $headers, $key ? ( key => $key ) : (), $body ? ( data => $body ) : (), %{$uri_params}, ); }; $sub_name = sprintf 'Amazon::S3::Bucket::%s', to_camel_case($sub_name); *{$sub_name} = $anon; } return; } 1; __END__ =pod =head1 NAME Amazon::S3::BucketV2 - lightweight interface to various S3 methods =head1 SYNOPSIS use Amazon::S3; use Amazon::S3::BucketV2; my $s3 = Amazon::S3->new( { aws_access_key_id => $aws_access_key_id, aws_secret_access_key => $aws_secret_access_key, } ); my $s3 = Amazon::S3->new(); my $bucket = Amazon::S3::BucketV2->new(account => $s3, bucket => 'foo'); $bucket->DeleteObject($key); $bucket->DeleteObjects(undef, { Delete => { Object => [ { Key => $key, Version => $version } ] } } ); =head1 DESCRIPTION A lightweight, generic interface to the AWS S3 API. C is a subclass of L. In addition to the methods described below you can still use the convenience methods offered in the parent class. I The methods listed below should be called with a list (or hash reference) of key/value pairs. Depending on your needs and the API being invoked some of these keys may not be required. =over 5 =item key The key in the S3 bucket. =item body The request body. This should be a hash ref which will be converted to an XML payload to be sent for the request. You need to review the required payload for the API being invoked and provide the appropriate Perl object to be converted to XML. To see how your Perl object will be serialized call the C method. For example the DeleteObjects API takes a payload that looks like this: string string ... boolean The corresponding Perl object would be created like this: my $content = { Delete => { Object => [ { Key => '/foo', VersionId => 'OYcLXagmS.WaD..oyH4KRguB95_YhLs7' } ] } }; ...and to verify how that Perl object would be serialized as XML: use Amazon::S3::Util qw(create_xml_request); my $content = { Delete => { Object => [ { Key => '/foo', VersionId => 'OYcLXagmS.WaD..oyH4KRguB95_YhLs7' } ] } }; print create_xml_request($content); =item uri_params A hash ref of additional query string parameters. =item headers A hash ref of additional headers to send with the request. The API methods will automatically add the rquired headers for most calls. Review the API specifications to see how to send additional headers you might require. =back Example: $bucket->DeleteObject(key => $key); $bucket->DeleteObject(key => $key, uri_param => { versionId => $version }); my $content = { Delete => { Object => [ { Key => $key, Version => $version } ] } }; $bucket->DeleteObject(body => $content); =head1 METHODS AND SUBROUTINES The methods below can be called in snake or CamelCase. Consult the official AWS S3 API guide for documentation on each method. L =head2 delete_bucket L =head2 delete_bucket_analytics_configuration L =head2 delete_bucket_cors L =head2 delete_bucket_encryption L =head2 delete_bucket_intelligent_tiering L =head2 delete_bucket_inventory_configuration L =head2 delete_bucket_lifecycle L =head2 delete_bucket_metrics_configuration L =head2 delete_bucket_ownership_controls L =head2 delete_bucket_policy L =head2 delete_bucket_replication L =head2 delete_bucket_tagging L =head2 delete_bucket_website L =head2 delete_object L =head2 delete_objects L =head2 delete_object_tagging L =head2 delete_public_access_block L =head2 get_bucket_accelerate_configuration L =head2 get_bucket_acl L =head2 get_bucket_analytics L =head2 get_bucket_cors L =head2 get_bucket_encryption L =head2 get_bucket_intelligent_tiering_configuration L =head2 get_bucket_inventory_configuration L =head2 get_bucket_lifecycle_configuration L =head2 get_bucket_location L =head2 get_bucket_logging L =head2 get_bucket_metrics_configuration L =head2 get_bucket_notification_configuration L =head2 get_bucket_ownership_controls L =head2 get_bucket_policy L =head2 get_bucket_policy_status L =head2 get_bucket_replication L =head2 get_bucket_request_payment L =head2 get_bucket_tagging L =head2 get_bucket_versioning L =head2 get_bucket_website L =head2 get_object_acl L =head2 get_object_attributes L =head2 get_object_legal_hold L =head2 get_object_lock_configuration L =head2 get_object_retention L =head2 get_object_tagging L =head2 get_object_torrent L =head2 get_public_access_block L =head2 put_bucket_cors L =head2 put_bucket_encryption L =head2 put_bucket_intelligent_tiering_configuration L =head2 put_bucket_lifecycle L =head2 put_bucket_lifecycle_configuration L =head2 put_bucket_replication_configuration L =head2 put_bucket_tagging L =head2 put_bucket_versioning L =head2 put_object L =head2 put_object_acl L =head2 put_object_legal_hold L =head2 put_object_lock_configuraiton L =head2 put_object_retention L =head2 put_object_tagging L =head2 put_public_access_block L =head2 restore_object L =head2 upload_part L =head2 upload_part_copy L =head1 SEE OTHER L, L =head1 AUTHOR Rob Lauer - =cut Amazon-S3-2.0.2/lib/Amazon/S3/Bucket.pm0000644000175100017510000013635615103436526016651 0ustar rlauerrlauerpackage Amazon::S3::Bucket; use strict; use warnings; use Amazon::S3::Constants qw(:all); use Amazon::S3::Util qw(:all); 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 IO::File; use IO::Scalar; use MIME::Base64; use List::Util qw(none pairs); use Scalar::Util qw(reftype); use URI; use XML::Simple; ## no critic (DiscouragedModules) use parent qw(Exporter Class::Accessor::Fast); our $VERSION = '2.0.2'; ## no critic (RequireInterpolation) __PACKAGE__->mk_accessors( qw( bucket creation_date account buffer_size region logger 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, $key, $value, $conf ) = @_; croak 'must specify key' if !$key || !length $key; $conf //= {}; my $account = $self->account; my $headers = delete $conf->{headers}; $headers //= {}; if ( $conf->{acl_short} ) { $account->_validate_acl_short( $conf->{acl_short} ); $conf->{'x-amz-acl'} = $conf->{acl_short}; delete $conf->{acl_short}; } $headers = { %{$conf}, %{$headers} }; set_md5_header( data => $value, headers => $headers ); if ( ref $value ) { $value = _content_sub( ${$value}, $self->buffer_size ); $headers->{'x-amz-content-sha256'} = 'UNSIGNED-PAYLOAD'; } # If we're pushing to a bucket that's under # DNS flux, we might get a 307 Since LWP doesn't support actually # waiting for a 100 Continue response, we'll just send a HEAD first # to see what's going on my $retval = eval { return $self->_add_key( { headers => $headers, data => $value, key => $key, }, ); }; # one more try? if someone specified the wrong region, we'll get a # 301 and you'll only know the region of redirection - no location # header provided... if ($EVAL_ERROR) { my $rsp = $account->last_response; if ( $rsp->code eq $HTTP_MOVED_PERMANENTLY ) { $self->region( $rsp->headers->{'x-amz-bucket-region'} ); } $retval = $self->_add_key( { headers => $headers, data => $value, key => $key, }, ); } return $retval; } ######################################################################## sub _add_key { ######################################################################## my ( $self, @args ) = @_; my ( $data, $headers, $key ) = @{ $args[0] }{qw{data headers key}}; my $account = $self->account; if ( ref $data ) { return $account->_send_request_expect_nothing_probed( { method => 'PUT', path => $self->_uri($key), headers => $headers, data => $data, region => $self->region, }, ); } else { return $account->_send_request_expect_nothing( { method => 'PUT', path => $self->_uri($key), headers => $headers, data => $data, region => $self->region, }, ); } } ######################################################################## sub add_key_filename { ######################################################################## my ( $self, $key, $value, $conf ) = @_; return $self->add_key( $key, \$value, $conf ); } ######################################################################## sub upload_multipart_object { ######################################################################## my ( $self, @args ) = @_; my $logger = $self->logger; my $parameters = get_parameters(@args); croak 'no key!' if !$parameters->{key}; croak 'either data, callback or fh must be set!' if !$parameters->{data} && !$parameters->{callback} && !$parameters->{fh}; croak 'callback must be a reference to a subroutine!' if $parameters->{callback} && reftype( $parameters->{callback} ) ne 'CODE'; $parameters->{abort_on_error} //= $TRUE; $parameters->{chunk_size} //= $MIN_MULTIPART_UPLOAD_CHUNK_SIZE; if ( !$parameters->{callback} && !$parameters->{fh} ) { #...but really nobody should be passing a >5MB scalar my $data = ref $parameters->{data} ? $parameters->{data} : \$parameters->{data}; $parameters->{fh} = IO::Scalar->new($data); } # ...having a file handle implies, we use this callback if ( $parameters->{fh} ) { my $fh = $parameters->{fh}; $fh->seek( 0, 2 ); my $length = $fh->tell; $fh->seek( 0, 0 ); $logger->trace( sub { return sprintf 'length of object: %s', $length; } ); croak 'length of the object must be >= ' . $MIN_MULTIPART_UPLOAD_CHUNK_SIZE if $length < $MIN_MULTIPART_UPLOAD_CHUNK_SIZE; my $chunk_size = ( $parameters->{chunk_size} && $parameters->{chunk_size} ) > $MIN_MULTIPART_UPLOAD_CHUNK_SIZE ? $parameters->{chunk_size} : $MIN_MULTIPART_UPLOAD_CHUNK_SIZE; $parameters->{callback} = sub { return if !$length; my $bytes_read = 0; my $n = $length >= $chunk_size ? $chunk_size : $length; $logger->trace( sprintf 'reading %d bytes', $n ); my $buffer; my $bytes = $fh->read( $buffer, $n, $bytes_read ); $logger->trace( sprintf 'read %d bytes', $bytes ); $bytes_read += $bytes; $length -= $bytes; $logger->trace( sprintf '%s bytes left to read', $length ); return ( \$buffer, $bytes ); }; } my $headers = $parameters->{headers} || {}; my $id = $self->initiate_multipart_upload( $parameters->{key}, $headers ); $logger->trace( sprintf 'multipart id: %s', $id ); my $part = 1; my %parts; my $key = $parameters->{key}; my $retval = eval { while (1) { my ( $buffer, $length ) = $parameters->{callback}->(); last if !$buffer; my $etag = $self->upload_part_of_multipart_upload( { id => $id, key => $key, data => $buffer, part => $part, }, ); $parts{ $part++ } = $etag; } $self->complete_multipart_upload( $parameters->{key}, $id, \%parts ); }; if ( $EVAL_ERROR && $parameters->{abort_on_error} ) { $self->abort_multipart_upload( $key, $id ); %parts = (); } return \%parts; } # Initiates a multipart upload operation. This is necessary for uploading # files > 5Gb to Amazon S3 # # returns: upload ID assigned by Amazon (used to identify this # particular upload in other operations) ######################################################################## sub initiate_multipart_upload { ######################################################################## my ( $self, $key, $headers ) = @_; croak 'Object key is required' if !$key; my $acct = $self->account; my $request = $acct->_make_request( { region => $self->region, method => 'POST', path => $self->_uri($key) . '?uploads=', headers => $headers, }, ); my $response = $acct->_do_http($request); $acct->_croak_if_response_error($response); my $r = $acct->_xpc_of_content( $response->content ); return $r->{UploadId}; } # # Upload a part of a file as part of a multipart upload operation # Each part must be at least 5mb (except for the last piece). # This returns the Amazon-generated eTag for the uploaded file segment. # It is necessary to keep track of the eTag for each part number # The complete operation will want a sequential list of all the part # numbers along with their eTags. # ######################################################################## sub upload_part_of_multipart_upload { ######################################################################## my ( $self, @args ) = @_; my ( $key, $upload_id, $part_number, $data, $length ); if ( @args == 1 ) { if ( reftype( $args[0] ) eq 'HASH' ) { ( $key, $upload_id, $part_number, $data, $length ) = @{ $args[0] }{qw{ key id part data length}}; } elsif ( reftype( $args[0] ) eq 'ARRAY' ) { ( $key, $upload_id, $part_number, $data, $length ) = @{ $args[0] }; } } else { ( $key, $upload_id, $part_number, $data, $length ) = @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 ); 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 $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 ) = @_; $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'; # 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); $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); if ( $response->code !~ /\A2\d\d\z/xsm ) { $acct->_remember_errors( $response->content, 1 ); croak $response->status_line; } 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 # It returns the block of XML returned from Amazon # ######################################################################## sub list_multipart_upload_parts { ######################################################################## my ( $self, $key, $upload_id, $headers ) = @_; 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 => 'GET', path => $self->_uri($key) . $params, headers => $headers, }, ); my $response = $acct->_do_http($request); $acct->_croak_if_response_error($response); # Just return the XML, let the caller figure out what to do with it return $response->content; } # List all the currently active multipart upload operations # Returns the block of XML returned from Amazon ######################################################################## sub list_multipart_uploads { ######################################################################## my ( $self, $headers ) = @_; my $acct = $self->account; my $request = $acct->_make_request( { region => $self->region, method => 'GET', path => $self->_uri() . '?uploads', headers => $headers, }, ); my $response = $acct->_do_http($request); $acct->_croak_if_response_error($response); # Just return the XML, let the caller figure out what to do with it return $response->content; } ######################################################################## sub head_key { ######################################################################## my ( $self, $key ) = @_; return $self->get_key( $key, 'HEAD' ); } ######################################################################## sub get_key_v2 { ######################################################################## my ( $self, $key, $method, $headers ) = @_; return $self->_get_key( $key, $method, undef, $headers ); } ######################################################################## sub get_key { ######################################################################## my ( $self, @args ) = @_; my ( $key, $method, $headers, $uri_params ); if ( ref $args[0] ) { ( $key, $method, $headers, $uri_params ) = @{ $args[0] }{qw(key method headers uri_params)}; } else { ( $key, $method, $headers, $uri_params ) = @args; } return $self->_get_key( key => $key, method => $method, filename => undef, headers => $headers, uri_params => $uri_params, ); } ######################################################################## sub _get_key { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my ( $key, $method, $filename, $headers, $uri_params ) = @{$parameters}{qw(key method filename headers uri_params)}; $method //= 'GET'; my $uri = $self->_uri($key); if ( $uri_params && keys %{$uri_params} ) { $uri = $QUESTION_MARK . create_query_string($uri_params); } if ( ref $filename ) { $filename = ${$filename}; } my $acct = $self->account; my $request = $acct->_make_request( { region => $self->region, method => $method, path => $uri, headers => $headers, }, ); my $response = $acct->_do_http( $request, $filename ); return if $response->code eq $HTTP_NOT_FOUND; $acct->_croak_if_response_error($response); my $etag = $response->header('ETag'); if ($etag) { $etag =~ s/^"//xsm; $etag =~ s/"$//xsm; } my $retval = { content_length => ( $response->content_length || 0 ), content_type => scalar $response->content_type, etag => $etag, value => ( $response->content // $EMPTY ), content_range => ( $response->header('Content-Range') || $EMPTY ), last_modified => ( $response->header('Last-Modified') || $EMPTY ), }; # Validate against data corruption by verifying the MD5 (only if not partial) if ( $method eq 'GET' && $response->code ne $HTTP_PARTIAL_CONTENT ) { my $md5 = ( $filename and -f $filename ) ? file_md5_hex($filename) : md5_hex( $retval->{value} ); # Some S3-compatible providers return an all-caps MD5 value in the # etag so it should be lc'd for comparison. croak "Computed and Response MD5's do not match: $md5 : $etag" if $md5 ne lc $etag; } foreach my $header ( $response->headers->header_field_names ) { next if $header !~ /x-amz-meta-/ixsm; $retval->{ lc $header } = $response->header($header); } return $retval; } ######################################################################## sub get_key_filename { ######################################################################## my ( $self, @args ) = @_; my ( $key, $method, $filename, $headers, $uri_params ); if ( ref $args[0] ) { ( $key, $method, $filename, $headers, $uri_params ) = @{ $args[0] }{qw(key method filename headers uri_params)}; } else { ( $key, $method, $filename, $headers, $uri_params ) = @args; } if ( !defined $filename ) { $filename = $key; } return $self->_get_key( key => $key, method => $method, filename => \$filename, headers => $headers, uri_params => $uri_params, ); } ######################################################################## # See: https://docs.aws.amazon.com/AmazonS3/latest/API/API_CopyObject.html # # Note that in this request the bucket object is the destination you # specify the source bucket in the key (bucket-name/source-key) or the # header x-amz-copy-source ######################################################################## sub copy_object { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my ( $source, $key, $bucket, $headers_in ) = @{$parameters}{qw(source key bucket headers)}; $headers_in //= {}; my %request_headers; if ( reftype($headers_in) eq 'ARRAY' ) { %request_headers = @{$headers_in}; } elsif ( reftype($headers_in) eq 'HASH' ) { %request_headers = %{$headers_in}; } else { croak 'headers must be hash or array' if !ref($headers_in) || reftype($headers_in) ne 'HASH'; } croak 'source or x-amz-copy-source must be specified' if !$source && !exists $request_headers{'x-amz-copy-source'}; croak 'no key' if !$key; my $acct = $self->account; $bucket //= $self->bucket(); if ( !$request_headers{'x-amz-copy-source'} ) { $request_headers{'x-amz-copy-source'} = sprintf '%s/%s', $bucket, urlencode($source); } $request_headers{'x-amz-tagging-directive'} //= 'COPY'; $key = $self->_uri($key); my $request = $acct->_make_request( method => 'PUT', path => $key, headers => \%request_headers, ); my $response = $acct->_do_http($request); if ( $response->code !~ /\A2\d{2}\z/xsm ) { $acct->_remember_errors( $response->content, 1 ); croak $response->status_line; } return $acct->_xpc_of_content( $response->content ); } ######################################################################## sub delete_key { ######################################################################## my ( $self, $key, $version ) = @_; croak 'must specify key' if !$key && length $key; my $account = $self->account; my $path = $self->_uri($key); if ($version) { $path = '?versionId=' . $version; } return $account->_send_request_expect_nothing( { method => 'DELETE', region => $self->region, path => $path, headers => {}, }, ); } ######################################################################## sub _format_delete_keys { ######################################################################## my (@args) = @_; my @keys; if ( ref $args[0] ) { if ( reftype( $args[0] ) eq 'ARRAY' ) { # list of keys, no version ids foreach my $key ( @{ $args[0] } ) { if ( ref($key) && reftype($key) eq 'HASH' ) { push @keys, { Key => [ $key->{Key} ], defined $key->{VersionId} ? ( VersionId => [ $key->{VersionId} ] ) : (), }; } else { # array of keys push @keys, { Key => [$key], }; } } } elsif ( reftype( $args[0] ) eq 'CODE' ) { # sub that returns key, version id while ( my (@object) = $args[0]->() ) { last if !@object || !defined $object[0]; push @keys, { Key => [ $object[0] ], defined $object[1] ? ( VersionId => [ $object[1] ] ) : (), }; } } else { # list of keys croak 'argument must be array or list'; } } elsif (@args) { @keys = map { { Key => [$_] } } @args; } else { croak 'must specify keys'; } croak 'must not exceed ' . $MAX_DELETE_KEYS . ' keys' if @keys > $MAX_DELETE_KEYS; return \@keys; } # @args => list of keys # $args[0] => array of hashes (Key, [VersionId]) VersionId is optional # $args[0] => array of scalars (keys) # $args[0] => code reference that returns key, version id or empty # $args[0] => hash ({ quiet => 1, keys => $keys}) # Throws exception if no keys or in wrong format... ######################################################################## sub delete_keys { ######################################################################## my ( $self, @args ) = @_; my ( $keys, $quiet_mode, $headers ); if ( ref $args[0] && reftype( $args[0] ) eq 'HASH' ) { ( $keys, $quiet_mode, $headers ) = @{ $args[0] }{qw(keys quiet headers)}; $keys = _format_delete_keys($keys); } else { $keys = _format_delete_keys(@args); } if ( defined $quiet_mode ) { $quiet_mode = $quiet_mode ? 'true' : 'false'; } else { $quiet_mode = 'false'; } my $content = { xmlns => $S3_XMLNS, Quiet => [$quiet_mode], Object => $keys, }; my $xml_content = XMLout( $content, RootName => 'Delete', XMLDecl => $XMLDECL, ); my $account = $self->account; my $md5 = md5($xml_content); my $md5_base64 = encode_base64($md5); chomp $md5_base64; $headers //= {}; $headers->{'Content-MD5'} = $md5_base64; return $account->_send_request( { method => 'POST', region => $self->region, path => $self->_uri() . '?delete', headers => $headers, data => $xml_content, }, ); } ######################################################################## sub delete_bucket { ######################################################################## my ($self) = @_; croak 'Unexpected arguments' if @_ > 1; return $self->account->delete_bucket($self); } ######################################################################## sub list_v2 { ######################################################################## my ( $self, $conf ) = @_; $conf ||= {}; $conf->{bucket} = $self->bucket; $conf->{'list-type'} = '2'; if ( $conf->{'marker'} ) { $conf->{'continuation-token'} = delete $conf->{'marker'}; } return $self->list($conf); } ######################################################################## sub list { ######################################################################## my ( $self, $conf ) = @_; $conf ||= {}; $conf->{bucket} = $self->bucket; return $self->account->list_bucket($conf); } ######################################################################## sub list_all_v2 { ######################################################################## my ( $self, $conf ) = @_; $conf //= {}; $conf->{bucket} = $self->bucket; return $self->account->list_bucket_all_v2($conf); } ######################################################################## sub list_all { ######################################################################## my ( $self, $conf ) = @_; $conf //= {}; $conf->{bucket} = $self->bucket; return $self->account->list_bucket_all($conf); } ######################################################################## sub get_acl { ######################################################################## my ( $self, $key, $headers ) = @_; my $account = $self->account; my $request = $account->_make_request( { region => $self->region, method => 'GET', path => $self->_uri($key) . '?acl=', headers => $headers // {}, }, ); my $old_redirectable = $account->ua->requests_redirectable; $account->ua->requests_redirectable( [] ); my $response = $account->_do_http($request); if ( $response->code =~ /^30/xsm ) { my $xpc = $account->_xpc_of_content( $response->content ); my $uri = URI->new( $response->header('location') ); my $old_host = $account->host; $account->host( $uri->host ); $request = $account->_make_request( { region => $self->region, method => 'GET', path => $uri->path, headers => {}, }, ); $response = $account->_do_http($request); $account->ua->requests_redirectable($old_redirectable); $account->host($old_host); } my $content; # do we test for NOT FOUND, returning undef? if ( $response->code ne $HTTP_NOT_FOUND ) { $account->_croak_if_response_error($response); $content = $response->content; } return $content; } ######################################################################## sub set_acl { ######################################################################## my ( $self, $conf ) = @_; my $account = $self->account; $conf //= {}; croak 'need either acl_xml or acl_short' if !$conf->{acl_xml} && !$conf->{acl_short}; croak 'cannot provide both acl_xml and acl_short' if $conf->{acl_xml} && $conf->{acl_short}; my $path = $self->_uri( $conf->{key} ) . '?acl'; my $headers = $conf->{headers}; if ( $conf->{acl_short} ) { $headers->{'x-amz-acl'} //= $conf->{acl_short}; } my $xml = $conf->{acl_xml} // $EMPTY; $headers->{'Content-Length'} = length $xml; return $account->_send_request_expect_nothing( { method => 'PUT', path => $path, headers => $headers, data => $xml, region => $self->region, }, ); } ######################################################################## sub get_location_constraint { ######################################################################## my ( $self, @args ) = @_; my $parameters = get_parameters(@args); my ( $bucket, $headers, $region ) = @{$parameters}{qw(bucket headers region)}; my $account = $self->account; $bucket //= $self->bucket; my $location = $account->_send_request( { region => $region // $self->region, method => 'GET', path => $bucket . '/?location=', headers => $headers, }, ); return $location if $location; croak $account->errstr if $account->_remember_errors($location); return; } ######################################################################## sub last_response { ######################################################################## my ($self) = @_; return $self->account->last_response; } ######################################################################## sub err { ######################################################################## my ($self) = @_; return $self->account->err; } ######################################################################## sub errstr { ######################################################################## my ($self) = @_; return $self->account->errstr; } ######################################################################## sub error { ######################################################################## my ($self) = @_; return $self->account->error; } ######################################################################## sub _content_sub { ######################################################################## my ( $filename, $buffer_size ) = @_; my $stat = stat $filename; my $remaining = $stat->size; my $blksize = $stat->blksize || $buffer_size; croak "$filename not a readable file with fixed size" if !-r $filename || !$remaining; my $fh = IO::File->new( $filename, 'r' ) or croak "Could not open $filename: $OS_ERROR"; $fh->binmode; return sub { my $buffer; # upon retries the file is closed and we must reopen it if ( !$fh->opened ) { $fh = IO::File->new( $filename, 'r' ) or croak "Could not open $filename: $OS_ERROR"; $fh->binmode; $remaining = $stat->size; } my $read = $fh->read( $buffer, $blksize ); if ( !$read ) { croak "Error while reading upload content $filename ($remaining remaining) $OS_ERROR" if $OS_ERROR and $remaining; $fh->close # otherwise, we found EOF or croak "close of upload content $filename failed: $OS_ERROR"; $buffer ||= $EMPTY; # LWP expects an empty string on finish, read returns 0 } $remaining -= length $buffer; return $buffer; }; } ######################################################################## sub _create_multipart_upload_request { ######################################################################## my ($parts_hr) = @_; my @parts; foreach my $part_num ( sort { $a <=> $b } keys %{$parts_hr} ) { push @parts, { PartNumber => $part_num, ETag => $parts_hr->{$part_num}, }; } return create_xml_request( { CompleteMultipartUpload => { Part => \@parts } } ); } 1; __END__ =pod =head1 NAME Amazon::S3::Bucket - A container class for a S3 bucket and its contents. =head1 SYNOPSIS use Amazon::S3; # creates bucket object (no "bucket exists" check) my $bucket = $s3->bucket("foo"); # create resource with meta data (attributes) my $keyname = 'testing.txt'; my $value = 'T'; $bucket->add_key( $keyname, $value, { content_type => 'text/plain', 'x-amz-meta-colour' => 'orange', } ); # list keys in the bucket $response = $bucket->list or die $s3->err . ": " . $s3->errstr; print $response->{bucket}."\n"; for my $key (@{ $response->{keys} }) { print "\t".$key->{key}."\n"; } # check if resource exists. print "$keyname exists\n" if $bucket->head_key($keyname); # delete key from bucket $bucket->delete_key($keyname); =head1 DESCRIPTION Class for interacting with AWS S3 buckets. =head1 METHODS AND SUBROUTINES =head2 new Instaniates a new bucket object. Pass a hash or hash reference containing various options: =over =item bucket (required) The name (identifier) of the bucket. =item account (required) The L object (representing the S3 account) this bucket is associated with. =item buffer_size The buffer size used for reading and writing objects to S3. default: 4K =item region If no region is set and C is set to true, the region of the bucket will be determined by calling the C method. Note that this will decrease performance of the constructor. If you know the region or are operating in only 1 region, set the region in the C object (C). =item logger Sets the logger. The logger should be a blessed reference capable of providing at least a C and C method for recording log messages. If no logger object is passed the C object's logger object will be used. =item verify_region Indicates that the bucket's region should be determined by calling the C method. default: false =back I This method does not check if a bucket actually exists unless you set C to true. If the bucket does not exist, the constructor will set the region to the default region specified by the L object (C) that you passed. Typically a developer will not call this method directly, but work through the interface in L that will handle their creation. =head2 add_key add_key( key, value, configuration) Write a new or existing object to S3. =over =item key A string identifier for the object being written to the bucket. =item value A SCALAR string representing the contents of the object. =item configuration A HASHREF of configuration data for this key. The configuration is generally the HTTP headers you want to pass to the S3 service. The client library will add all necessary headers. Adding them to the configuration hash will override what the library would send and add headers that are not typically required for S3 interactions. =item acl_short (optional) In addition to additional and overriden HTTP headers, this HASHREF can have a C key to set the permissions (access) of the resource without a seperate call via C or in the form of an XML document. See the documentation in C for the values and usage. =back Returns a boolean indicating the sucess or failure of the call. Check C and C for error messages if this operation fails. To examine the raw output of the response from the API call, use the C method. my $retval = $bucket->add_key('foo', $content, {}); if ( !$retval ) { print STDERR Dumper([$bucket->err, $bucket->errstr, $bucket->last_response]); } =head2 add_key_filename The method works like C except the value is assumed to be a filename on the local file system. The file will be streamed rather then loaded into memory in one big chunk. =head2 copy_object %parameters Copies an object from one bucket to another bucket. I Returns a hash reference to the response object (C). Headers returned from the request can be obtained using the C method. my $headers = { $bucket->last_response->headers->flatten }; Throws an exception if the response code is not 2xx. You can get an extended error message using the C method. my $result = eval { return $s3->copy_object( key => 'foo.jpg', source => 'boo.jpg' ); }; if ($@) { die $s3->errstr; } Examples: $bucket->copy_object( key => 'foo.jpg', source => 'boo.jpg' ); $bucket->copy_object( key => 'foo.jpg', source => 'boo.jpg', bucket => 'my-source-bucket' ); $bucket->copy_object( key => 'foo.jpg', headers => { 'x-amz-copy-source' => 'my-source-bucket/boo.jpg' ); See L for more details. C<%parameters> is a list of key/value pairs described below: =over =item key (required) Name of the destination key in the bucket represented by the bucket object. =item headers (optional) Hash or array reference of headers to send in the request. =item bucket (optional) Name of the source bucket. Default is the same bucket as the destination. =item source (optional) Name of the source key in the source bucket. If not provided, you must provide the source in the `x-amz-copy-source` header. =back =head2 head_key $key_name Returns a configuration HASH of the given key. If a key does not exist in the bucket C will be returned. HASH will contain the following members: =over =item content_length =item content_type =item etag =item value =back =head2 delete_key delete_key(key, [version]) Permanently removes C<$key_name> from the bucket. Returns a boolean value indicating the operation's success. =head2 delete_keys @keys =head2 delete_keys $keys Permanently removes keys from the bucket. Returns the response body from the API call. Returns C on non '2xx' return codes. See The argument to C can be: =over 5 =item * list of key names =item * an array of hashes where each hash reference contains the keys C and optionally C. =item * an array of scalars where each scalar is a key name =item * a hash of options where the hash contains =item * a callback that returns the key and optionally the version id =over 10 =item quiet Boolean indicating quiet mode =item keys An array of keys containing scalars or hashes as describe above. =back =back Examples: # delete a list of keys $bucket->delete_keys(qw( foo bar baz)); # delete an array of keys $bucket->delete_keys([qw(foo bar baz)]); # delete an array of keys in quiet mode $bucket->delete({ quiet => 1, keys => [ qw(foo bar baz) ]); # delete an array of versioned objects $bucket->delete_keys([ { Key => 'foo', VersionId => '1'} ]); # callback my @key_list = qw(foo => 1, bar => 3, biz => 1); $bucket->delete_keys( sub { return ( shift @key_list, shift @key_list ); } ); I API is only called once.> =head2 delete_bucket Permanently removes the bucket from the server. A bucket cannot be removed if it contains any keys (contents). This is an alias for C<$s3-Edelete_bucket($bucket)>. =head2 get_key key, [method, headers, uri_params] =head2 get_key hashref Takes a key and optional arguments and returns the hash of metatdata which includes the contents of the S3 object. Example: $bucket->get_key( key => 'foo', uri_params => { versionId => $version }, headers => { Range => 'bytes=0-9' } ); =over 5 =item key Key name =item method HTTP method (GET or HEAD) default: GET =item headers A hashref of additional headers to send with the request =item uri-params A hashref containing key/value pairs representing the URI parameters you want to include in the request. Possible parameters are shown below. See L =over 10 =item partNumber =item response-cache-control =item response-content-disposition =item response-content-encoding =item response-content-language =item response-content-type =item response-expires =item versionId =back =back The method returns C if the key does not exist in the bucket and throws an exception (dies) on server errors. On success, the method returns a HASHREF containing: =over =item content_type =item etag =item value =item @meta =item content_range =item last_modified =back I for ranged gets is the MD5 value for the entire file.> =head2 get_key_filename $key_name, [$method, $filename, $headers, $uri_params] =head2 get_key_filename $args Pass a list of arguments or a hash of key value/pairs. This method works like C, but takes an added filename that the S3 resource will be written to. If C is undefined or an empty string, the a file with the key name will be created. =over 5 =item key (required) =item method default: GET =item filename default: name of the key =item headers A hashref of additional headers to send with the request =item uri-params A hashref containing key/value pairs representing the URI parameters you want to include in the request. See L for possible parameters. See L =back =head2 list List all keys in this bucket. See L for documentation of this method. =head2 list_v2 See L for documentation of this method. =head2 list_all List all keys in this bucket without having to worry about 'marker'. This may make multiple requests to S3 under the hood. See L for documentation of this method. =head2 list_all_v2 Same as C but uses the version 2 API for listing keys. See L for documentation of this method. =head2 get_acl Retrieves the Access Control List (ACL) for the bucket or resource as an XML document. =over =item key The key of the stored resource to fetch. This parameter is optional. By default the method returns the ACL for the bucket itself. =back =head2 set_acl set_acl(acl) Sets the Access Control List (ACL) for the bucket or resource. Requires a HASHREF argument with one of the following keys: =over =item acl_xml An XML string which contains access control information which matches Amazon's published schema. =item acl_short Alternative shorthand notation for common types of ACLs that can be used in place of a ACL XML document. According to the Amazon S3 API documentation the following recognized acl_short types are defined as follows: =over =item private Owner gets FULL_CONTROL. No one else has any access rights. This is the default. =item public-read Owner gets FULL_CONTROL and the anonymous principal is granted READ access. If this policy is used on an object, it can be read from a browser with no authentication. =item public-read-write Owner gets FULL_CONTROL, the anonymous principal is granted READ and WRITE access. This is a useful policy to apply to a bucket, if you intend for any anonymous user to PUT objects into the bucket. =item authenticated-read Owner gets FULL_CONTROL, and any principal authenticated as a registered Amazon S3 user is granted READ access. =back =item key The key name to apply the permissions. If the key is not provided the bucket ACL will be set. =back Returns a boolean indicating the operations success. =head2 get_location_constraint Returns the location constraint (region the bucket resides in) for a bucket. Returns undef if there is no location constraint. Valid values that may be returned: af-south-1 ap-east-1 ap-northeast-1 ap-northeast-2 ap-northeast-3 ap-south-1 ap-southeast-1 ap-southeast-2 ca-central-1 cn-north-1 cn-northwest-1 EU eu-central-1 eu-north-1 eu-south-1 eu-west-1 eu-west-2 eu-west-3 me-south-1 sa-east-1 us-east-2 us-gov-east-1 us-gov-west-1 us-west-1 us-west-2 For more information on location constraints, refer to the documentation for L. =head2 err The S3 error code for the last error the account encountered. =head2 errstr A human readable error string for the last error the account encountered. =head2 error The decoded XML string as a hash object of the last error. =head2 last_response Returns the last C to an API call. =head1 MULTIPART UPLOAD SUPPORT From Amazon's website: I See L for more information about multipart uploads. =over 5 =item * Maximum object size 5TB =item * Maximum number of parts 10,000 =item * Part numbers 1 to 10,000 (inclusive) =item * Part size 5MB to 5GB. There is no limit on the last part of your multipart upload. =item * Maximum nubmer of parts returned for a list parts request - 1000 =item * Maximum number of multipart uploads returned in a list multipart uploads request - 1000 =back A multipart upload begins by calling C. This will return an identifier that is used in subsequent calls. my $bucket = $s3->bucket('my-bucket'); my $id = $bucket->initiate_multipart_upload('some-big-object'); my $part_list = {}; my $part = 1; my $etag = $bucket->upload_part_of_multipart_upload('my-bucket', $id, $part, $data, length $data); $part_list{$part++} = $etag; $bucket->complete_multipart_upload('my-bucket', $id, $part_list); =heads upload_multipart_object upload_multipart_object( ... ) Convenience routine C that encapsulates the multipart upload process. Accepts a hash or hash reference of arguments. If successful, a reference to a hash that contains the part numbers and etags of the uploaded parts. You can pass a data object, callback routine or a file handle. =over 5 =item key Name of the key to create. =item data Scalar object that contains the data to write to S3. =item callback Optionally provided a callback routine that will be called until you pass a buffer with a length of 0. Your callback will receive no arguments but should return a tuple consisting of a B to a scalar object that contains the data to write and a scalar that represents the length of data. Once you return a zero length buffer the multipart process will be completed. =item fh File handle of an open file. The file must be greater than the minimum chunk size for multipart uploads otherwise the method will throw an exception. =item abort_on_error Indicates whether the multipart upload should be aborted if an error is encountered. Amazon will charge you for the storage of parts that have been uploaded unless you abort the upload. default: true =back =head2 abort_multipart_upload abort_multipart_upload(key, multpart-upload-id) Abort a multipart upload =head2 complete_multipart_upload complete_multipart_upload(key, multpart-upload-id, parts) Signal completion of a multipart upload. C is a reference to a hash of part numbers and etags. =head2 initiate_multipart_upload initiate_multipart_upload(key, headers) Initiate a multipart upload. Returns an id used in subsequent call to C. =head2 list_multipart_upload_parts List all the uploaded parts of a multipart upload =head2 list_multipart_uploads List multipart uploads in progress =head2 upload_part_of_multipart_upload upload_part_of_multipart_upload(key, id, part, data, length) Upload a portion of a multipart upload =over 5 =item key Name of the key in the bucket to create. =item id The multipart-upload id return in the C call. =item part The next part number (part numbers start at 1). =item data Scalar or reference to a scalar that contains the data to upload. =item length (optional) Length of the data. =back =head1 SEE ALSO L =head1 AUTHOR Please see the L manpage for author, copyright, and license information. =head1 CONTRIBUTORS Rob Lauer Jojess Fournier Tim Mullin Todd Rinaldo luiserd97 =cut Amazon-S3-2.0.2/lib/Amazon/S3/Signature/0000755000175100017510000000000015103436527017022 5ustar rlauerrlauerAmazon-S3-2.0.2/lib/Amazon/S3/Signature/V4.pm0000644000175100017510000000154015103436526017650 0ustar rlauerrlauerpackage Amazon::S3::Signature::V4; use strict; use warnings; use parent qw{Net::Amazon::Signature::V4}; ######################################################################## sub new { ######################################################################## my ( $class, @args ) = @_; my %options; if ( !ref $args[0] ) { @options{qw{access_key_id secret endpoint service}} = @args; } else { %options = %{ $args[0] }; } my $region = delete $options{region}; $options{endpoint} //= $region; my $self = $class->SUPER::new( \%options ); return $self; } ######################################################################## sub region { ######################################################################## my ( $self, @args ) = @_; if (@args) { $self->{endpoint} = $args[0]; } return $self->{endpoint}; } 1; Amazon-S3-2.0.2/lib/Amazon/S3/Constants.pm0000644000175100017510000000737415103436526017405 0ustar rlauerrlauerpackage Amazon::S3::Constants; use strict; use warnings; use parent qw(Exporter); use Readonly; our $VERSION = '2.0.2'; ## no critic (RequireInterpolation) # defaults Readonly our $AMAZON_HEADER_PREFIX => 'x-amz-'; Readonly our $DEFAULT_BUFFER_SIZE => 4 * 1024; Readonly our $DEFAULT_HOST => 's3.amazonaws.com'; Readonly our $DEFAULT_TIMEOUT => 30; Readonly our $KEEP_ALIVE_CACHESIZE => 0; Readonly our $METADATA_PREFIX => 'x-amz-meta-'; Readonly our $MAX_BUCKET_NAME_LENGTH => 64; Readonly our $MIN_BUCKET_NAME_LENGTH => 3; Readonly our $MIN_MULTIPART_UPLOAD_CHUNK_SIZE => 5 * 1024 * 1024; Readonly our $DEFAULT_LOG_LEVEL => 'error'; Readonly our $MAX_DELETE_KEYS => 1000; Readonly our $MAX_RETRIES => 5; Readonly our $DEFAULT_REGION => 'us-east-1'; Readonly our $AWS_METADATA_BASE_URL => 'http://169.254.169.254/latest/meta-data/'; Readonly our $XMLDECL => ''; Readonly our $S3_XMLNS => 'http://s3.amazonaws.com/doc/2006-03-01/'; Readonly::Hash our %LOG_LEVELS => ( trace => 5, debug => 4, info => 3, warn => 2, error => 1, fatal => 0, ); Readonly::Hash our %LIST_OBJECT_MARKERS => ( '3' => [qw(KeyMarker NextKeyMarker key-marker)], '2' => [qw(ContinuationToken NextContinuationToken continuation-token)], '1' => [qw(Marker NextMarker marker)], ); # booleans Readonly our $TRUE => 1; Readonly our $FALSE => 0; # chars Readonly our $COMMA => q{,}; Readonly our $COLON => q{:}; Readonly our $DOT => q{.}; Readonly our $DOUBLE_COLON => q{::}; Readonly our $EMPTY => q{}; Readonly our $SLASH => q{/}; Readonly our $QUESTION_MARK => q{?}; Readonly our $AMPERSAND => q{&}; Readonly our $EQUAL_SIGN => q{=}; # HTTP codes Readonly our $HTTP_PARTIAL_CONTENT => 206; Readonly our $HTTP_NO_CONTENT => 204; Readonly our $HTTP_BAD_REQUEST => 400; Readonly our $HTTP_UNAUTHORIZED => 401; Readonly our $HTTP_PAYMENT_RQUIRED => 402; Readonly our $HTTP_FORBIDDEN => 403; Readonly our $HTTP_NOT_FOUND => 404; Readonly our $HTTP_CONFLICT => 409; Readonly our $HTTP_MOVED_PERMANENTLY => 301; Readonly our $HTTP_FOUND => 302; Readonly our $HTTP_SEE_OTHER => 303; Readonly our $HTTP_NOT_MODIFIED => 304; our %EXPORT_TAGS = ( chars => [ qw( $AMPERSAND $COLON $DOUBLE_COLON $DOT $COMMA $EMPTY $EQUAL_SIGN $QUESTION_MARK $SLASH ) ], booleans => [ qw( $TRUE $FALSE ) ], defaults => [ qw( $AMAZON_HEADER_PREFIX $METADATA_PREFIX $KEEP_ALIVE_CACHESIZE $DEFAULT_TIMEOUT $DEFAULT_BUFFER_SIZE $DEFAULT_LOG_LEVEL $DEFAULT_HOST $DEFAULT_REGION $MAX_BUCKET_NAME_LENGTH $MAX_DELETE_KEYS $MIN_BUCKET_NAME_LENGTH $MIN_MULTIPART_UPLOAD_CHUNK_SIZE $MAX_RETRIES ) ], misc => [ qw( $AWS_METADATA_BASE_URL $S3_XMLNS $XMLDECL %LIST_OBJECT_MARKERS %LOG_LEVELS $NOT_FOUND ) ], http => [ qw( $HTTP_BAD_REQUEST $HTTP_CONFLICT $HTTP_UNAUTHORIZED $HTTP_PAYMENT_RQUIRED $HTTP_FORBIDDEN $HTTP_NOT_FOUND $HTTP_NO_CONTENT $HTTP_MOVED_PERMANENTLY $HTTP_PARTIAL_CONTENT $HTTP_FOUND $HTTP_SEE_OTHER $HTTP_NOT_MODIFIED ) ], ); our @EXPORT_OK = map { @{ $EXPORT_TAGS{$_} } } keys %EXPORT_TAGS; $EXPORT_TAGS{all} = [@EXPORT_OK]; 1; ## no critic (RequirePodSections) __END__ =pod =head1 NAME Amazon::S3::Constants - constants and defaults for Amazon::S3 =head1 AUTHOR Rob Lauer - =cut Amazon-S3-2.0.2/lib/Amazon/S3/Util.pm0000644000175100017510000000753115103436526016341 0ustar rlauerrlauerpackage Amazon::S3::Util; use strict; use warnings; use Amazon::S3::Constants qw(:all); 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 MIME::Base64; use Scalar::Util qw(reftype); use URI::Escape qw(uri_escape_utf8); use XML::Simple; use parent qw(Exporter); our @EXPORT_OK = qw( create_query_string create_grant_header create_xml_request create_api_uri set_md5_header urlencode get_parameters ); our %EXPORT_TAGS; $EXPORT_TAGS{all} = [@EXPORT_OK]; ######################################################################## sub urlencode { ######################################################################## my (@args) = @_; my $unencoded = ref $args[0] ? $args[1] : $args[0]; ## no critic (RequireInterpolation) return uri_escape_utf8( $unencoded, '^A-Za-z0-9\-\._~\x2f' ); } # hashref or list of key/value pairs ######################################################################## sub create_query_string { ######################################################################## my (@args) = @_; my $parameters = get_parameters(@args); return $EMPTY if !$parameters || !keys %{$parameters}; return join $AMPERSAND, map { sprintf '%s=%s', $_, urlencode( $parameters->{$_} ) } keys %{$parameters}; } ######################################################################## sub create_api_uri { ######################################################################## my (@args) = @_; my $parameters = get_parameters(@args); my $path = delete $parameters->{path}; $path //= $EMPTY; if ( $path !~ /\/$/xsm ) { $path = "$path/"; } my $api = delete $parameters->{api}; $api //= $EMPTY; my $query_string = create_query_string($parameters); return sprintf '%s?%s%s', $path, $api, $query_string; } ######################################################################## sub create_xml_request { ######################################################################## my ( $request, $content_key ) = @_; if ( !$content_key ) { ($content_key) = keys %{$request}; } $request->{$content_key}->{xmlns} = $S3_XMLNS; return XMLout( $request, NSExpand => $TRUE, KeyAttr => [], KeepRoot => $TRUE, ContentKey => $content_key, NoAttr => $TRUE, XMLDecl => $XMLDECL, ); } ######################################################################## sub set_md5_header { ######################################################################## my (@args) = @_; my $parameters = get_parameters(@args); my ( $content, $headers ) = @{$parameters}{qw(data headers)}; my $md5 = eval { if ( ref($content) && reftype($content) eq 'SCALAR' ) { $headers->{'Content-Length'} = -s ${$content}; my $md5_hex = file_md5_hex( ${$content} ); return encode_base64( pack 'H*', $md5_hex ); } else { $headers->{'Content-Length'} = length $content; my $md5 = md5($content); my $md5_hex = unpack 'H*', $md5; return encode_base64($md5); } }; die "$EVAL_ERROR" if $EVAL_ERROR; chomp $md5; $headers->{'Content-MD5'} = $md5; return; } # grant: # full-control # read # read-acp # write # write-acp # # type: # id # uri # emailAddress ######################################################################## sub create_grant_header { ######################################################################## my ( $grant, $type, @args ) = @_; my $values = ref $args[0] ? $args[0] : \@args; return { "x-amz-grant-$grant" => join ', ', map { sprintf qq{$type="%s"}, $_ } @{$values} }; } ######################################################################### sub get_parameters { return ref $_[0] ? $_[0] : {@_}; } ######################################################################## 1;