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 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)],
$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 $thing;
}
+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+
=func dumper
$str = dumper $thing;
sub extends {
my $parent = shift;
my $caller = caller;
- # load $parent;
- eval qq[require $parent];
+ load $parent;
no strict 'refs'; ## no critic (ProhibitNoStrict)
@{"${caller}::ISA"} = $parent;
}
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}
: qq{$member = \$_[1] if \$#_;};
}
+ push @{$ATTRIBUTES{$package} //= []}, $name;
$line -= 4;
my $code = <<END;
# line $line "$file"
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
-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
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
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 $query = query_any(@_);
my @match;
for my $item (@$list) {
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];
}
projects / chaz / p5-File-KDBX / blobdiff