{{$NEXT}}
+ * Added support for 32-bit perls.
+
0.901 2022-05-02 01:18:13-0600
* Fixed a bug where peeking at memory-protected strings and binaries does
* C<PERL_ONLY> - Do not use L<File::KDBX::XS> if true (default: false)
* C<NO_FORK> - Do not fork if true (default: false)
-=head1 CAVEATS
-
-Some features (e.g. parsing) require 64-bit perl. It should be possible and actually pretty easy to make it
-work using L<Math::BigInt>, but I need to build a 32-bit perl in order to test it and frankly I'm still
-figuring out how. I'm sure it's simple so I'll mark this one "TODO", but for now an exception will be thrown
-when trying to use such features with undersized IVs.
-
=head1 SEE ALSO
=for :list
use strict;
use Exporter qw(import);
+use File::KDBX::Util qw(int64);
use Scalar::Util qw(dualvar);
use namespace::clean -except => 'import';
},
time => {
__prefix => 'TIME',
- SECONDS_AD1_TO_UNIX_EPOCH => 62_135_596_800,
+ SECONDS_AD1_TO_UNIX_EPOCH => int64('62135596800'),
},
yubikey => {
YUBICO_VID => dualvar( 0x1050, 'Yubico'),
use File::KDBX::Error;
use File::KDBX::IO::Crypt;
use File::KDBX::IO::HashBlock;
-use File::KDBX::Util qw(:class :empty :load assert_64bit erase_scoped);
+use File::KDBX::Util qw(:class :empty :int :load erase_scoped);
use IO::Handle;
use namespace::clean;
# nothing
}
elsif ($type == HEADER_TRANSFORM_ROUNDS) {
- assert_64bit;
- $val = pack('Q<', $val);
+ $val = pack_Ql($val);
}
elsif ($type == HEADER_ENCRYPTION_IV) {
# nothing
use File::KDBX::Error;
use File::KDBX::IO::Crypt;
use File::KDBX::IO::HmacBlock;
-use File::KDBX::Util qw(:class :empty :load assert_64bit erase_scoped);
+use File::KDBX::Util qw(:class :empty :int :load erase_scoped);
use IO::Handle;
use Scalar::Util qw(looks_like_number);
use boolean qw(:all);
return VMAP_TYPE_BOOL;
}
elsif (looks_like_number($variant) && ($variant + 0) =~ /^\d+$/) {
- assert_64bit;
my $neg = $variant < 0;
- my @b = unpack('L>2', pack('Q>', $variant));
+ my @b = unpack('L>2', scalar reverse pack_Ql($variant));
return VMAP_TYPE_INT64 if $b[0] && $neg;
return VMAP_TYPE_UINT64 if $b[0];
return VMAP_TYPE_INT32 if $neg;
$val = pack('L<', $val);
}
elsif ($type == VMAP_TYPE_UINT64) {
- assert_64bit;
- $val = pack('Q<', $val);
+ $val = pack_Ql($val);
}
elsif ($type == VMAP_TYPE_BOOL) {
$val = pack('C', $val);
$val = pack('l', $val);
}
elsif ($type == VMAP_TYPE_INT64) {
- assert_64bit;
- $val = pack('q<', $val);
+ $val = pack_ql($val);
}
elsif ($type == VMAP_TYPE_STRING) {
$val = encode('UTF-8', $val);
use Encode qw(encode);
use File::KDBX::Constants qw(:version :time);
use File::KDBX::Error;
-use File::KDBX::Util qw(:class assert_64bit erase_scoped gzip snakify);
+use File::KDBX::Util qw(:class :int erase_scoped gzip snakify);
use IO::Handle;
use Scalar::Util qw(blessed isdual looks_like_number);
use Time::Piece;
sub _encode_datetime_binary {
local $_ = shift;
- assert_64bit;
my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH;
- my $buf = pack('Q<', $seconds_since_ad1->epoch);
+ my $buf = pack_Ql($seconds_since_ad1->epoch);
return eval { encode_b64($buf) };
}
use Crypt::Mac::HMAC qw(hmac);
use Errno;
use File::KDBX::Error;
-use File::KDBX::Util qw(:class :io assert_64bit);
+use File::KDBX::Util qw(:class :int :io);
use namespace::clean;
extends 'File::KDBX::IO';
=cut
my %ATTRS = (
- _block_index => 0,
+ _block_index => int64(0),
_buffer => sub { \(my $buf = '') },
_finished => 0,
block_size => sub { $BLOCK_SIZE },
=cut
sub new {
- assert_64bit;
-
my $class = shift;
my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
my $self = $class->SUPER::new;
or throw 'Failed to read HMAC block', index => $self->_block_index, size => $size;
}
- my $packed_index = pack('Q<', $self->_block_index);
+ my $packed_index = pack_Ql($self->_block_index);
my $got_hmac = hmac('SHA256', $self->_hmac_key,
$packed_index,
$packed_size,
my $block = '';
$block = substr($$buffer, 0, $size, '') if 0 < $size;
- my $packed_index = pack('Q<', $self->_block_index);
+ my $packed_index = pack_Ql($self->_block_index);
my $packed_size = pack('L<', $size);
my $hmac = hmac('SHA256', $self->_hmac_key,
$packed_index,
my $key = shift // $self->key;
my $index = shift // $self->_block_index;
- my $packed_index = pack('Q<', $index);
+ my $packed_index = pack_Ql($index);
my $hmac_key = digest_data('SHA512', $packed_index, $key);
return $hmac_key;
}
use File::KDBX::Error;
use File::KDBX::IO::Crypt;
use File::KDBX::IO::HashBlock;
-use File::KDBX::Util qw(:class :io :load assert_64bit erase_scoped);
+use File::KDBX::Util qw(:class :int :io :load erase_scoped);
use namespace::clean;
extends 'File::KDBX::Loader';
# nothing
}
elsif ($type == HEADER_TRANSFORM_ROUNDS) {
- assert_64bit;
- $val = unpack('Q<', $val);
+ ($val) = unpack_Ql($val);
}
elsif ($type == HEADER_ENCRYPTION_IV) {
# nothing
# nothing
}
elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) {
- $val = unpack('L<', $val);
+ ($val) = unpack('L<', $val);
}
elsif ($type == HEADER_KDF_PARAMETERS ||
$type == HEADER_PUBLIC_CUSTOM_DATA) {
use Encode qw(decode);
use File::KDBX::Constants qw(:header :inner_header :variant_map :compression);
use File::KDBX::Error;
-use File::KDBX::Util qw(:class :io :load assert_64bit erase_scoped);
+use File::KDBX::Util qw(:class :int :io :load erase_scoped);
use File::KDBX::IO::Crypt;
use File::KDBX::IO::HmacBlock;
use boolean;
($val) = unpack('L<', $val);
}
elsif ($type == VMAP_TYPE_UINT64) {
- assert_64bit;
- ($val) = unpack('Q<', $val);
+ ($val) = unpack_Ql($val);
}
elsif ($type == VMAP_TYPE_BOOL) {
($val) = unpack('C', $val);
($val) = unpack('l<', $val);
}
elsif ($type == VMAP_TYPE_INT64) {
- assert_64bit;
- ($val) = unpack('q<', $val);
+ ($val) = unpack_ql($val);
}
elsif ($type == VMAP_TYPE_STRING) {
$val = decode('UTF-8', $val);
use File::KDBX::Constants qw(:version :time);
use File::KDBX::Error;
use File::KDBX::Safe;
-use File::KDBX::Util qw(:class :text assert_64bit gunzip erase_scoped);
+use File::KDBX::Util qw(:class :int :text gunzip erase_scoped);
use Scalar::Util qw(looks_like_number);
use Time::Piece;
use XML::LibXML::Reader;
throw 'Failed to parse binary datetime', text => $_, error => $err;
}
throw $@ if $@;
- assert_64bit;
$binary .= \0 x (8 - length($binary)) if length($binary) < 8;
- my ($seconds_since_ad1) = unpack('Q<', $binary);
+ my ($seconds_since_ad1) = unpack_Ql($binary);
my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH;
return Time::Piece->new($epoch);
}
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;
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)],
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)],
$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
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 };
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;
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('to_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 $bytes = reverse pack('H16', substr(('0' x 15) . $num->to_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);
-=func is_writable
+Like C<pack('qE<lt>', $int)>, but also works on 32-bit perls.
- $bool = is_readable($mode);
- $bool = is_writable($mode);
+=cut
-Determine of an C<fopen>-style mode is readable, writable or both.
+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 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;
+ 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
inner_random_stream_key => "\214\aW\253\362\177<\346n`\263l\245\353T\25\261BnFp\177\357\335\36(b\372z\231b\355",
kdf_parameters => {
"\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
- R => 6000,
+ R => num(6000),
S => "S\202\207A\3475\265\177\220\331\263[\334\326\365\324B\\\2222zb-f\263m\220\333S\361L\332",
},
master_seed => "\253!\2\241\r*|{\227\0276Lx\215\32\\\17\372d\254\255*\21r\376\251\313+gMI\343",
inner_random_stream_key => "\346\n8\2\322\264i\5\5\274\22\377+\16tB\353\210\1\2m\2U%\326\347\355\313\313\340A\305",
kdf_parameters => {
"\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
- R => 6000,
+ R => num(6000),
S => "\340\377\235\255\222o\1(\226m\373\tC{K\352\f\332M\302|~P\e\346J\@\275A\227\236\366",
},
master_seed => "Z\230\355\353\2303\361\237-p\345\27nM\22<E\252\314k\20\257\302\343p\"y\5sfw ",
inner_random_stream_key => "Z\244]\373\13`\2108=>\r\224\351\373\316\276\253\6\317z\356\302\36\fW\1776Q\366\32\34,",
kdf_parameters => {
"\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
- R => 6000,
+ R => num(6000),
S => "l\254\250\255\240U\313\364\336\316#\254\306\231\f%U\207J\235\275\34\b\25036\26\241\a\300\26\332",
},
master_seed => "\13\350\370\214{\0276\17dv\31W[H\26\272\4\335\377\356\275N\"\2A1\364\213\226\237\303M",
inner_random_stream_key => "+\232\222\302\20\333\254\342YD\371\34\373,\302:\303\247\t\26\$\a\370g\314\32J\240\371;U\234",
kdf_parameters => {
"\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
- R => 6000,
+ R => num(6000),
S => "\3!\230hx\363\220nV\23\340\316\262\210\26Z\al?\343\240\260\325\262\31i\223y\b\306\344V",
},
master_seed => "\0206\244\265\203m14\257T\372o\16\271\306\347\215\365\376\304\20\356\344\3713\3\303\363\a\5\205\325",
kdf_parameters => ignore(),
kdf_parameters => {
"\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
- R => 6000,
+ R => num(6000),
S => "y\251\327\312mW8B\351\273\364#T#m:\370k1\240v\360E\245\304\325\265\313\337\245\211E",
},
master_seed => "\355\32<1\311\320\315\24\204\325\250\35+\2525\321\224x?\361\355\310V\322\20\331\324\"\372\334\210\233",
encryption_iv => "3?\207P\233or\220\215h\2240",
kdf_parameters => {
"\$UUID" => "\357cm\337\214)DK\221\367\251\244\3\343\n\f",
- I => 2,
- M => 1048576,
- P => 2,
+ I => num(2),
+ M => num(1048576),
+ P => num(2),
S => "V\254\6m-\206*\260\305\f\0\366\24:4\235\364A\362\346\221\13)}\250\217P\303\303\2\331\245",
- V => 19,
+ V => num(19),
},
master_seed => ";\372y\300yS%\3331\177\231\364u\265Y\361\225\3273h\332R,\22\240a\240\302\271\357\313\23",
}, 'Extract headers' or diag explain $kdbx->headers;
use TestCommon;
use File::KDBX::Util qw(:all);
+use Math::BigInt 1.999808;
+use Scalar::Util qw(blessed);
use Test::More;
can_ok('File::KDBX::Util', qw{
- assert_64bit
can_fork
dumper
empty
like exception { pad_pkcs7('bar', 0) }, qr/must provide block size/i, 'Size must be non-zero';
};
+subtest '64-bit packing' => sub {
+ for my $test (
+ # bytes, value
+ ["\xfe\xff\xff\xff\xff\xff\xff\xff", -2],
+ ["\xff\xff\xff\xff\xff\xff\xff\xff", -1],
+ ["\x00\x00\x00\x00\x00\x00\x00\x00", 0],
+ ["\x01\x00\x00\x00\x00\x00\x00\x00", 1],
+ ["\x02\x00\x00\x00\x00\x00\x00\x00", 2],
+ ["\x01\x01\x00\x00\x00\x00\x00\x00", 257],
+ ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('-2')],
+ ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('-1')],
+ ["\x00\x00\x00\x00\x00\x00\x00\x00", Math::BigInt->new('0')],
+ ["\x01\x00\x00\x00\x00\x00\x00\x00", Math::BigInt->new('1')],
+ ["\x02\x00\x00\x00\x00\x00\x00\x00", Math::BigInt->new('2')],
+ ["\x01\x01\x00\x00\x00\x00\x00\x00", Math::BigInt->new('257')],
+ ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551614')],
+ ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551615')],
+ ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551616')], # overflow
+ ["\x02\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775806')],
+ ["\x01\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775807')],
+ ["\x00\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775808')],
+ ["\x00\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('-9223372036854775809')], # overflow
+ ) {
+ my ($bytes, $num) = @$test;
+ my $desc = sprintf('Pack %s => %s', $num, unpack('H*', $bytes));
+ $desc =~ s/^(Pack)/$1 bigint/ if blessed $num;
+ my $p = pack_Ql($num);
+ is $p, $bytes, $desc or diag unpack('H*', $p);
+ }
+
+ for my $test (
+ # bytes, unsigned value, signed value
+ ["\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0],
+ ["\x01\x00\x00\x00\x00\x00\x00\x00", 1, 1],
+ ["\x02\x00\x00\x00\x00\x00\x00\x00", 2, 2],
+ ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551614'), -2],
+ ["\xff\xff\xff\xff\xff\xff\xff\xff", Math::BigInt->new('18446744073709551615'), -1],
+ ["\x02\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('9223372036854775810'),
+ Math::BigInt->new('-9223372036854775806')],
+ ["\x01\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('9223372036854775809'),
+ Math::BigInt->new('-9223372036854775807')],
+ ["\x00\x00\x00\x00\x00\x00\x00\x80", Math::BigInt->new('9223372036854775808'),
+ Math::BigInt->new('-9223372036854775808')],
+ ) {
+ my ($bytes, $num1, $num2) = @$test;
+ my $desc = sprintf('Unpack %s => %s', unpack('H*', $bytes), $num1);
+ my $p = unpack_Ql($bytes);
+ cmp_ok $p, '==', $num1, $desc or diag $p;
+ $desc = sprintf('Unpack signed %s => %s', unpack('H*', $bytes), $num2);
+ my $q = unpack_ql($bytes);
+ cmp_ok $q, '==', $num2, $desc or diag $q;
+ };
+};
+
done_testing;
projects / chaz / p5-File-KDBX / commitdiff
