Add recursive transactions

[chaz/p5-File-KDBX] / lib / File / KDBX / Util.pm

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index c970683694fcef37ff0086c2c5a7acc5d54f3efa..3355d41fa1d3454c119a14dbd98d900abef70083 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -7,6 +7,7 @@ use strict;
 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;
@@ -18,7 +19,6 @@ our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
     assert      => [qw(assert_64bit)],
-    bool        => [qw(FALSE TRUE)],
     clone       => [qw(clone clone_nomagic)],
     crypt       => [qw(pad_pkcs7)],
     debug       => [qw(dumper)],
@@ -29,7 +29,7 @@ our %EXPORT_TAGS = (
     gzip        => [qw(gzip gunzip)],
     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)],
@@ -82,6 +82,36 @@ my %OP_NEG = (
     '!~'    =>  '=~',
 );
 
+=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();
@@ -243,7 +273,17 @@ Overwrite the memory used by one or more string.
 
 =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
@@ -252,10 +292,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 +307,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($$_);
             # }
@@ -312,6 +348,7 @@ See L</erase>.
 =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($_)
@@ -468,34 +505,6 @@ sub load_optional {
     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, ...);
@@ -610,7 +619,6 @@ This is the search engine described with many examples at L<File::KDBX/QUERY>.
 sub search {
     my $list    = shift;
     my $query   = shift;
-    # my %args    = @_;
 
     if (is_coderef($query) && !@_) {
         # already a query
@@ -622,12 +630,32 @@ sub search {
         $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;
 }
@@ -820,22 +848,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.