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 9c4e6f63cea884dcde6fd14e2e4a51c45fcdd51c..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,7 +30,8 @@ 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)],
     search      => [qw(query query_any search simple_expression_query)],
     text        => [qw(snakify trim)],
     load        => [qw(load_optional load_xs try_load_optional)],
     search      => [qw(query query_any search simple_expression_query)],
     text        => [qw(snakify trim)],


@@ -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;


@@ -578,19 +568,117 @@ sub gzip {
     return $out;
 }
 
     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);

 
 

-=func is_writable
+Like C<unpack('QE<lt>', $bytes)>, but also works on 32-bit perls.

 
 

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

 
 

-Determine of an C<fopen>-style mode is readable, writable or both.
+Like C<unpack('qE<lt>', $bytes)>, but also works on 32-bit perls.

 
 =cut
 
 
 =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
 
 
 =func is_uuid
 


@@ -681,7 +769,7 @@ 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
 
 
 =cut
 


@@ -712,8 +800,8 @@ sub query_any {
     $size = read_all($fh, my $buffer, $size);
     $size = read_all($fh, my $buffer, $size, $offset);
 
     $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
 


@@ -901,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];
 }