From eb5adf956fc6b9285b43ce6965eea728573e7864 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Tue, 19 Apr 2022 13:49:49 -0600 Subject: [PATCH] Adjust dependencies --- dist.ini | 7 ++- lib/File/KDBX/Dumper/V3.pm | 4 +- lib/File/KDBX/Dumper/V4.pm | 4 +- lib/File/KDBX/Error.pm | 2 +- lib/File/KDBX/Loader/V3.pm | 4 +- lib/File/KDBX/Loader/V4.pm | 4 +- lib/File/KDBX/Util.pm | 109 +++++++++++++++++++------------------ t/kdf-aes-pp.t | 5 +- t/lib/TestCommon.pm | 5 +- 9 files changed, 75 insertions(+), 69 deletions(-) diff --git a/dist.ini b/dist.ini index 8eceb08..ba85d8c 100644 --- a/dist.ini +++ b/dist.ini @@ -7,8 +7,6 @@ license = Perl_5 [@Author::CCM] [Prereqs / RuntimeRecommends] -; B::COW might speed up the memory erase feature, maybe -B::COW = 0 File::Spec = 0 [Prereqs / TestSuggests] @@ -49,6 +47,11 @@ to_relationship = none module = File::KeePass module = File::KeePass::KDBX +[Prereqs::Soften / ProgressiveEnhancement] +to_relationship = none +; File::KDBX::XS, which is recommended, provides the same functionality as B::COW +module = B::COW + [Prereqs::Soften] modules_from_features = 1 diff --git a/lib/File/KDBX/Dumper/V3.pm b/lib/File/KDBX/Dumper/V3.pm index 635931f..ceb9f29 100644 --- a/lib/File/KDBX/Dumper/V3.pm +++ b/lib/File/KDBX/Dumper/V3.pm @@ -10,7 +10,7 @@ use File::KDBX::Constants qw(:header :compression); use File::KDBX::Error; use File::KDBX::IO::Crypt; use File::KDBX::IO::HashBlock; -use File::KDBX::Util qw(:empty assert_64bit erase_scoped); +use File::KDBX::Util qw(:empty :load assert_64bit erase_scoped); use IO::Handle; use namespace::clean; @@ -160,7 +160,7 @@ sub _write_body { my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; if ($compress == COMPRESSION_GZIP) { - require IO::Compress::Gzip; + load_optional('IO::Compress::Gzip'); $fh = IO::Compress::Gzip->new($fh, -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(), -TextFlag => 1, diff --git a/lib/File/KDBX/Dumper/V4.pm b/lib/File/KDBX/Dumper/V4.pm index 8100212..642f689 100644 --- a/lib/File/KDBX/Dumper/V4.pm +++ b/lib/File/KDBX/Dumper/V4.pm @@ -11,7 +11,7 @@ use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_ma use File::KDBX::Error; use File::KDBX::IO::Crypt; use File::KDBX::IO::HmacBlock; -use File::KDBX::Util qw(:empty assert_64bit erase_scoped); +use File::KDBX::Util qw(:empty :load assert_64bit erase_scoped); use IO::Handle; use Scalar::Util qw(looks_like_number); use boolean qw(:all); @@ -243,7 +243,7 @@ sub _write_body { my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; if ($compress == COMPRESSION_GZIP) { - require IO::Compress::Gzip; + load_optional('IO::Compress::Gzip'); $fh = IO::Compress::Gzip->new($fh, -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(), -TextFlag => 1, diff --git a/lib/File/KDBX/Error.pm b/lib/File/KDBX/Error.pm index fbc6bbd..7f44942 100644 --- a/lib/File/KDBX/Error.pm +++ b/lib/File/KDBX/Error.pm @@ -70,7 +70,7 @@ passed will be forwarded to L to create a new error object. This can be convenient for error handling when you're not sure what the exception is but you want to treat it as a B. Example: - eval { .... }; + eval { ... }; if (my $error = error(@_)) { if ($error->type eq 'key.missing') { handle_missing_key($error); diff --git a/lib/File/KDBX/Loader/V3.pm b/lib/File/KDBX/Loader/V3.pm index 77ad479..687215a 100644 --- a/lib/File/KDBX/Loader/V3.pm +++ b/lib/File/KDBX/Loader/V3.pm @@ -22,7 +22,7 @@ use File::KDBX::Constants qw(:header :compression :kdf); use File::KDBX::Error; use File::KDBX::IO::Crypt; use File::KDBX::IO::HashBlock; -use File::KDBX::Util qw(:io assert_64bit erase_scoped); +use File::KDBX::Util qw(:io :load assert_64bit erase_scoped); use namespace::clean; use parent 'File::KDBX::Loader'; @@ -142,7 +142,7 @@ sub _read_body { my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; if ($compress == COMPRESSION_GZIP) { - require IO::Uncompress::Gunzip; + load_optional('IO::Uncompress::Gunzip'); $fh = IO::Uncompress::Gunzip->new($fh) or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError", error => $IO::Uncompress::Gunzip::GunzipError; diff --git a/lib/File/KDBX/Loader/V4.pm b/lib/File/KDBX/Loader/V4.pm index fa8d21d..2180d28 100644 --- a/lib/File/KDBX/Loader/V4.pm +++ b/lib/File/KDBX/Loader/V4.pm @@ -22,7 +22,7 @@ use Crypt::Mac::HMAC qw(hmac); use Encode qw(decode); use File::KDBX::Constants qw(:header :inner_header :variant_map :compression); use File::KDBX::Error; -use File::KDBX::Util qw(:io assert_64bit erase_scoped); +use File::KDBX::Util qw(:io :load assert_64bit erase_scoped); use File::KDBX::IO::Crypt; use File::KDBX::IO::HmacBlock; use boolean; @@ -198,7 +198,7 @@ sub _read_body { my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS}; if ($compress == COMPRESSION_GZIP) { - require IO::Uncompress::Gunzip; + load_optional('IO::Uncompress::Gunzip'); $fh = IO::Uncompress::Gunzip->new($fh) or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError", error => $IO::Uncompress::Gunzip::GunzipError; diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index c970683..87d87d6 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -82,6 +82,47 @@ my %OP_NEG = ( '!~' => '=~', ); +=func FALSE + +=func TRUE + +Constants appropriate for use as return values in functions claiming to return true or false. + +=cut + +sub FALSE() { !1 } +sub TRUE() { 1 } + +=func load_xs + + $bool = load_xs(); + $bool = load_xs($version); + +Attempt to load L. Return truthy if C is loaded. If C<$version> is given, it will check +that at least the given version is loaded. + +=cut + +sub load_xs { + my $version = shift; + + goto IS_LOADED if File::KDBX->can('_XS_LOADED'); + + my $try_xs = 1; + $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS}); + + my $use_xs = 0; + $use_xs = eval { require File::KDBX::XS; 1 } if $try_xs; + + *File::KDBX::_XS_LOADED = *File::KDBX::_XS_LOADED = $use_xs ? \&TRUE : \&FALSE; + + IS_LOADED: + { + local $@; + return $version ? !!eval { File::KDBX::XS->VERSION($version); 1 } : File::KDBX::_XS_LOADED(); + } +} + =func assert_64bit assert_64bit(); @@ -243,7 +284,17 @@ Overwrite the memory used by one or more string. =cut -# use File::KDBX::XS; +BEGIN { + if (load_xs) { + # loaded CowREFCNT + } + elsif (eval { require B::COW; 1 }) { + *CowREFCNT = \*B::COW::cowrefcnt; + } + else { + *CowREFCNT = sub { undef }; + } +} sub erase { # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just @@ -252,10 +303,8 @@ sub erase { for (@_) { if (!is_ref($_)) { next if !defined $_ || readonly $_; - if (_USE_COWREFCNT()) { - my $cowrefcnt = B::COW::cowrefcnt($_); - goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; - } + my $cowrefcnt = CowREFCNT($_); + goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; # if (__PACKAGE__->can('erase_xs')) { # erase_xs($_); # } @@ -269,10 +318,8 @@ sub erase { } elsif (is_scalarref($_)) { next if !defined $$_ || readonly $$_; - if (_USE_COWREFCNT()) { - my $cowrefcnt = B::COW::cowrefcnt($$_); - goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; - } + my $cowrefcnt = CowREFCNT($$_); + goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; # if (__PACKAGE__->can('erase_xs')) { # erase_xs($$_); # } @@ -468,34 +515,6 @@ sub load_optional { return wantarray ? @_ : $_[0]; } -=func load_xs - - $bool = load_xs(); - $bool = load_xs($version); - -Attempt to load L. Return truthy if C is loaded. If C<$version> is given, it will check -that at least the given version is loaded. - -=cut - -sub load_xs { - my $version = shift; - - require File::KDBX; - - my $has_xs = File::KDBX->can('XS_LOADED'); - return $has_xs->() && ($version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1) if $has_xs; - - my $try_xs = 1; - $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS}); - - my $use_xs = 0; - $use_xs = try_load_optional('File::KDBX::XS') if $try_xs; - - *File::KDBX::XS_LOADED = *File::KDBX::XS_LOADED = $use_xs ? sub() { 1 } : sub() { 0 }; - return $version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1; -} - =func memoize \&memoized_code = memoize(\&code, ...); @@ -820,22 +839,6 @@ sub uuid { } -=func FALSE - -=func TRUE - -Constants appropriate for use as return values in functions claiming to return true or false. - -=cut - -sub FALSE() { !1 } -sub TRUE() { 1 } - -BEGIN { - my $use_cowrefcnt = eval { require B::COW; 1 }; - *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 }; -} - ### -------------------------------------------------------------------------- # Determine if an array looks like keypairs from a hash. diff --git a/t/kdf-aes-pp.t b/t/kdf-aes-pp.t index e5f0fc6..9ebdb39 100644 --- a/t/kdf-aes-pp.t +++ b/t/kdf-aes-pp.t @@ -3,10 +3,11 @@ use warnings; use strict; +BEGIN { $ENV{PERL_FILE_KDBX_XS} = 0 } + use lib 't/lib'; use TestCommon; -BEGIN { $ENV{PERL_FILE_KDBX_XS} = 0 } use File::KDBX::KDF; use File::KDBX::Constants qw(:kdf); @@ -14,7 +15,7 @@ use Test::More; my $kdf = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10); -is File::KDBX::XS_LOADED(), 0, 'XS can be avoided'; +ok !File::KDBX::_XS_LOADED(), 'XS can be avoided'; my $r = $kdf->transform("\2" x 32); is $r, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222", diff --git a/t/lib/TestCommon.pm b/t/lib/TestCommon.pm index 3111460..e499251 100644 --- a/t/lib/TestCommon.pm +++ b/t/lib/TestCommon.pm @@ -6,7 +6,7 @@ use strict; use Data::Dumper; use File::KDBX::Constants qw(:magic :kdf); use File::KDBX::Util qw(can_fork dumper); -use File::Spec::Functions qw(catfile); +use File::Spec; use FindBin qw($Bin); use Test::Fatal; use Test::Deep; @@ -36,7 +36,6 @@ sub import { # Just export a random assortment of things useful for testing. no strict 'refs'; *{"${caller}::dumper"} = \&File::KDBX::Util::dumper; - *{"${caller}::catfile"} = \&File::Spec::Functions::catfile; *{"${caller}::exception"} = \&Test::Fatal::exception; *{"${caller}::warning"} = \&Test::Warnings::warning; @@ -50,7 +49,7 @@ sub import { } sub testfile { - return catfile($Bin, 'files', @_); + return File::Spec->catfile($Bin, 'files', @_); } sub dump_test_deep_template { -- 2.45.2