X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FUtil.pm;h=84cb363158b50b14125e970052a0e0244afa6108;hb=22c06c7b833137dc25dab1942f161fde5bc0d9c3;hp=c3d77ae69b2f08e156eeeb11ed29f330ee76fc53;hpb=4dc2a1996dfcf2dfda3c554daa2f5f59fa763494;p=chaz%2Fp5-File-KDBX

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index c3d77ae..84cb363 100644
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -7,7 +7,6 @@ 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;
@@ -20,28 +19,38 @@ use namespace::clean -except => 'import';
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
-    assert      => [qw(assert_64bit)],
+    assert      => [qw(DEBUG assert)],
     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)],
     erase       => [qw(erase erase_scoped)],
     gzip        => [qw(gzip gunzip)],
-    io          => [qw(is_readable is_writable read_all)],
+    int         => [qw(int64 pack_ql pack_Ql unpack_ql unpack_Ql)],
+    io          => [qw(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)],
-    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}};
 
+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,
@@ -92,8 +101,8 @@ my %ATTRIBUTES;
     $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.
+Attempt to load L<File::KDBX::XS>. Return truthy if it is loaded. If C<$version> is given, it will check that
+at least the given version is loaded.
 
 =cut
 
@@ -104,7 +113,7 @@ sub load_xs {
     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;
+        return $XS_LOADED = !1;
     }
 
     $XS_LOADED = !!eval { require File::KDBX::XS; 1 };
@@ -117,18 +126,30 @@ sub load_xs {
     }
 }
 
-=func assert_64bit
+=func assert
 
-    assert_64bit();
+    assert { ... };
 
-Throw if perl doesn't support 64-bit IVs.
+Write an executable comment. Only executed if C<DEBUG> is set in the environment.
 
 =cut
 
-sub assert_64bit() {
-    require Config;
-    $Config::Config{ivsize} < 8
-        and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize};
+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 can_fork
@@ -196,6 +217,10 @@ sub clone_nomagic {
     return $thing;
 }
 
+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+
 =func dumper
 
     $str = dumper $thing;
@@ -398,59 +423,46 @@ 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 $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
     my $coerce  = $args{coerce};
     my $is      = $args{is} || 'rw';
 
-    my $has_default = is_coderef $default;
-    my $has_coerce  = is_coderef $coerce;
-
     my $store = $args{store};
     ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
 
-    my $caller = caller;
-    push @{$ATTRIBUTES{$caller} //= []}, $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};
 
-    no strict 'refs'; ## no critic (ProhibitNoStrict)
-    if ($store) {
-        *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
-            $_[0]->$store->{$name} //= scalar $default->($_[0]);
-        } : $is eq 'ro' ? sub {
-            $_[0]->$store->{$name} //= $default;
-        } : $has_default && $has_coerce ? sub {
-            $#_ ? $_[0]->$store->{$name} = scalar $coerce->($_[1])
-                : $_[0]->$store->{$name} //= scalar $default->($_[0]);
-        } : $has_default ? sub {
-            $#_ ? $_[0]->$store->{$name} = $_[1]
-                : $_[0]->$store->{$name} //= scalar $default->($_[0]);
-        } : $has_coerce ? sub {
-            $#_ ? $_[0]->$store->{$name} = scalar $coerce->($_[1])
-                : $_[0]->$store->{$name} //= $default;
-        } : sub {
-            $#_ ? $_[0]->$store->{$name} = $_[1]
-                : $_[0]->$store->{$name} //= $default;
-        };
-    }
-    else {
-        *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
-            $_[0]->{$name} //= scalar $default->($_[0]);
-        } : $is eq 'ro' ? sub {
-            $_[0]->{$name} //= $default;
-        } : $has_default && $has_coerce ? sub {
-            $#_ ? $_[0]->{$name} = scalar $coerce->($_[1])
-                : $_[0]->{$name} //= scalar $default->($_[0]);
-        } : $has_default ? sub {
-            $#_ ? $_[0]->{$name} = $_[1]
-                : $_[0]->{$name} //= scalar $default->($_[0]);
-        } : $has_coerce ? sub {
-            $#_ ? $_[0]->{$name} = scalar $coerce->($_[1])
-                : $_[0]->{$name} //= $default;
-        } : sub {
-            $#_ ? $_[0]->{$name} = $_[1]
-                : ($_[0]->{$name} //= $default);
-        };
+
+    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
@@ -556,19 +568,117 @@ sub gzip {
     return $out;
 }
 
-=func is_readable
+=func int64
+
+    $int = int64($string);
+
+Get a scalar integer capable of holding 64-bit values, initialized with a given default value. On a 64-bit
+perl, it will return a regular SvIV. On a 32-bit perl it will return a L<Math::BigInt>.
+
+=cut
+
+sub int64 {
+    require Config;
+    if ($Config::Config{ivsize} < 8) {
+        require Math::BigInt;
+        return Math::BigInt->new(@_);
+    }
+    return 0 + shift;
+}
+
+=func pack_Ql
+
+    $bytes = pack_Ql($int);
+
+Like C<pack('QE<lt>', $int)>, but also works on 32-bit perls.
+
+=cut
+
+sub pack_Ql {
+    my $num = shift;
+    require Config;
+    if ($Config::Config{ivsize} < 8) {
+        if (blessed $num && $num->can('as_hex')) {
+            return "\xff\xff\xff\xff\xff\xff\xff\xff" if Math::BigInt->new('18446744073709551615') <= $num;
+            return "\x00\x00\x00\x00\x00\x00\x00\x80" if $num <= Math::BigInt->new('-9223372036854775808');
+            my $neg;
+            if ($num < 0) {
+                $neg = 1;
+                $num = -$num;
+            }
+            my $hex = $num->as_hex;
+            $hex =~ s/^0x/000000000000000/;
+            my $bytes = reverse pack('H16', substr($hex, -16));
+            $bytes .= "\0" x (8 - length $bytes) if length $bytes < 8;
+            if ($neg) {
+                # two's compliment
+                $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes));
+                substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) + 1));
+            }
+            return $bytes;
+        }
+        else {
+            my $pad = $num < 0 ? "\xff" : "\0";
+            return pack('L<', $num) . ($pad x 4);
+        };
+    }
+    return pack('Q<', $num);
+}
+
+=func pack_ql
+
+    $bytes = pack_ql($int);
+
+Like C<pack('qE<lt>', $int)>, but also works on 32-bit perls.
+
+=cut
+
+sub pack_ql { goto &pack_Ql }
+
+=func unpack_Ql
+
+    $int = unpack_Ql($bytes);
+
+Like C<unpack('QE<lt>', $bytes)>, but also works on 32-bit perls.
+
+=cut
 
-=func is_writable
+sub unpack_Ql {
+    my $bytes = shift;
+    require Config;
+    if ($Config::Config{ivsize} < 8) {
+        require Math::BigInt;
+        return Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes));
+    }
+    return unpack('Q<', $bytes);
+}
 
-    $bool = is_readable($mode);
-    $bool = is_writable($mode);
+=func unpack_ql
 
-Determine of an C<fopen>-style mode is readable, writable or both.
+    $int = unpack_ql($bytes);
+
+Like C<unpack('qE<lt>', $bytes)>, but also works on 32-bit perls.
 
 =cut
 
-sub is_readable { $_[0] !~ /^[aw]b?$/ }
-sub is_writable { $_[0] !~ /^rb?$/ }
+sub unpack_ql {
+    my $bytes = shift;
+    require Config;
+    if ($Config::Config{ivsize} < 8) {
+        require Math::BigInt;
+        if (ord(substr($bytes, -1, 1)) & 128) {
+            return Math::BigInt->new('-9223372036854775808') if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x80";
+            # two's compliment
+            substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) - 1));
+            $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes));
+            return -Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes));
+        }
+        else {
+            return Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes));
+        }
+    }
+    return unpack('q<', $bytes);
+}
 
 =func is_uuid
 
@@ -605,8 +715,9 @@ sub load_optional {
     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];
@@ -658,19 +769,39 @@ 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.
 
-See L<File::KDBX/QUERY> for examples.
+See L<File::KDBX/"Declarative Syntax"> for examples.
 
 =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);
     $size = read_all($fh, my $buffer, $size, $offset);
 
-Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
-distinguishable from other errors by C<$!> not being set.
+Like L<perlfunc/"read FILEHANDLE,SCALAR,LENGTH,OFFSET"> but returns C<undef> if not all C<$size> bytes are
+read. This is considered an error, distinguishable from other errors by C<$!> not being set.
 
 =cut
 
@@ -719,54 +850,15 @@ sub recurse_limit {
 
 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;
-    my $query   = shift;
-
-    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);
-    }
-    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 $query   = query_any(@_);
 
     my @match;
     for my $item (@$list) {
         push @match, $item if $query->($item);
-        last if $limit <= @match;
     }
     return \@match;
 }
@@ -774,6 +866,7 @@ sub search_limited {
 =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>.
@@ -896,7 +989,8 @@ sub to_number { $_[0] // return; 0+$_[0] }
 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];
 }
@@ -935,7 +1029,7 @@ sub try_load_optional {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {
-            warn $err if $ENV{DEBUG};
+            warn $err if 3 <= DEBUG;
             return;
         }
     }
@@ -992,6 +1086,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.