use Crypt::PRNG qw(random_bytes random_string);
use Encode qw(decode encode);
use Exporter qw(import);
+use File::KDBX::Constants qw(:bool);
use File::KDBX::Error;
use List::Util 1.33 qw(any all);
use Module::Load;
-use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref is_ref);
-use Scalar::Util qw(blessed isdual looks_like_number readonly refaddr);
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref);
+use Scalar::Util qw(blessed readonly);
use namespace::clean -except => 'import';
our $VERSION = '999.999'; # VERSION
empty => [qw(empty nonempty)],
erase => [qw(erase erase_scoped)],
gzip => [qw(gzip gunzip)],
- io => [qw(read_all)],
+ io => [qw(is_readable is_writable read_all)],
load => [qw(load_optional load_xs try_load_optional)],
- search => [qw(query search simple_expression_query)],
+ search => [qw(query search search_limited simple_expression_query)],
text => [qw(snakify trim)],
uuid => [qw(format_uuid generate_uuid is_uuid uuid)],
uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
'!~' => '=~',
);
+=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
+
+my $XS_LOADED;
+sub load_xs {
+ my $version = shift;
+
+ goto IS_LOADED if defined $XS_LOADED;
+
+ if ($ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS})) {
+ return $XS_LOADED = FALSE;
+ }
+
+ $XS_LOADED = !!eval { require File::KDBX::XS; 1 };
+
+ IS_LOADED:
+ {
+ local $@;
+ return $XS_LOADED if !$version;
+ return !!eval { File::KDBX::XS->VERSION($version); 1 };
+ }
+}
+
=func assert_64bit
assert_64bit();
=cut
-# use File::KDBX::XS;
+BEGIN {
+ if (load_xs) {
+ *_CowREFCNT = \&File::KDBX::XS::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($$_);
# }
=cut
sub erase_scoped {
+ throw 'Programmer error: Cannot call erase_scoped in void context' if !defined wantarray;
my @args;
for (@_) {
!is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
return $out;
}
+=func is_readable
+
+=func is_writable
+
+ $bool = is_readable($mode);
+ $bool = is_writable($mode);
+
+Determine of an C<fopen>-style mode is readable, writable or both.
+
+=cut
+
+sub is_readable { $_[0] !~ /^[aw]b?$/ }
+sub is_writable { $_[0] !~ /^rb?$/ }
+
=func is_uuid
$bool = is_uuid($thing);
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, ...);
sub search {
my $list = shift;
my $query = shift;
- # my %args = @_;
if (is_coderef($query) && !@_) {
# already a query
$query = query($query, @_);
}
- # my $limit = $args{limit};
+ my @match;
+ for my $item (@$list) {
+ push @match, $item if $query->($item);
+ }
+ return \@match;
+}
+
+sub search_limited {
+ my $list = shift;
+ my $query = shift;
+ my $limit = shift // 1;
+
+ if (is_coderef($query) && !@_) {
+ # already a query
+ }
+ elsif (is_scalarref($query)) {
+ $query = simple_expression_query($$query, @_);
+ }
+ else {
+ $query = query($query, @_);
+ }
my @match;
for my $item (@$list) {
push @match, $item if $query->($item);
- # last if defined $limit && $limit <= @match;
+ last if $limit <= @match;
}
return \@match;
}
}
-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.