X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FUtil.pm;h=e9bb316762b8e373fb7f8ef486826599e579d522;hb=afae2e268e27694e7d64721dd974d22ed3efae9b;hp=d36bcda7cff81b7af0f41e34a030420c71183bf1;hpb=eefcd42a336641c8927b29d12c5c59443212468f;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index d36bcda..e9bb316 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -1,13 +1,13 @@ package File::KDBX::Util; # ABSTRACT: Utility functions for working with KDBX files +use 5.010; use warnings; 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,7 +20,7 @@ use namespace::clean -except => 'import'; 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)], @@ -31,7 +31,8 @@ our %EXPORT_TAGS = ( 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)], @@ -101,8 +102,8 @@ my %ATTRIBUTES; $bool = load_xs(); $bool = load_xs($version); -Attempt to load L. Return truthy if C is loaded. If C<$version> is given, it will check -that at least the given version is loaded. +Attempt to load L. Return truthy if it is loaded. If C<$version> is given, it will check that +at least the given version is loaded. =cut @@ -113,7 +114,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 }; @@ -152,20 +153,6 @@ sub assert(&) { ## no critic (ProhibitSubroutinePrototypes) 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; @@ -582,19 +569,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. + +=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', $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); -=func is_writable +Like C', $int)>, but also works on 32-bit perls. - $bool = is_readable($mode); - $bool = is_writable($mode); +=cut -Determine of an C-style mode is readable, writable or both. +sub pack_ql { goto &pack_Ql } + +=func unpack_Ql + + $int = unpack_Ql($bytes); + +Like C', $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', $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 @@ -685,7 +770,7 @@ The logic can be specified in a manner similar to L for examples. +See L for examples. =cut @@ -716,8 +801,8 @@ sub query_any { $size = read_all($fh, my $buffer, $size); $size = read_all($fh, my $buffer, $size, $offset); -Like L but returns C if not all C<$size> bytes are read. This is considered an error, -distinguishable from other errors by C<$!> not being set. +Like L but returns C if not all C<$size> bytes are +read. This is considered an error, distinguishable from other errors by C<$!> not being set. =cut