Fix test fail with older versions of Time::Piece

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

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index 5b12e9dd1ea525135e29611a258537b33d4193a7..84cb363158b50b14125e970052a0e0244afa6108 100644 (file)
--- 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 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;


@@ -20,7 +19,7 @@ use namespace::clean -except => 'import';
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (

-    assert      => [qw(DEBUG assert 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)],
     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)],


@@ -31,9 +30,10 @@ our %EXPORT_TAGS = (
     empty       => [qw(empty nonempty)],
     erase       => [qw(erase erase_scoped)],
     gzip        => [qw(gzip gunzip)],
     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)],
     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)],
     uuid        => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],
     uri         => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
     text        => [qw(snakify trim)],
     uuid        => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],
     uri         => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],


@@ -101,8 +101,8 @@ my %ATTRIBUTES;
     $bool = load_xs();
     $bool = load_xs($version);
 
     $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
 
 
 =cut
 


@@ -113,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})) {
     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 };
     }
 
     $XS_LOADED = !!eval { require File::KDBX::XS; 1 };


@@ -152,20 +152,6 @@ sub assert(&) { ## no critic (ProhibitSubroutinePrototypes)
     die "$0: $file:$line: Assertion failed$assertion\n";
 }
 
     die "$0: $file:$line: Assertion failed$assertion\n";
 }
 

-=func assert_64bit
-
-    assert_64bit();
-
-Throw if perl doesn't support 64-bit IVs.
-
-=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};
-}
-

 =func can_fork
 
     $bool = can_fork;
 =func can_fork
 
     $bool = can_fork;


@@ -231,6 +217,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;


@@ -442,11 +432,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}


@@ -460,6 +452,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"


@@ -575,19 +568,117 @@ sub gzip {
     return $out;
 }
 
     return $out;
 }
 

-=func is_readable
+=func int64

 
 

-=func is_writable
+    $int = int64($string);

 
 

-    $bool = is_readable($mode);
-    $bool = is_writable($mode);
+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;
+}

 
 

-Determine of an C<fopen>-style mode is readable, writable or both.
+=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
 
 
 =cut
 

-sub is_readable { $_[0] !~ /^[aw]b?$/ }
-sub is_writable { $_[0] !~ /^rb?$/ }
+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
+
+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);
+}
+
+=func unpack_ql
+
+    $int = unpack_ql($bytes);
+
+Like C<unpack('qE<lt>', $bytes)>, but also works on 32-bit perls.
+
+=cut
+
+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
 
 
 =func is_uuid
 


@@ -678,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.
 
 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);
     $size = read_all($fh, my $buffer, $size, $offset);
 
 =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
 
 
 =cut
 


@@ -739,23 +850,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) {


@@ -890,7 +989,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];
 }