]> Dogcows Code - chaz/p5-File-KDBX/blobdiff - lib/File/KDBX/Util.pm
projects / chaz / p5-File-KDBX / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
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 8f7dcb860c648e8faabdc17b342bdb17623b4b1e..5645b4c4a4fa83e994427335ac850a92730ef8cc 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -20,12 +20,12 @@ use namespace::clean -except => 'import';
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
-    assert      => [qw(assert_64bit)],
+    assert      => [qw(DEBUG assert assert_64bit)],
     class       => [qw(extends has list_attributes)],
     clone       => [qw(clone clone_nomagic)],
     coercion    => [qw(to_bool to_number to_string to_time to_tristate to_uuid)],
     crypt       => [qw(pad_pkcs7)],
     class       => [qw(extends has list_attributes)],
     clone       => [qw(clone clone_nomagic)],
     coercion    => [qw(to_bool to_number to_string to_time to_tristate to_uuid)],
     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)],
@@ -33,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 search_limited 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,
@@ -117,6 +126,32 @@ sub load_xs {
     }
 }
 
     }
 }
 
+=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
 
     assert_64bit();
 =func assert_64bit
 
     assert_64bit();
@@ -196,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;
@@ -407,11 +446,13 @@ sub has {
 
     my $store = $args{store};
     ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
 
     my $store = $args{store};
     ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
-    push @{$ATTRIBUTES{$package} //= []}, $name;
 
 
-    my $store_code = '';
-    $store_code = qq{->$store} if $store;
-    my $member = qq{\$_[0]$store_code\->{'$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}
 
     my $default_code = is_coderef $default ? q{scalar $default->($_[0])}
                         : defined $default ? q{$default}
@@ -425,6 +466,7 @@ sub has {
                                   : qq{$member = \$_[1] if \$#_;};
     }
 
                                   : qq{$member = \$_[1] if \$#_;};
     }
 
+    push @{$ATTRIBUTES{$package} //= []}, $name;
     $line -= 4;
     my $code = <<END;
 # line $line "$file"
     $line -= 4;
     my $code = <<END;
 # line $line "$file"
@@ -589,8 +631,9 @@ 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];
@@ -642,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);
@@ -703,23 +766,11 @@ 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;
-
-    if (is_coderef($query) && !@_) {
-        # already a query
-    }
-    elsif (is_scalarref($query)) {
-        $query = simple_expression_query($$query, @_);
-    }
-    else {
-        $query = query($query, @_);
-    }
+    my $query   = query_any(@_);
 
     my @match;
     for my $item (@$list) {
 
     my @match;
     for my $item (@$list) {
@@ -728,36 +779,10 @@ sub search {
     return \@match;
 }
 
     return \@match;
 }
 
-=for Pod::Coverage search_limited
-
-=cut
-
-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 $limit <= @match;
-    }
-    return \@match;
-}
-
 =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>.
@@ -880,7 +905,8 @@ sub to_number { $_[0] // return; 0+$_[0] }
 sub to_string { $_[0] // return; "$_[0]" }
 sub to_time   {
     $_[0] // return;
 sub to_string { $_[0] // return; "$_[0]" }
 sub to_time   {
     $_[0] // return;
-    return gmtime($_[0]) if looks_like_number($_[0]);
+    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];
 }
     return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0];
     return $_[0];
 }
@@ -919,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;
         }
     }
@@ -976,6 +1002,14 @@ sub uuid {
 
 }
 
 
 }
 
+=func UUID_NULL
+
+Get the null UUID (i.e. string of 16 null bytes).
+
+=cut
+
+sub UUID_NULL() { "\0" x 16 }
+
 ### --------------------------------------------------------------------------
 
 # Determine if an array looks like keypairs from a hash.
 ### --------------------------------------------------------------------------
 
 # Determine if an array looks like keypairs from a hash.
Unnamed repository; edit this file 'description' to name the repository.
This page took 0.026416 seconds and 4 git commands to generate.