1 package File
::KDBX
::Util
;
2 # ABSTRACT: Utility functions for working with KDBX files
7 use Crypt
::PRNG
qw(random_bytes random_string);
8 use Encode
qw(decode encode);
9 use Exporter
qw(import);
10 use File
::KDBX
::Constants
qw(:bool);
11 use File
::KDBX
::Error
;
12 use List
::Util
1.33 qw(any all);
14 use Ref
::Util
qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref);
15 use Scalar
::Util
qw(blessed readonly);
16 use namespace
::clean
-except
=> 'import';
18 our $VERSION = '999.999'; # VERSION
21 assert
=> [qw(assert_64bit)],
22 clone
=> [qw(clone clone_nomagic)],
23 crypt => [qw(pad_pkcs7)],
24 debug
=> [qw(dumper)],
25 fork => [qw(can_fork)],
26 function
=> [qw(memoize recurse_limit)],
27 empty
=> [qw(empty nonempty)],
28 erase
=> [qw(erase erase_scoped)],
29 gzip
=> [qw(gzip gunzip)],
30 io
=> [qw(is_readable is_writable read_all)],
31 load
=> [qw(load_optional load_xs try_load_optional)],
32 search
=> [qw(query search search_limited simple_expression_query)],
33 text
=> [qw(snakify trim)],
34 uuid
=> [qw(format_uuid generate_uuid is_uuid uuid)],
35 uri
=> [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
38 $EXPORT_TAGS{all
} = [map { @$_ } values %EXPORT_TAGS];
39 our @EXPORT_OK = @{$EXPORT_TAGS{all
}};
58 '-not' => 1, # special
88 $bool = load_xs
($version);
90 Attempt to load L
<File
::KDBX
::XS
>. Return truthy
if C
<XS
> is loaded
. If C
<$version> is given, it will check
91 that at least the
given version
is loaded
.
99 goto IS_LOADED
if defined $XS_LOADED;
101 if ($ENV{PERL_ONLY
} || (exists $ENV{PERL_FILE_KDBX_XS
} && !$ENV{PERL_FILE_KDBX_XS
})) {
102 return $XS_LOADED = FALSE
;
105 $XS_LOADED = !!eval { require File
::KDBX
::XS
; 1 };
110 return $XS_LOADED if !$version;
111 return !!eval { File
::KDBX
::XS-
>VERSION($version); 1 };
119 Throw
if perl doesn
't support 64-bit IVs.
125 $Config::Config{ivsize} < 8
126 and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize};
133 Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>.
139 return 1 if $Config::Config{d_fork};
140 return 0 if $^O ne 'MSWin32
' && $^O ne 'NetWare
';
141 return 0 if !$Config::Config{useithreads};
142 return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/;
143 return 0 if $] < 5.008001;
144 if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc
' && $Config::Config{gccversion}) {
145 return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/;
146 my @parts = split(/[\.\s]+/, $Config::Config{gccversion});
147 return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
149 return 0 if $INC{'Devel
/Cover
.pm
'};
155 $clone = clone($thing);
157 Clone deeply. This is an unadorned alias to L<Storable> C<dclone>.
163 goto &Storable::dclone;
168 $clone = clone_nomagic($thing);
170 Clone deeply without keeping [most of] the magic.
172 B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data
or recursive
179 if (is_arrayref
($thing)) {
180 my @arr = map { clone_nomagic
($_) } @$thing;
183 elsif (is_hashref
($thing)) {
185 $hash{$_} = clone_nomagic
($thing->{$_}) for keys %$thing;
188 elsif (is_ref
($thing)) {
189 return clone
($thing);
196 $str = dumper
$thing;
197 dumper
$thing; # in void context, prints to STDERR
199 Like L
<Data
::Dumper
> but slightly terser
in some cases relevent to L
<File
::KDBX
>.
204 require Data
::Dumper
;
205 # avoid "once" warnings
206 local $Data::Dumper
::Deepcopy
= $Data::Dumper
::Deepcopy
= 1;
207 local $Data::Dumper
::Deparse
= $Data::Dumper
::Deparse
= 1;
208 local $Data::Dumper
::Indent
= 1;
209 local $Data::Dumper
::Quotekeys
= 0;
210 local $Data::Dumper
::Sortkeys
= 1;
211 local $Data::Dumper
::Terse
= 1;
212 local $Data::Dumper
::Trailingcomma
= 1;
213 local $Data::Dumper
::Useqq
= 1;
216 for my $struct (@_) {
217 my $str = Data
::Dumper
::Dumper
($struct);
220 $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
222 $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \)/Time::Piece->new($1)/gs;
224 print STDERR
$str if !defined wantarray;
228 return join("\n", @dumps);
235 $bool = empty
$thing;
237 $bool = nonempty
$thing;
239 Test whether a thing
is empty
(or nonempty
). An empty thing
is one of these
:
246 * hash with zero keys
247 * reference to an empty thing (recursive)
249 Note in particular that zero C<0> is not considered empty because it is an actual value.
253 sub empty
{ _empty
(@_) }
254 sub nonempty
{ !_empty
(@_) }
261 || (is_arrayref
($_) && @$_ == 0)
262 || (is_hashref
($_) && keys %$_ == 0)
263 || (is_scalarref
($_) && (!defined $$_ || $$_ eq ''))
264 || (is_refref
($_) && _empty
($$_));
270 erase
(\
$string, ...);
272 Overwrite the memory used by one
or more string
.
278 *_CowREFCNT
= \
&File
::KDBX
::XS
::CowREFCNT
;
280 elsif (eval { require B
::COW
; 1 }) {
281 *_CowREFCNT
= \
&B
::COW
::cowrefcnt
;
284 *_CowREFCNT
= sub { undef };
289 # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
290 # creating a copy and erasing the copy.
291 # TODO - Is this worth doing? Need some benchmarking.
294 next if !defined $_ || readonly
$_;
295 my $cowrefcnt = _CowREFCNT
($_);
296 goto FREE_NONREF
if defined $cowrefcnt && 1 < $cowrefcnt;
297 # if (__PACKAGE__->can('erase_xs')) {
301 substr($_, 0, length($_), "\0" x
length($_));
304 no warnings
'uninitialized';
308 elsif (is_scalarref
($_)) {
309 next if !defined $$_ || readonly
$$_;
310 my $cowrefcnt = _CowREFCNT
($$_);
311 goto FREE_REF
if defined $cowrefcnt && 1 < $cowrefcnt;
312 # if (__PACKAGE__->can('erase_xs')) {
316 substr($$_, 0, length($$_), "\0" x
length($$_));
319 no warnings
'uninitialized';
323 elsif (is_arrayref
($_)) {
327 elsif (is_hashref
($_)) {
332 throw
'Cannot erase this type of scalar', type
=> ref $_, what
=> $_;
339 $scope_guard = erase_scoped
($string, ...);
340 $scope_guard = erase_scoped
(\
$string, ...);
341 undef $scope_guard; # erase happens here
343 Get a scope guard that will cause scalars to be erased later
(i
.e
. when the scope ends
). This
is useful
if you
344 want to make sure a string gets erased after you
're done with it, even if the scope ends abnormally.
351 throw 'Programmer error
: Cannot call erase_scoped
in void context
' if !defined wantarray;
354 !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
355 or throw 'Cannot erase this type of
scalar', type => ref $_, what => $_;
356 push @args, is_ref($_) ? $_ : \$_;
358 require Scope::Guard;
359 return Scope::Guard->new(sub { erase(@args) });
364 $string_uuid = format_uuid($raw_uuid);
365 $string_uuid = format_uuid($raw_uuid, $delimiter);
367 Format a 128-bit UUID (given as a string of 16 octets) into a hexidecimal string, optionally with a delimiter
368 to break up the UUID visually into five parts. Examples:
370 my $uuid = uuid('01234567-89AB-CDEF-0123-456789ABCDEF
');
371 say format_uuid($uuid); # -> 0123456789ABCDEF0123456789ABCDEF
372 say format_uuid($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF
374 This is the inverse of L</uuid>.
379 local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
380 my $delim = shift // '';
381 length($_) == 16 or throw 'Must provide a
16-bytes UUID
', size => length($_), str => $_;
382 return uc(join($delim, unpack('H8 H4 H4 H4 H12
', $_)));
387 $uuid = generate_uuid;
388 $uuid = generate_uuid(\%set);
389 $uuid = generate_uuid(\&test_uuid);
391 Generate a new random UUID. It's pretty unlikely that this will generate a repeat
, but
if you
're worried about
392 that you can provide either a set of existing UUIDs (as a hashref where the keys are the elements of a set) or
393 a function to check for existing UUIDs, and this will be sure to not return a UUID already in provided set.
394 Perhaps an example will make it clear:
397 uuid('12345678-9ABC-DEFG-1234-56789ABCDEFG
') => 'whatever
',
399 $uuid = generate_uuid(\%uuid_set);
401 $uuid = generate_uuid(sub { !$uuid_set{$_} });
403 Here, C<$uuid> can't be
"12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L
</uuid
> to easily
pack
404 a
16-byte UUID from a literal
, but it otherwise
is not a consequential part of the example
.
409 my $set = @_ % 2 == 1 ? shift : undef;
411 my $test = $set //= $args{test
};
412 $test = sub { !$set->{$_} } if is_hashref
($test);
414 my $printable = $args{printable
} // $args{print};
417 $_ = $printable ? random_string
(16) : random_bytes
(16);
418 } while (!$test->($_));
424 $unzipped = gunzip
($string);
426 Decompress an octet stream
.
431 load_optional
('Compress::Raw::Zlib');
433 my ($i, $status) = Compress
::Raw
::Zlib
::Inflate-
>new(-WindowBits
=> 31);
434 $status == Compress
::Raw
::Zlib
::Z_OK
()
435 or throw
'Failed to initialize compression library', status
=> $status;
436 $status = $i->inflate($_, my $out);
437 $status == Compress
::Raw
::Zlib
::Z_STREAM_END
()
438 or throw
'Failed to decompress data', status
=> $status;
444 $zipped = gzip
($string);
446 Compress an octet stream
.
451 load_optional
('Compress::Raw::Zlib');
453 my ($d, $status) = Compress
::Raw
::Zlib
::Deflate-
>new(-WindowBits
=> 31, -AppendOutput
=> 1);
454 $status == Compress
::Raw
::Zlib
::Z_OK
()
455 or throw
'Failed to initialize compression library', status
=> $status;
456 $status = $d->deflate($_, my $out);
457 $status == Compress
::Raw
::Zlib
::Z_OK
()
458 or throw
'Failed to compress data', status
=> $status;
459 $status = $d->flush($out);
460 $status == Compress
::Raw
::Zlib
::Z_OK
()
461 or throw
'Failed to compress data', status
=> $status;
469 $bool = is_readable
($mode);
470 $bool = is_writable
($mode);
472 Determine of an C
<fopen
>-style mode
is readable
, writable
or both
.
476 sub is_readable
{ $_[0] !~ /^[aw]b?$/ }
477 sub is_writable
{ $_[0] !~ /^rb?$/ }
481 $bool = is_uuid
($thing);
483 Check
if a thing
is a UUID
(i
.e
. scalar string of
length 16).
487 sub is_uuid
{ defined $_[0] && !is_ref
($_[0]) && length($_[0]) == 16 }
491 $package = load_optional
($package);
493 Load a module that isn
't required but can provide extra functionality. Throw if the module is not available.
498 for my $module (@_) {
499 eval { load $module };
501 warn $err if $ENV{DEBUG};
502 throw "Missing dependency: Please install $module to use this feature.\n", module => $module;
505 return wantarray ? @_ : $_[0];
510 \&memoized_code = memoize(\&code, ...);
512 Memoize a function. Extra arguments are passed through to C<&code> when it is called.
520 return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) };
525 $padded_string = pad_pkcs7($string, $block_size),
527 Pad a block using the PKCS#7 method.
532 my $data = shift // throw 'Must provide a string to pad
';
533 my $size = shift or throw 'Must provide block size
';
535 0 <= $size && $size < 256
536 or throw 'Cannot add PKCS7 padding to a large block size
', size => $size;
538 my $pad_len = $size - length($data) % $size;
539 $data .= chr($pad_len) x $pad_len;
544 $query = query(@where);
547 Generate a function that will run a series of tests on a passed hashref and return true or false depending on
548 if the data record in the hash matched the specified logic.
550 The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration
551 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
554 See L<File::KDBX/QUERY> for examples.
558 sub query { _query(undef, '-or', \@_) }
562 $size = read_all($fh, my $buffer, $size);
563 $size = read_all($fh, my $buffer, $size, $offset);
565 Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
566 distinguishable from other errors by C<$!> not being set.
570 sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes)
571 my $result = @_ == 3 ? read($_[0], $_[1], $_[2])
572 : read($_[0], $_[1], $_[2], $_[3]);
573 return if !defined $result;
574 return if $result != $_[2];
580 \&limited_code = recurse_limit(\&code);
581 \&limited_code = recurse_limit(\&code, $max_depth);
582 \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler);
584 Wrap a function with a guard to prevent deep recursion.
590 my $max_depth = shift // 200;
591 my $error = shift // sub {};
593 return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) };
598 # Generate a query on-the-fly:
599 \@matches = search(\@records, @where);
601 # Use a pre-compiled query:
602 $query = query(@where);
603 \@matches = search(\@records, $query);
605 # Use a simple expression:
606 \@matches = search(\@records, \'query terms', @fields);
607 \
@matches = search
(\
@records, \'query terms
', $operator, @fields);
609 # Use your own subroutine:
610 \@matches = search(\@records, \&query);
611 \@matches = search(\@records, sub { $record = shift; ... });
613 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
615 This is the search engine described with many examples at L<File::KDBX/QUERY>.
623 if (is_coderef($query) && !@_) {
626 elsif (is_scalarref($query)) {
627 $query = simple_expression_query($$query, @_);
630 $query = query($query, @_);
634 for my $item (@$list) {
635 push @match, $item if $query->($item);
643 my $limit = shift // 1;
645 if (is_coderef($query) && !@_) {
648 elsif (is_scalarref($query)) {
649 $query = simple_expression_query($$query, @_);
652 $query = query($query, @_);
656 for my $item (@$list) {
657 push @match, $item if $query->($item);
658 last if $limit <= @match;
663 =func simple_expression_query
665 $query = simple_expression_query($expression, @fields);
667 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
668 L<described here|https://keepass.info/help/base/search.html#mode_se>.
670 An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
671 quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
672 one of the given fields.
676 sub simple_expression_query {
678 my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~';
680 my $neg_op = $OP_NEG{$op};
681 my $is_re = $op eq '=~' || $op eq '!~';
683 require Text::ParseWords;
684 my @terms = Text::ParseWords::shellwords($expr);
686 my @query = qw(-and);
688 for my $term (@terms) {
689 my @subquery = qw(-or);
691 my $neg = $term =~ s/^-//;
692 my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)];
695 push @subquery, $field => $condition;
698 push @query, \
@subquery;
701 return query
(\
@query);
706 $string = snakify
($string);
708 Turn a CamelCase string into snake_case
.
714 s/UserName/Username/g;
715 s/([a-z])([A-Z0-9])/${1}_${2}/g;
716 s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g;
722 ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url
($url);
724 Split a URL into its parts
.
726 For example
, C
<http
://user
:pass
@localhost:4000/path
?query
#hash> gets split like:
743 my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m
!
753 $scheme = lc($scheme);
755 $host ||= 'localhost';
758 $path = "/$path" if $path !~ m
!^/!;
760 $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef;
762 my ($username, $password) = split($auth, ':', 2);
764 return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
769 $string = trim
($string);
771 The ubiquitous C
<trim
> function
. Removes all whitespace from both ends of a string
.
775 sub trim
($) { ## no critic (ProhibitSubroutinePrototypes)
776 local $_ = shift // return;
782 =func try_load_optional
784 $package = try_load_optional
($package);
786 Try to load a module that isn
't required but can provide extra functionality, and return true if successful.
790 sub try_load_optional {
791 for my $module (@_) {
792 eval { load $module };
794 warn $err if $ENV{DEBUG};
801 =func uri_escape_utf8
803 $string = uri_escape_utf8($string);
805 Percent-encode arbitrary text strings, like for a URI.
809 my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
810 sub uri_escape_utf8 {
811 local $_ = shift // return;
812 $_ = encode('UTF-8
', $_);
813 # RFC 3986 section 2.3 unreserved characters
814 s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge;
818 =func uri_unescape_utf8
820 $string = uri_unescape_utf8($string);
822 Inverse of L</uri_escape_utf8>.
826 sub uri_unescape_utf8 {
827 local $_ = shift // return;
828 s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
829 return decode('UTF-8
', $_);
834 $raw_uuid = uuid($string_uuid);
836 Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s
, like
837 C
<12345678-9ABC-DEFG-1234-56789ABCDEFG
>) into a string of exactly
16 octets
.
839 This
is the inverse of L
</format_uuid
>.
844 local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
846 /^[A-Fa-f0-9]{32}$/ or throw
'Must provide a formatted 128-bit UUID';
847 return pack('H32', $_);
851 ### --------------------------------------------------------------------------
853 # Determine if an array looks like keypairs from a hash.
854 sub _looks_like_keypairs
{
856 return 0 if @$arr % 2 == 1;
857 for (my $i = 0; $i < @$arr; $i += 2) {
858 return 0 if is_ref
($arr->[$i]);
863 sub _is_operand_plain
{
865 return !(is_hashref
($_) || is_arrayref
($_));
871 my $op = shift // throw
'Must specify a query operator';
874 return _query_simple
($op, $subject) if defined $subject && !is_ref
($op) && ($OPS{$subject} || 2) < 2;
875 return _query_simple
($subject, $op, $operand) if _is_operand_plain
($operand);
876 return _query_inverse
(_query
($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false';
877 return _query
($subject, '-and', [%$operand]) if is_hashref
($operand);
881 my @atoms = @$operand;
883 if (_looks_like_keypairs
(\
@atoms)) {
884 my ($atom, $operand) = splice @atoms, 0, 2;
885 if (my $op_type = $OPS{$atom}) {
886 if ($op_type == 1 && _is_operand_plain
($operand)) { # unary
887 push @queries, _query_simple
($operand, $atom);
890 push @queries, _query
($subject, $atom, $operand);
893 elsif (!is_ref
($atom)) {
894 push @queries, _query
($atom, 'eq', $operand);
898 my $atom = shift @atoms;
899 if ($OPS{$atom}) { # apply new operator over the rest
900 push @queries, _query
($subject, $atom, \
@atoms);
903 else { # apply original operator over this one
904 push @queries, _query
($subject, $op, $atom);
912 elsif ($op eq '-and') {
913 return _query_all
(@queries);
915 elsif ($op eq '-or') {
916 return _query_any
(@queries);
918 throw
'Malformed query';
923 my $op = shift // 'eq';
926 # these special operators can also act as simple operators
927 $op = '!!' if $op eq '-true';
928 $op = '!' if $op eq '-false';
929 $op = '!' if $op eq '-not';
931 defined $subject or throw
'Subject is not set in query';
932 $OPS{$op} >= 0 or throw
'Cannot use a non-simple operator in a simple query';
933 if (empty
($operand)) {
937 # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing.
938 elsif ($op eq 'eq' || $op eq '==') {
941 elsif ($op eq 'ne' || $op eq '!=') {
945 throw
'Operand is required';
949 my $field = sub { blessed
$_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} };
952 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand },
953 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand },
954 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand },
955 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand },
956 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand },
957 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand },
958 '==' => sub { local $_ = $field->(@_); defined && $_ == $operand },
959 '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand },
960 '<' => sub { local $_ = $field->(@_); defined && $_ < $operand },
961 '>' => sub { local $_ = $field->(@_); defined && $_ > $operand },
962 '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand },
963 '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand },
964 '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand },
965 '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand },
966 '!' => sub { local $_ = $field->(@_); ! $_ },
967 '!!' => sub { local $_ = $field->(@_); !!$_ },
968 '-defined' => sub { local $_ = $field->(@_); defined $_ },
969 '-undef' => sub { local $_ = $field->(@_); !defined $_ },
970 '-nonempty' => sub { local $_ = $field->(@_); nonempty
$_ },
971 '-empty' => sub { local $_ = $field->(@_); empty
$_ },
974 return $map{$op} // throw
"Unexpected operator in query: $op",
982 return sub { !$query->(@_) };
989 all
{ $_->($val) } @queries;
997 any
{ $_->($val) } @queries;