Remove min_version and clean up a lot of pod

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

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index a074d3e163f2641b5d1936d442a6f7efedefdcc0..5645b4c4a4fa83e994427335ac850a92730ef8cc 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -7,21 +7,25 @@ use strict;
 use Crypt::PRNG qw(random_bytes random_string);
 use Encode qw(decode encode);
 use Exporter qw(import);
 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 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 looks_like_number readonly);
+use Time::Piece;
+use boolean;

 use namespace::clean -except => 'import';
 
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
 use namespace::clean -except => 'import';
 
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (

-    assert      => [qw(assert_64bit)],
-    bool        => [qw(FALSE TRUE)],
+    assert      => [qw(DEBUG assert assert_64bit)],
+    class       => [qw(extends has list_attributes)],

     clone       => [qw(clone clone_nomagic)],
     clone       => [qw(clone clone_nomagic)],

+    coercion    => [qw(to_bool to_number to_string to_time to_tristate to_uuid)],

     crypt       => [qw(pad_pkcs7)],
     crypt       => [qw(pad_pkcs7)],

-    debug       => [qw(dumper)],
+    debug       => [qw(DEBUG dumper)],

     fork        => [qw(can_fork)],
     function    => [qw(memoize recurse_limit)],
     empty       => [qw(empty nonempty)],
     fork        => [qw(can_fork)],
     function    => [qw(memoize recurse_limit)],
     empty       => [qw(empty nonempty)],


@@ -29,15 +33,24 @@ our %EXPORT_TAGS = (
     gzip        => [qw(gzip gunzip)],
     io          => [qw(is_readable is_writable read_all)],
     load        => [qw(load_optional load_xs try_load_optional)],
     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 query_any search simple_expression_query)],

     text        => [qw(snakify trim)],
     text        => [qw(snakify trim)],

-    uuid        => [qw(format_uuid generate_uuid is_uuid uuid)],
+    uuid        => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],

     uri         => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
 );
 
 $EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
 our @EXPORT_OK = @{$EXPORT_TAGS{all}};
 
     uri         => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
 );
 
 $EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
 our @EXPORT_OK = @{$EXPORT_TAGS{all}};
 

+BEGIN {
+    my $debug = $ENV{DEBUG};
+    $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
+    *DEBUG = $debug == 1 ? sub() { 1 } :
+             $debug == 2 ? sub() { 2 } :
+             $debug == 3 ? sub() { 3 } :
+             $debug == 4 ? sub() { 4 } : sub() { 0 };
+}
+

 my %OPS = (
     'eq'        =>  2, # binary
     'ne'        =>  2,
 my %OPS = (
     'eq'        =>  2, # binary
     'ne'        =>  2,


@@ -81,6 +94,63 @@ my %OP_NEG = (
     '=~'    =>  '!~',
     '!~'    =>  '=~',
 );
     '=~'    =>  '!~',
     '!~'    =>  '=~',
 );

+my %ATTRIBUTES;
+
+=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
+
+    assert { ... };
+
+Write an executable comment. Only executed if C<DEBUG> is set in the environment.
+
+=cut
+
+sub assert(&) { ## no critic (ProhibitSubroutinePrototypes)
+    return if !DEBUG;
+    my $code = shift;
+    return if $code->();
+
+    (undef, my $file, my $line) = caller;
+    $file =~ s!([^/\\]+)$!$1!;
+    my $assertion = '';
+    if (try_load_optional('B::Deparse')) {
+        my $deparse = B::Deparse->new(qw{-P -x9});
+        $assertion = $deparse->coderef2text($code);
+        $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s;
+        $assertion =~ s/\s+/ /gs;
+        $assertion = ": $assertion";
+    }
+    die "$0: $file:$line: Assertion failed$assertion\n";
+}

 
 =func assert_64bit
 
 
 =func assert_64bit
 


@@ -161,6 +231,10 @@ sub clone_nomagic {
     return $thing;
 }
 
     return $thing;
 }
 

+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+

 =func dumper
 
     $str = dumper $thing;
 =func dumper
 
     $str = dumper $thing;


@@ -189,7 +263,8 @@ sub dumper {
         # boolean
         $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
         # Time::Piece
         # boolean
         $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
         # Time::Piece

-        $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \)/Time::Piece->new($1)/gs;
+        $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/
+            "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges;

 
         print STDERR $str if !defined wantarray;
         push @dumps, $str;
 
         print STDERR $str if !defined wantarray;
         push @dumps, $str;


@@ -243,7 +318,17 @@ Overwrite the memory used by one or more string.
 
 =cut
 
 
 =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
 
 sub erase {
     # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just


@@ -252,10 +337,8 @@ sub erase {
     for (@_) {
         if (!is_ref($_)) {
             next if !defined $_ || readonly $_;
     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($_);
             # }
             # if (__PACKAGE__->can('erase_xs')) {
             #     erase_xs($_);
             # }


@@ -269,10 +352,8 @@ sub erase {
         }
         elsif (is_scalarref($_)) {
             next if !defined $$_ || readonly $$_;
         }
         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($$_);
             # }
             # if (__PACKAGE__->can('erase_xs')) {
             #     erase_xs($$_);
             # }


@@ -312,6 +393,7 @@ See L</erase>.
 =cut
 
 sub erase_scoped {
 =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($_)
     my @args;
     for (@_) {
         !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)


@@ -322,6 +404,81 @@ sub erase_scoped {
     return Scope::Guard->new(sub { erase(@args) });
 }
 
     return Scope::Guard->new(sub { erase(@args) });
 }
 

+=func extends
+
+    extends $class;
+
+Set up the current module to inheret from another module.
+
+=cut
+
+sub extends {
+    my $parent  = shift;
+    my $caller  = caller;
+    load $parent;
+    no strict 'refs'; ## no critic (ProhibitNoStrict)
+    @{"${caller}::ISA"} = $parent;
+}
+
+=func has
+
+    has $name => %options;
+
+Create an attribute getter/setter. Possible options:
+
+=for :list
+* C<is> - Either "rw" (default) or "ro"
+* C<default> - Default value
+* C<coerce> - Coercive function
+
+=cut
+
+sub has {
+    my $name = shift;
+    my %args = @_ % 2 == 1 ? (default => shift, @_) : @_;
+
+    my ($package, $file, $line) = caller;
+
+    my $d = $args{default};
+    my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
+    my $coerce  = $args{coerce};
+    my $is      = $args{is} || 'rw';
+
+    my $store = $args{store};
+    ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
+
+    my @path = split(/\./, $args{path} || '');
+    my $last = pop @path;
+    my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}}
+                     : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}};
+    my $member = qq{\$_[0]$path};
+
+
+    my $default_code = is_coderef $default ? q{scalar $default->($_[0])}
+                        : defined $default ? q{$default}
+                                           : q{undef};
+    my $get = qq{$member //= $default_code;};
+
+    my $set = '';
+    if ($is eq 'rw') {
+        $set = is_coderef $coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;}
+                : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \$#_;}
+                                  : qq{$member = \$_[1] if \$#_;};
+    }
+
+    push @{$ATTRIBUTES{$package} //= []}, $name;
+    $line -= 4;
+    my $code = <<END;
+# line $line "$file"
+sub ${package}::${name} {
+    return $default_code if !Scalar::Util::blessed(\$_[0]);
+    $set
+    $get
+}
+END
+    eval $code; ## no critic (ProhibitStringyEval)
+}
+

 =func format_uuid
 
     $string_uuid = format_uuid($raw_uuid);
 =func format_uuid
 
     $string_uuid = format_uuid($raw_uuid);


@@ -449,6 +606,19 @@ Check if a thing is a UUID (i.e. scalar string of length 16).
 
 sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
 
 
 sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
 

+=func list_attributes
+
+    @attributes = list_attributes($package);
+
+Get a list of attributes for a class.
+
+=cut
+
+sub list_attributes {
+    my $package = shift;
+    return @{$ATTRIBUTES{$package} // []};
+}
+

 =func load_optional
 
     $package = load_optional($package);
 =func load_optional
 
     $package = load_optional($package);


@@ -461,41 +631,14 @@ sub load_optional {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {

-            warn $err if $ENV{DEBUG};
-            throw "Missing dependency: Please install $module to use this feature.\n", module => $module;
+            throw "Missing dependency: Please install $module to use this feature.\n",
+                module  => $module,
+                error   => $err;

         }
     }
     return wantarray ? @_ : $_[0];
 }
 
         }
     }
     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 memoize
 
     \&memoized_code = memoize(\&code, ...);


@@ -542,12 +685,32 @@ The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES
 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
 having its own bugs.
 
 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
 having its own bugs.
 

-See L<File::KDBX/QUERY> for examples.
+See L<File::KDBX/"Declarative Syntax"> for examples.

 
 =cut
 
 sub query { _query(undef, '-or', \@_) }
 
 
 =cut
 
 sub query { _query(undef, '-or', \@_) }
 

+=func query_any
+
+Get either a L</query> or L</simple_expression_query>, depending on the arguments.
+
+=cut
+
+sub query_any {
+    my $code = shift;
+
+    if (is_coderef($code) || overload::Method($code, '&{}')) {
+        return $code;
+    }
+    elsif (is_scalarref($code)) {
+        return simple_expression_query($$code, @_);
+    }
+    else {
+        return query($code, @_);
+    }
+}
+

 =func read_all
 
     $size = read_all($fh, my $buffer, $size);
 =func read_all
 
     $size = read_all($fh, my $buffer, $size);


@@ -603,31 +766,15 @@ sub recurse_limit {
 
 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
 
 
 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
 

-This is the search engine described with many examples at L<File::KDBX/QUERY>.
-

 =cut
 
 sub search {
     my $list    = shift;
 =cut
 
 sub search {
     my $list    = shift;

-    my $query   = shift;
-    # my %args    = @_;
-
-    if (is_coderef($query) && !@_) {
-        # already a query
-    }
-    elsif (is_scalarref($query)) {
-        $query = simple_expression_query($$query, @_);
-    }
-    else {
-        $query = query($query, @_);
-    }
-
-    # my $limit = $args{limit};
+    my $query   = query_any(@_);

 
     my @match;
     for my $item (@$list) {
         push @match, $item if $query->($item);
 
     my @match;
     for my $item (@$list) {
         push @match, $item if $query->($item);

-        # last if defined $limit && $limit <= @match;

     }
     return \@match;
 }
     }
     return \@match;
 }


@@ -635,6 +782,7 @@ sub search {
 =func simple_expression_query
 
     $query = simple_expression_query($expression, @fields);
 =func simple_expression_query
 
     $query = simple_expression_query($expression, @fields);

+    $query = simple_expression_query($expression, $operator, @fields);

 
 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
 L<described here|https://keepass.info/help/base/search.html#mode_se>.
 
 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
 L<described here|https://keepass.info/help/base/search.html#mode_se>.


@@ -736,6 +884,40 @@ sub split_url {
     return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
 }
 
     return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
 }
 

+=func to_bool
+
+=func to_number
+
+=func to_string
+
+=func to_time
+
+=func to_tristate
+
+=func to_uuid
+
+Various typecasting / coercive functions.
+
+=cut
+
+sub to_bool   { $_[0] // return; boolean($_[0]) }
+sub to_number { $_[0] // return; 0+$_[0] }
+sub to_string { $_[0] // return; "$_[0]" }
+sub to_time   {
+    $_[0] // return;
+    return scalar gmtime($_[0]) if looks_like_number($_[0]);
+    return scalar gmtime if $_[0] eq 'now';
+    return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0];
+    return $_[0];
+}
+sub to_tristate { $_[0] // return; boolean($_[0]) }
+sub to_uuid {
+    my $str = to_string(@_) // return;
+    return sprintf('%016s', $str) if length($str) < 16;
+    return substr($str, 0, 16) if 16 < length($str);
+    return $str;
+}
+

 =func trim
 
     $string = trim($string);
 =func trim
 
     $string = trim($string);


@@ -763,7 +945,7 @@ sub try_load_optional {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {

-            warn $err if $ENV{DEBUG};
+            warn $err if 3 <= DEBUG;

             return;
         }
     }
             return;
         }
     }


@@ -820,21 +1002,13 @@ sub uuid {
 
 }
 
 
 }
 

-=func FALSE
-
-=func TRUE
+=func UUID_NULL

 
 

-Constants appropriate for use as return values in functions claiming to return true or false.
+Get the null UUID (i.e. string of 16 null bytes).

 
 =cut
 
 
 =cut
 

-sub FALSE() { !1 }
-sub TRUE()  {  1 }
-
-BEGIN {
-    my $use_cowrefcnt = eval { require B::COW; 1 };
-    *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
-}
+sub UUID_NULL() { "\0" x 16 }

 
 ### --------------------------------------------------------------------------
 
 
 ### --------------------------------------------------------------------------