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 looks_like_number readonly);
18 use namespace
::clean
-except
=> 'import';
20 our $VERSION = '999.999'; # VERSION
23 assert
=> [qw(DEBUG assert assert_64bit)],
24 class => [qw(extends has list_attributes)],
25 clone
=> [qw(clone clone_nomagic)],
26 coercion
=> [qw(to_bool to_number to_string to_time to_tristate to_uuid)],
27 crypt => [qw(pad_pkcs7)],
28 debug
=> [qw(DEBUG dumper)],
29 fork => [qw(can_fork)],
30 function
=> [qw(memoize recurse_limit)],
31 empty
=> [qw(empty nonempty)],
32 erase
=> [qw(erase erase_scoped)],
33 gzip
=> [qw(gzip gunzip)],
34 io
=> [qw(is_readable is_writable read_all)],
35 load
=> [qw(load_optional load_xs try_load_optional)],
36 search
=> [qw(query search simple_expression_query)],
37 text
=> [qw(snakify trim)],
38 uuid
=> [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],
39 uri
=> [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
42 $EXPORT_TAGS{all
} = [map { @$_ } values %EXPORT_TAGS];
43 our @EXPORT_OK = @{$EXPORT_TAGS{all
}};
46 my $debug = $ENV{DEBUG
};
47 $debug = looks_like_number
($debug) ? (0 + $debug) : ($debug ? 1 : 0);
48 *DEBUG
= $debug == 1 ? sub() { 1 } :
49 $debug == 2 ? sub() { 2 } :
50 $debug == 3 ? sub() { 3 } :
51 $debug == 4 ? sub() { 4 } : sub() { 0 };
71 '-not' => 1, # special
102 $bool = load_xs
($version);
104 Attempt to load L
<File
::KDBX
::XS
>. Return truthy
if C
<XS
> is loaded
. If C
<$version> is given, it will check
105 that at least the
given version
is loaded
.
113 goto IS_LOADED
if defined $XS_LOADED;
115 if ($ENV{PERL_ONLY
} || (exists $ENV{PERL_FILE_KDBX_XS
} && !$ENV{PERL_FILE_KDBX_XS
})) {
116 return $XS_LOADED = FALSE
;
119 $XS_LOADED = !!eval { require File
::KDBX
::XS
; 1 };
124 return $XS_LOADED if !$version;
125 return !!eval { File
::KDBX
::XS-
>VERSION($version); 1 };
133 Write an executable comment
. Only executed
if C
<DEBUG
> is set
in the environment
.
137 sub assert
(&) { ## no critic (ProhibitSubroutinePrototypes)
142 (undef, my $file, my $line) = caller;
143 $file =~ s!([^/\\]+)$!$1!;
145 if (try_load_optional
('B::Deparse')) {
146 my $deparse = B
::Deparse-
>new(qw{-P -x9});
147 $assertion = $deparse->coderef2text($code);
148 $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s;
149 $assertion =~ s/\s+/ /gs;
150 $assertion = ": $assertion";
152 die "$0: $file:$line: Assertion failed$assertion\n";
159 Throw
if perl doesn
't support 64-bit IVs.
165 $Config::Config{ivsize} < 8
166 and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize};
173 Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>.
179 return 1 if $Config::Config{d_fork};
180 return 0 if $^O ne 'MSWin32
' && $^O ne 'NetWare
';
181 return 0 if !$Config::Config{useithreads};
182 return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/;
183 return 0 if $] < 5.008001;
184 if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc
' && $Config::Config{gccversion}) {
185 return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/;
186 my @parts = split(/[\.\s]+/, $Config::Config{gccversion});
187 return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
189 return 0 if $INC{'Devel
/Cover
.pm
'};
195 $clone = clone($thing);
197 Clone deeply. This is an unadorned alias to L<Storable> C<dclone>.
203 goto &Storable::dclone;
208 $clone = clone_nomagic($thing);
210 Clone deeply without keeping [most of] the magic.
212 B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data
or recursive
219 if (is_arrayref
($thing)) {
220 my @arr = map { clone_nomagic
($_) } @$thing;
223 elsif (is_hashref
($thing)) {
225 $hash{$_} = clone_nomagic
($thing->{$_}) for keys %$thing;
228 elsif (is_ref
($thing)) {
229 return clone
($thing);
236 $str = dumper
$thing;
237 dumper
$thing; # in void context, prints to STDERR
239 Like L
<Data
::Dumper
> but slightly terser
in some cases relevent to L
<File
::KDBX
>.
244 require Data
::Dumper
;
245 # avoid "once" warnings
246 local $Data::Dumper
::Deepcopy
= $Data::Dumper
::Deepcopy
= 1;
247 local $Data::Dumper
::Deparse
= $Data::Dumper
::Deparse
= 1;
248 local $Data::Dumper
::Indent
= 1;
249 local $Data::Dumper
::Quotekeys
= 0;
250 local $Data::Dumper
::Sortkeys
= 1;
251 local $Data::Dumper
::Terse
= 1;
252 local $Data::Dumper
::Trailingcomma
= 1;
253 local $Data::Dumper
::Useqq
= 1;
256 for my $struct (@_) {
257 my $str = Data
::Dumper
::Dumper
($struct);
260 $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
262 $str =~ s
/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/
263 "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges
;
265 print STDERR
$str if !defined wantarray;
269 return join("\n", @dumps);
276 $bool = empty
$thing;
278 $bool = nonempty
$thing;
280 Test whether a thing
is empty
(or nonempty
). An empty thing
is one of these
:
287 * hash with zero keys
288 * reference to an empty thing (recursive)
290 Note in particular that zero C<0> is not considered empty because it is an actual value.
294 sub empty
{ _empty
(@_) }
295 sub nonempty
{ !_empty
(@_) }
302 || (is_arrayref
($_) && @$_ == 0)
303 || (is_hashref
($_) && keys %$_ == 0)
304 || (is_scalarref
($_) && (!defined $$_ || $$_ eq ''))
305 || (is_refref
($_) && _empty
($$_));
311 erase
(\
$string, ...);
313 Overwrite the memory used by one
or more string
.
319 *_CowREFCNT
= \
&File
::KDBX
::XS
::CowREFCNT
;
321 elsif (eval { require B
::COW
; 1 }) {
322 *_CowREFCNT
= \
&B
::COW
::cowrefcnt
;
325 *_CowREFCNT
= sub { undef };
330 # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
331 # creating a copy and erasing the copy.
332 # TODO - Is this worth doing? Need some benchmarking.
335 next if !defined $_ || readonly
$_;
336 my $cowrefcnt = _CowREFCNT
($_);
337 goto FREE_NONREF
if defined $cowrefcnt && 1 < $cowrefcnt;
338 # if (__PACKAGE__->can('erase_xs')) {
342 substr($_, 0, length($_), "\0" x
length($_));
345 no warnings
'uninitialized';
349 elsif (is_scalarref
($_)) {
350 next if !defined $$_ || readonly
$$_;
351 my $cowrefcnt = _CowREFCNT
($$_);
352 goto FREE_REF
if defined $cowrefcnt && 1 < $cowrefcnt;
353 # if (__PACKAGE__->can('erase_xs')) {
357 substr($$_, 0, length($$_), "\0" x
length($$_));
360 no warnings
'uninitialized';
364 elsif (is_arrayref
($_)) {
368 elsif (is_hashref
($_)) {
373 throw
'Cannot erase this type of scalar', type
=> ref $_, what
=> $_;
380 $scope_guard = erase_scoped
($string, ...);
381 $scope_guard = erase_scoped
(\
$string, ...);
382 undef $scope_guard; # erase happens here
384 Get a scope guard that will cause scalars to be erased later
(i
.e
. when the scope ends
). This
is useful
if you
385 want to make sure a string gets erased after you
're done with it, even if the scope ends abnormally.
392 throw 'Programmer error
: Cannot call erase_scoped
in void context
' if !defined wantarray;
395 !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
396 or throw 'Cannot erase this type of
scalar', type => ref $_, what => $_;
397 push @args, is_ref($_) ? $_ : \$_;
399 require Scope::Guard;
400 return Scope::Guard->new(sub { erase(@args) });
407 Set up the current module to inheret from another module.
415 no strict 'refs
'; ## no critic (ProhibitNoStrict)
416 @{"${caller}::ISA"} = $parent;
421 has $name => %options;
423 Create an attribute getter/setter. Possible options:
426 * C<is> - Either "rw" (default) or "ro"
427 * C<default> - Default value
428 * C<coerce> - Coercive function
434 my %args = @_ % 2 == 1 ? (default => shift, @_) : @_;
436 my ($package, $file, $line) = caller;
438 my $d = $args{default};
439 my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
440 my $coerce = $args{coerce};
441 my $is = $args{is} || 'rw';
443 my $store = $args{store};
444 ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
445 push @{$ATTRIBUTES{$package} //= []}, $name;
448 $store_code = qq{->$store} if $store;
449 my $member = qq{\$_[0]$store_code\->{'$name'}};
451 my $default_code = is_coderef
$default ? q{scalar $default->($_[0])}
452 : defined $default ? q{$default}
454 my $get = qq{$member //= $default_code;};
458 $set = is_coderef
$coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;}
459 : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \
$#_;}
460 : qq{$member = \$_[1] if \$#_;};
466 sub ${package}::${name} {
467 return $default_code if !Scalar::Util::blessed(\$_[0]);
472 eval $code; ## no critic (ProhibitStringyEval)
477 $string_uuid = format_uuid
($raw_uuid);
478 $string_uuid = format_uuid
($raw_uuid, $delimiter);
480 Format a
128-bit UUID
(given as a string of
16 octets
) into a hexidecimal string
, optionally with a delimiter
481 to
break up the UUID visually into five parts
. Examples
:
483 my $uuid = uuid
('01234567-89AB-CDEF-0123-456789ABCDEF');
484 say format_uuid
($uuid); # -> 0123456789ABCDEF0123456789ABCDEF
485 say format_uuid
($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF
487 This
is the inverse of L
</uuid
>.
492 local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
493 my $delim = shift // '';
494 length($_) == 16 or throw
'Must provide a 16-bytes UUID', size
=> length($_), str
=> $_;
495 return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_)));
500 $uuid = generate_uuid
;
501 $uuid = generate_uuid
(\
%set);
502 $uuid = generate_uuid
(\
&test_uuid
);
504 Generate a new random UUID
. It
's pretty unlikely that this will generate a repeat, but if you're worried about
505 that you can provide either a set of existing UUIDs
(as a hashref where the
keys are the elements of a set
) or
506 a function to check
for existing UUIDs
, and this will be sure to
not return a UUID already
in provided set
.
507 Perhaps an example will make it clear
:
510 uuid
('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever',
512 $uuid = generate_uuid
(\
%uuid_set);
514 $uuid = generate_uuid
(sub { !$uuid_set{$_} });
516 Here
, C
<$uuid> can
't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack
517 a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example.
522 my $set = @_ % 2 == 1 ? shift : undef;
524 my $test = $set //= $args{test};
525 $test = sub { !$set->{$_} } if is_hashref($test);
527 my $printable = $args{printable} // $args{print};
530 $_ = $printable ? random_string(16) : random_bytes(16);
531 } while (!$test->($_));
537 $unzipped = gunzip($string);
539 Decompress an octet stream.
544 load_optional('Compress
::Raw
::Zlib
');
546 my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
547 $status == Compress::Raw::Zlib::Z_OK()
548 or throw 'Failed to initialize compression library
', status => $status;
549 $status = $i->inflate($_, my $out);
550 $status == Compress::Raw::Zlib::Z_STREAM_END()
551 or throw 'Failed to decompress data
', status => $status;
557 $zipped = gzip($string);
559 Compress an octet stream.
564 load_optional('Compress
::Raw
::Zlib
');
566 my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
567 $status == Compress::Raw::Zlib::Z_OK()
568 or throw 'Failed to initialize compression library
', status => $status;
569 $status = $d->deflate($_, my $out);
570 $status == Compress::Raw::Zlib::Z_OK()
571 or throw 'Failed to compress data
', status => $status;
572 $status = $d->flush($out);
573 $status == Compress::Raw::Zlib::Z_OK()
574 or throw 'Failed to compress data
', status => $status;
582 $bool = is_readable($mode);
583 $bool = is_writable($mode);
585 Determine of an C<fopen>-style mode is readable, writable or both.
589 sub is_readable { $_[0] !~ /^[aw]b?$/ }
590 sub is_writable { $_[0] !~ /^rb?$/ }
594 $bool = is_uuid($thing);
596 Check if a thing is a UUID (i.e. scalar string of length 16).
600 sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
602 =func list_attributes
604 @attributes = list_attributes($package);
606 Get a list of attributes for a class.
610 sub list_attributes {
612 return @{$ATTRIBUTES{$package} // []};
617 $package = load_optional($package);
619 Load a module that isn't required but can provide extra functionality
. Throw
if the module
is not available
.
624 for my $module (@_) {
625 eval { load
$module };
627 throw
"Missing dependency: Please install $module to use this feature.\n",
632 return wantarray ? @_ : $_[0];
637 \
&memoized_code
= memoize
(\
&code
, ...);
639 Memoize a function
. Extra arguments are passed through to C
<&code
> when it
is called
.
647 return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) };
652 $padded_string = pad_pkcs7
($string, $block_size),
654 Pad a block using the PKCS
#7 method.
659 my $data = shift // throw
'Must provide a string to pad';
660 my $size = shift or throw
'Must provide block size';
662 0 <= $size && $size < 256
663 or throw
'Cannot add PKCS7 padding to a large block size', size
=> $size;
665 my $pad_len = $size - length($data) % $size;
666 $data .= chr($pad_len) x
$pad_len;
671 $query = query
(@where);
674 Generate a function that will run a series of tests on a passed hashref
and return true
or false depending on
675 if the data record
in the hash matched the specified logic
.
677 The logic can be specified
in a manner similar to L
<SQL
::Abstract
/"WHERE CLAUSES"> which was the inspiration
678 for this function
, but this code
is distinct
, supporting an overlapping but
not identical feature set
and
681 See L
<File
::KDBX
/QUERY
> for examples
.
685 sub query
{ _query
(undef, '-or', \
@_) }
689 $size = read_all
($fh, my $buffer, $size);
690 $size = read_all
($fh, my $buffer, $size, $offset);
692 Like L
<functions
/read> but returns C
<undef> if not all C
<$size> bytes are
read. This
is considered an error
,
693 distinguishable from other errors by C
<$!> not being set
.
697 sub read_all
($$$;$) { ## no critic (ProhibitSubroutinePrototypes)
698 my $result = @_ == 3 ? read($_[0], $_[1], $_[2])
699 : read($_[0], $_[1], $_[2], $_[3]);
700 return if !defined $result;
701 return if $result != $_[2];
707 \
&limited_code
= recurse_limit
(\
&code
);
708 \
&limited_code
= recurse_limit
(\
&code
, $max_depth);
709 \
&limited_code
= recurse_limit
(\
&code
, $max_depth, \
&error_handler
);
711 Wrap a function with a guard to prevent deep recursion
.
717 my $max_depth = shift // 200;
718 my $error = shift // sub {};
720 return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) };
725 # Generate a query on-the-fly:
726 \
@matches = search
(\
@records, @where);
728 # Use a pre-compiled query:
729 $query = query
(@where);
730 \
@matches = search
(\
@records, $query);
732 # Use a simple expression:
733 \
@matches = search
(\
@records, \'query terms
', @fields);
734 \@matches = search(\@records, \'query terms', $operator, @fields);
736 # Use your own subroutine:
737 \
@matches = search
(\
@records, \
&query
);
738 \
@matches = search
(\
@records, sub { $record = shift; ... });
740 Execute a linear search over an array of records using a L
</query
>. A
"record" is usually a hash
.
742 This
is the search engine described with many examples at L
<File
::KDBX
/QUERY
>.
750 if (is_coderef
($query) && !@_) {
753 elsif (is_scalarref
($query)) {
754 $query = simple_expression_query
($$query, @_);
757 $query = query
($query, @_);
761 for my $item (@$list) {
762 push @match, $item if $query->($item);
767 =func simple_expression_query
769 $query = simple_expression_query
($expression, @fields);
770 $query = simple_expression_query
($expression, $operator, @fields);
772 Generate a query
, like L
</query>, to be used with L</search
> but built from a
"simple expression" as
773 L
<described here
|https
://keepass
.info
/help/base
/search
.html
#mode_se>.
775 An expression
is a string with one
or more space-separated terms
. Terms with spaces can be enclosed
in double
776 quotes
. Terms are negated
if they are prefixed with a minus sign
. A record must match every term on at least
777 one of the
given fields
.
781 sub simple_expression_query
{
783 my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~';
785 my $neg_op = $OP_NEG{$op};
786 my $is_re = $op eq '=~' || $op eq '!~';
788 require Text
::ParseWords
;
789 my @terms = Text
::ParseWords
::shellwords
($expr);
791 my @query = qw(-and);
793 for my $term (@terms) {
794 my @subquery = qw(-or);
796 my $neg = $term =~ s/^-//;
797 my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)];
800 push @subquery, $field => $condition;
803 push @query, \
@subquery;
806 return query
(\
@query);
811 $string = snakify
($string);
813 Turn a CamelCase string into snake_case
.
819 s/UserName/Username/g;
820 s/([a-z])([A-Z0-9])/${1}_${2}/g;
821 s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g;
827 ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url
($url);
829 Split a URL into its parts
.
831 For example
, C
<http
://user
:pass
@localhost:4000/path
?query
#hash> gets split like:
848 my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m
!
858 $scheme = lc($scheme);
860 $host ||= 'localhost';
863 $path = "/$path" if $path !~ m
!^/!;
865 $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef;
867 my ($username, $password) = split($auth, ':', 2);
869 return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
884 Various typecasting
/ coercive functions
.
888 sub to_bool
{ $_[0] // return; boolean
($_[0]) }
889 sub to_number
{ $_[0] // return; 0+$_[0] }
890 sub to_string
{ $_[0] // return; "$_[0]" }
893 return gmtime($_[0]) if looks_like_number
($_[0]);
894 return Time
::Piece-
>strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed
$_[0];
897 sub to_tristate
{ $_[0] // return; boolean
($_[0]) }
899 my $str = to_string
(@_) // return;
900 return sprintf('%016s', $str) if length($str) < 16;
901 return substr($str, 0, 16) if 16 < length($str);
907 $string = trim
($string);
909 The ubiquitous C
<trim
> function
. Removes all whitespace from both ends of a string
.
913 sub trim
($) { ## no critic (ProhibitSubroutinePrototypes)
914 local $_ = shift // return;
920 =func try_load_optional
922 $package = try_load_optional
($package);
924 Try to load a module that isn
't required but can provide extra functionality, and return true if successful.
928 sub try_load_optional {
929 for my $module (@_) {
930 eval { load $module };
932 warn $err if 3 <= DEBUG;
939 =func uri_escape_utf8
941 $string = uri_escape_utf8($string);
943 Percent-encode arbitrary text strings, like for a URI.
947 my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
948 sub uri_escape_utf8 {
949 local $_ = shift // return;
950 $_ = encode('UTF-8
', $_);
951 # RFC 3986 section 2.3 unreserved characters
952 s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge;
956 =func uri_unescape_utf8
958 $string = uri_unescape_utf8($string);
960 Inverse of L</uri_escape_utf8>.
964 sub uri_unescape_utf8 {
965 local $_ = shift // return;
966 s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
967 return decode('UTF-8
', $_);
972 $raw_uuid = uuid($string_uuid);
974 Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s
, like
975 C
<12345678-9ABC-DEFG-1234-56789ABCDEFG
>) into a string of exactly
16 octets
.
977 This
is the inverse of L
</format_uuid
>.
982 local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
984 /^[A-Fa-f0-9]{32}$/ or throw
'Must provide a formatted 128-bit UUID';
985 return pack('H32', $_);
991 Get the null UUID
(i
.e
. string of
16 null bytes
).
995 sub UUID_NULL
() { "\0" x
16 }
997 ### --------------------------------------------------------------------------
999 # Determine if an array looks like keypairs from a hash.
1000 sub _looks_like_keypairs
{
1002 return 0 if @$arr % 2 == 1;
1003 for (my $i = 0; $i < @$arr; $i += 2) {
1004 return 0 if is_ref
($arr->[$i]);
1009 sub _is_operand_plain
{
1011 return !(is_hashref
($_) || is_arrayref
($_));
1016 my $subject = shift;
1017 my $op = shift // throw
'Must specify a query operator';
1018 my $operand = shift;
1020 return _query_simple
($op, $subject) if defined $subject && !is_ref
($op) && ($OPS{$subject} || 2) < 2;
1021 return _query_simple
($subject, $op, $operand) if _is_operand_plain
($operand);
1022 return _query_inverse
(_query
($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false';
1023 return _query
($subject, '-and', [%$operand]) if is_hashref
($operand);
1027 my @atoms = @$operand;
1029 if (_looks_like_keypairs
(\
@atoms)) {
1030 my ($atom, $operand) = splice @atoms, 0, 2;
1031 if (my $op_type = $OPS{$atom}) {
1032 if ($op_type == 1 && _is_operand_plain
($operand)) { # unary
1033 push @queries, _query_simple
($operand, $atom);
1036 push @queries, _query
($subject, $atom, $operand);
1039 elsif (!is_ref
($atom)) {
1040 push @queries, _query
($atom, 'eq', $operand);
1044 my $atom = shift @atoms;
1045 if ($OPS{$atom}) { # apply new operator over the rest
1046 push @queries, _query
($subject, $atom, \
@atoms);
1049 else { # apply original operator over this one
1050 push @queries, _query
($subject, $op, $atom);
1055 if (@queries == 1) {
1058 elsif ($op eq '-and') {
1059 return _query_all
(@queries);
1061 elsif ($op eq '-or') {
1062 return _query_any
(@queries);
1064 throw
'Malformed query';
1068 my $subject = shift;
1069 my $op = shift // 'eq';
1070 my $operand = shift;
1072 # these special operators can also act as simple operators
1073 $op = '!!' if $op eq '-true';
1074 $op = '!' if $op eq '-false';
1075 $op = '!' if $op eq '-not';
1077 defined $subject or throw
'Subject is not set in query';
1078 $OPS{$op} >= 0 or throw
'Cannot use a non-simple operator in a simple query';
1079 if (empty
($operand)) {
1080 if ($OPS{$op} < 2) {
1083 # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing.
1084 elsif ($op eq 'eq' || $op eq '==') {
1087 elsif ($op eq 'ne' || $op eq '!=') {
1091 throw
'Operand is required';
1095 my $field = sub { blessed
$_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} };
1098 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand },
1099 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand },
1100 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand },
1101 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand },
1102 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand },
1103 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand },
1104 '==' => sub { local $_ = $field->(@_); defined && $_ == $operand },
1105 '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand },
1106 '<' => sub { local $_ = $field->(@_); defined && $_ < $operand },
1107 '>' => sub { local $_ = $field->(@_); defined && $_ > $operand },
1108 '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand },
1109 '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand },
1110 '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand },
1111 '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand },
1112 '!' => sub { local $_ = $field->(@_); ! $_ },
1113 '!!' => sub { local $_ = $field->(@_); !!$_ },
1114 '-defined' => sub { local $_ = $field->(@_); defined $_ },
1115 '-undef' => sub { local $_ = $field->(@_); !defined $_ },
1116 '-nonempty' => sub { local $_ = $field->(@_); nonempty
$_ },
1117 '-empty' => sub { local $_ = $field->(@_); empty
$_ },
1120 return $map{$op} // throw
"Unexpected operator in query: $op",
1121 subject
=> $subject,
1123 operand
=> $operand;
1126 sub _query_inverse
{
1128 return sub { !$query->(@_) };
1135 all
{ $_->($val) } @queries;
1143 any
{ $_->($val) } @queries;