X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;ds=sidebyside;f=lib%2FFile%2FKDBX%2FUtil.pm;h=87d87d6c2022d13e0ed61620c6bf56881fbdb3af;hb=eb5adf956fc6b9285b43ce6965eea728573e7864;hp=2d830742e949e3730a452fc25ef6713f7d2a3d03;hpb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;p=chaz%2Fp5-File-KDBX

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index 2d83074..87d87d6 100644
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -10,14 +10,15 @@ use Exporter qw(import);
 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
 
 our %EXPORT_TAGS = (
     assert      => [qw(assert_64bit)],
+    bool        => [qw(FALSE TRUE)],
     clone       => [qw(clone clone_nomagic)],
     crypt       => [qw(pad_pkcs7)],
     debug       => [qw(dumper)],
@@ -26,7 +27,7 @@ our %EXPORT_TAGS = (
     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)],
     text        => [qw(snakify trim)],
@@ -81,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<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();
@@ -119,13 +161,11 @@ sub can_fork {
     return 1;
 }
 
-=func clone_nomagic
+=func clone
 
-    $clone = clone_nomagic($thing);
-
-Clone deeply without keeping [most of] the magic.
+    $clone = clone($thing);
 
-B<NOTE:> At the moment the implementation is naïve and won't respond well to nontrivial data.
+Clone deeply. This is an unadorned alias to L<Storable> C<dclone>.
 
 =cut
 
@@ -134,6 +174,17 @@ sub clone {
     goto &Storable::dclone;
 }
 
+=func clone_nomagic
+
+    $clone = clone_nomagic($thing);
+
+Clone deeply without keeping [most of] the magic.
+
+B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data or recursive
+structures.
+
+=cut
+
 sub clone_nomagic {
     my $thing = shift;
     if (is_arrayref($thing)) {
@@ -153,7 +204,8 @@ sub clone_nomagic {
 
 =func dumper
 
-    $str = dumper $struct;
+    $str = dumper $thing;
+    dumper $thing;  # in void context, prints to STDERR
 
 Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>.
 
@@ -232,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
@@ -241,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($_);
             # }
@@ -258,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($$_);
             # }
@@ -391,7 +449,7 @@ sub gunzip {
     return $out;
 }
 
-=func gunzip
+=func gzip
 
     $zipped = gzip($string);
 
@@ -414,6 +472,20 @@ sub gzip {
     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);
@@ -443,34 +515,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, ...);
@@ -762,6 +806,14 @@ sub uri_escape_utf8 {
     return $_;
 }
 
+=func uri_unescape_utf8
+
+    $string = uri_unescape_utf8($string);
+
+Inverse of L</uri_escape_utf8>.
+
+=cut
+
 sub uri_unescape_utf8 {
     local $_ = shift // return;
     s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
@@ -787,11 +839,6 @@ sub uuid {
 
 }
 
-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.