[@Author::CCM]
[Prereqs / RuntimeRecommends]
-; B::COW might speed up the memory erase feature, maybe
-B::COW = 0
File::Spec = 0
[Prereqs / TestSuggests]
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
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;
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,
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);
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,
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<File::KDBX::Error>. Example:
- eval { .... };
+ eval { ... };
if (my $error = error(@_)) {
if ($error->type eq 'key.missing') {
handle_missing_key($error);
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';
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;
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;
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;
'!~' => '=~',
);
+=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<File::KDBX::XS>. Return truthy if C<XS> 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();
=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
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($_);
# }
}
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($$_);
# }
return wantarray ? @_ : $_[0];
}
-=func load_xs
-
- $bool = load_xs();
- $bool = load_xs($version);
-
-Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> 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, ...);
}
-=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.
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);
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",
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;
# 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;
}
sub testfile {
- return catfile($Bin, 'files', @_);
+ return File::Spec->catfile($Bin, 'files', @_);
}
sub dump_test_deep_template {
projects / chaz / p5-File-KDBX / commitdiff
