1 package File
::KDBX
::Util
;
2 # ABSTRACT: Utility functions for working with KDBX files
8 use Crypt
::PRNG
qw(random_bytes random_string);
9 use Encode
qw(decode encode);
10 use Exporter
qw(import);
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)],
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 int => [qw(int64 pack_ql pack_Ql unpack_ql unpack_Ql)],
36 load
=> [qw(load_optional load_xs try_load_optional)],
37 search
=> [qw(query query_any search simple_expression_query)],
38 text
=> [qw(snakify trim)],
39 uuid
=> [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],
40 uri
=> [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
43 $EXPORT_TAGS{all
} = [map { @$_ } values %EXPORT_TAGS];
44 our @EXPORT_OK = @{$EXPORT_TAGS{all
}};
47 my $debug = $ENV{DEBUG
};
48 $debug = looks_like_number
($debug) ? (0 + $debug) : ($debug ? 1 : 0);
49 *DEBUG
= $debug == 1 ? sub() { 1 } :
50 $debug == 2 ? sub() { 2 } :
51 $debug == 3 ? sub() { 3 } :
52 $debug == 4 ? sub() { 4 } : sub() { 0 };
72 '-not' => 1, # special
103 $bool = load_xs
($version);
105 Attempt to load L
<File
::KDBX
::XS
>. Return truthy
if it
is loaded
. If C
<$version> is given, it will check that
106 at least the
given version
is loaded
.
114 goto IS_LOADED
if defined $XS_LOADED;
116 if ($ENV{PERL_ONLY
} || (exists $ENV{PERL_FILE_KDBX_XS
} && !$ENV{PERL_FILE_KDBX_XS
})) {
117 return $XS_LOADED = !1;
120 $XS_LOADED = !!eval { require File
::KDBX
::XS
; 1 };
125 return $XS_LOADED if !$version;
126 return !!eval { File
::KDBX
::XS-
>VERSION($version); 1 };
134 Write an executable comment
. Only executed
if C
<DEBUG
> is set
in the environment
.
138 sub assert
(&) { ## no critic (ProhibitSubroutinePrototypes)
143 (undef, my $file, my $line) = caller;
144 $file =~ s!([^/\\]+)$!$1!;
146 if (try_load_optional
('B::Deparse')) {
147 my $deparse = B
::Deparse-
>new(qw{-P -x9});
148 $assertion = $deparse->coderef2text($code);
149 $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s;
150 $assertion =~ s/\s+/ /gs;
151 $assertion = ": $assertion";
153 die "$0: $file:$line: Assertion failed$assertion\n";
160 Determine
if perl can
fork, with logic lifted from L
<Test2
::Util
/CAN_FORK
>.
166 return 1 if $Config::Config
{d_fork
};
167 return 0 if $^O ne 'MSWin32' && $^O ne 'NetWare';
168 return 0 if !$Config::Config
{useithreads
};
169 return 0 if $Config::Config
{ccflags
} !~ /-DPERL_IMPLICIT_SYS/;
170 return 0 if $] < 5.008001;
171 if ($] == 5.010000 && $Config::Config
{ccname
} eq 'gcc' && $Config::Config
{gccversion
}) {
172 return 0 if $Config::Config
{gccversion
} !~ m/^(\d+)\.(\d+)/;
173 my @parts = split(/[\.\s]+/, $Config::Config
{gccversion
});
174 return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
176 return 0 if $INC{'Devel/Cover.pm'};
182 $clone = clone
($thing);
184 Clone deeply
. This
is an unadorned alias to L
<Storable
> C
<dclone
>.
190 goto &Storable
::dclone
;
195 $clone = clone_nomagic
($thing);
197 Clone deeply without keeping
[most of
] the magic
.
199 B
<WARNING
:> At the moment the implementation
is naïve
and won
't respond well to nontrivial data or recursive
206 if (is_arrayref($thing)) {
207 my @arr = map { clone_nomagic($_) } @$thing;
210 elsif (is_hashref($thing)) {
212 $hash{$_} = clone_nomagic($thing->{$_}) for keys %$thing;
215 elsif (is_ref($thing)) {
216 return clone($thing);
223 Constant number indicating the level of debuggingness.
227 $str = dumper $thing;
228 dumper $thing; # in void context, prints to STDERR
230 Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>.
235 require Data::Dumper;
236 # avoid "once" warnings
237 local $Data::Dumper::Deepcopy = $Data::Dumper::Deepcopy = 1;
238 local $Data::Dumper::Deparse = $Data::Dumper::Deparse = 1;
239 local $Data::Dumper::Indent = 1;
240 local $Data::Dumper::Quotekeys = 0;
241 local $Data::Dumper::Sortkeys = 1;
242 local $Data::Dumper::Terse = 1;
243 local $Data::Dumper::Trailingcomma = 1;
244 local $Data::Dumper::Useqq = 1;
247 for my $struct (@_) {
248 my $str = Data::Dumper::Dumper($struct);
251 $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
253 $str =~ s/bless\([^\)]+?(\d+)'?,\s
+\d
+,?\s
+\
], 'Time::Piece' \
),/
254 "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges
;
256 print STDERR
$str if !defined wantarray;
260 return join("\n", @dumps);
267 $bool = empty
$thing;
269 $bool = nonempty
$thing;
271 Test whether a thing
is empty
(or nonempty
). An empty thing
is one of these
:
278 * hash with zero keys
279 * reference to an empty thing (recursive)
281 Note in particular that zero C<0> is not considered empty because it is an actual value.
285 sub empty
{ _empty
(@_) }
286 sub nonempty
{ !_empty
(@_) }
293 || (is_arrayref
($_) && @$_ == 0)
294 || (is_hashref
($_) && keys %$_ == 0)
295 || (is_scalarref
($_) && (!defined $$_ || $$_ eq ''))
296 || (is_refref
($_) && _empty
($$_));
302 erase
(\
$string, ...);
304 Overwrite the memory used by one
or more string
.
310 *_CowREFCNT
= \
&File
::KDBX
::XS
::CowREFCNT
;
312 elsif (eval { require B
::COW
; 1 }) {
313 *_CowREFCNT
= \
&B
::COW
::cowrefcnt
;
316 *_CowREFCNT
= sub { undef };
321 # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
322 # creating a copy and erasing the copy.
323 # TODO - Is this worth doing? Need some benchmarking.
326 next if !defined $_ || readonly
$_;
327 my $cowrefcnt = _CowREFCNT
($_);
328 goto FREE_NONREF
if defined $cowrefcnt && 1 < $cowrefcnt;
329 # if (__PACKAGE__->can('erase_xs')) {
333 substr($_, 0, length($_), "\0" x
length($_));
336 no warnings
'uninitialized';
340 elsif (is_scalarref
($_)) {
341 next if !defined $$_ || readonly
$$_;
342 my $cowrefcnt = _CowREFCNT
($$_);
343 goto FREE_REF
if defined $cowrefcnt && 1 < $cowrefcnt;
344 # if (__PACKAGE__->can('erase_xs')) {
348 substr($$_, 0, length($$_), "\0" x
length($$_));
351 no warnings
'uninitialized';
355 elsif (is_arrayref
($_)) {
359 elsif (is_hashref
($_)) {
364 throw
'Cannot erase this type of scalar', type
=> ref $_, what
=> $_;
371 $scope_guard = erase_scoped
($string, ...);
372 $scope_guard = erase_scoped
(\
$string, ...);
373 undef $scope_guard; # erase happens here
375 Get a scope guard that will cause scalars to be erased later
(i
.e
. when the scope ends
). This
is useful
if you
376 want to make sure a string gets erased after you
're done with it, even if the scope ends abnormally.
383 throw 'Programmer error
: Cannot call erase_scoped
in void context
' if !defined wantarray;
386 !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
387 or throw 'Cannot erase this type of
scalar', type => ref $_, what => $_;
388 push @args, is_ref($_) ? $_ : \$_;
390 require Scope::Guard;
391 return Scope::Guard->new(sub { erase(@args) });
398 Set up the current module to inheret from another module.
406 no strict 'refs
'; ## no critic (ProhibitNoStrict)
407 @{"${caller}::ISA"} = $parent;
412 has $name => %options;
414 Create an attribute getter/setter. Possible options:
417 * C<is> - Either "rw" (default) or "ro"
418 * C<default> - Default value
419 * C<coerce> - Coercive function
425 my %args = @_ % 2 == 1 ? (default => shift, @_) : @_;
427 my ($package, $file, $line) = caller;
429 my $d = $args{default};
430 my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
431 my $coerce = $args{coerce};
432 my $is = $args{is} || 'rw';
434 my $store = $args{store};
435 ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
437 my @path = split(/\./, $args{path} || '');
438 my $last = pop @path;
439 my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}}
440 : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}};
441 my $member = qq{\$_[0]$path};
444 my $default_code = is_coderef
$default ? q{scalar $default->($_[0])}
445 : defined $default ? q{$default}
447 my $get = qq{$member //= $default_code;};
451 $set = is_coderef
$coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;}
452 : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \
$#_;}
453 : qq{$member = \$_[1] if \$#_;};
456 push @{$ATTRIBUTES{$package} //= []}, $name;
460 sub ${package}::${name} {
461 return $default_code if !Scalar::Util::blessed(\$_[0]);
466 eval $code; ## no critic (ProhibitStringyEval)
471 $string_uuid = format_uuid
($raw_uuid);
472 $string_uuid = format_uuid
($raw_uuid, $delimiter);
474 Format a
128-bit UUID
(given as a string of
16 octets
) into a hexidecimal string
, optionally with a delimiter
475 to
break up the UUID visually into five parts
. Examples
:
477 my $uuid = uuid
('01234567-89AB-CDEF-0123-456789ABCDEF');
478 say format_uuid
($uuid); # -> 0123456789ABCDEF0123456789ABCDEF
479 say format_uuid
($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF
481 This
is the inverse of L
</uuid
>.
486 local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
487 my $delim = shift // '';
488 length($_) == 16 or throw
'Must provide a 16-bytes UUID', size
=> length($_), str
=> $_;
489 return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_)));
494 $uuid = generate_uuid
;
495 $uuid = generate_uuid
(\
%set);
496 $uuid = generate_uuid
(\
&test_uuid
);
498 Generate a new random UUID
. It
's pretty unlikely that this will generate a repeat, but if you're worried about
499 that you can provide either a set of existing UUIDs
(as a hashref where the
keys are the elements of a set
) or
500 a function to check
for existing UUIDs
, and this will be sure to
not return a UUID already
in provided set
.
501 Perhaps an example will make it clear
:
504 uuid
('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever',
506 $uuid = generate_uuid
(\
%uuid_set);
508 $uuid = generate_uuid
(sub { !$uuid_set{$_} });
510 Here
, C
<$uuid> can
't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack
511 a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example.
516 my $set = @_ % 2 == 1 ? shift : undef;
518 my $test = $set //= $args{test};
519 $test = sub { !$set->{$_} } if is_hashref($test);
521 my $printable = $args{printable} // $args{print};
524 $_ = $printable ? random_string(16) : random_bytes(16);
525 } while (!$test->($_));
531 $unzipped = gunzip($string);
533 Decompress an octet stream.
538 load_optional('Compress
::Raw
::Zlib
');
540 my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
541 $status == Compress::Raw::Zlib::Z_OK()
542 or throw 'Failed to initialize compression library
', status => $status;
543 $status = $i->inflate($_, my $out);
544 $status == Compress::Raw::Zlib::Z_STREAM_END()
545 or throw 'Failed to decompress data
', status => $status;
551 $zipped = gzip($string);
553 Compress an octet stream.
558 load_optional('Compress
::Raw
::Zlib
');
560 my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
561 $status == Compress::Raw::Zlib::Z_OK()
562 or throw 'Failed to initialize compression library
', status => $status;
563 $status = $d->deflate($_, my $out);
564 $status == Compress::Raw::Zlib::Z_OK()
565 or throw 'Failed to compress data
', status => $status;
566 $status = $d->flush($out);
567 $status == Compress::Raw::Zlib::Z_OK()
568 or throw 'Failed to compress data
', status => $status;
574 $int = int64($string);
576 Get a scalar integer capable of holding 64-bit values, initialized with a given default value. On a 64-bit
577 perl, it will return a regular SvIV. On a 32-bit perl it will return a L<Math::BigInt>.
583 if ($Config::Config{ivsize} < 8) {
584 require Math::BigInt;
585 return Math::BigInt->new(@_);
592 $bytes = pack_Ql($int);
594 Like C<pack('QE
<lt>', $int)>, but also works on 32-bit perls.
601 if ($Config::Config{ivsize} < 8) {
602 if (blessed $num && $num->can('as_hex
')) {
603 return "\xff\xff\xff\xff\xff\xff\xff\xff" if Math::BigInt->new('18446744073709551615') <= $num;
604 return "\x00\x00\x00\x00\x00\x00\x00\x80" if $num <= Math::BigInt->new('-9223372036854775808');
610 my $hex = $num->as_hex;
611 $hex =~ s/^0x/000000000000000/;
612 my $bytes = reverse pack('H16
', substr($hex, -16));
613 $bytes .= "\0" x (8 - length $bytes) if length $bytes < 8;
616 $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes));
617 substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) + 1));
622 my $pad = $num < 0 ? "\xff" : "\0";
623 return pack('L<', $num) . ($pad x
4);
626 return pack('Q<', $num);
631 $bytes = pack_ql
($int);
633 Like C
<pack('qE<lt>', $int)>, but also works on
32-bit perls
.
637 sub pack_ql
{ goto &pack_Ql
}
641 $int = unpack_Ql
($bytes);
643 Like C
<unpack('QE<lt>', $bytes)>, but also works on
32-bit perls
.
650 if ($Config::Config
{ivsize
} < 8) {
651 require Math
::BigInt
;
652 return Math
::BigInt-
>new('0x' . unpack('H*', scalar reverse $bytes));
654 return unpack('Q<', $bytes);
659 $int = unpack_ql
($bytes);
661 Like C
<unpack('qE<lt>', $bytes)>, but also works on
32-bit perls
.
668 if ($Config::Config
{ivsize
} < 8) {
669 require Math
::BigInt
;
670 if (ord(substr($bytes, -1, 1)) & 128) {
671 return Math
::BigInt-
>new('-9223372036854775808') if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x80";
673 substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) - 1));
674 $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes));
675 return -Math
::BigInt-
>new('0x' . unpack('H*', scalar reverse $bytes));
678 return Math
::BigInt-
>new('0x' . unpack('H*', scalar reverse $bytes));
681 return unpack('q<', $bytes);
686 $bool = is_uuid
($thing);
688 Check
if a thing
is a UUID
(i
.e
. scalar string of
length 16).
692 sub is_uuid
{ defined $_[0] && !is_ref
($_[0]) && length($_[0]) == 16 }
694 =func list_attributes
696 @attributes = list_attributes
($package);
698 Get a list of attributes
for a
class.
702 sub list_attributes
{
704 return @{$ATTRIBUTES{$package} // []};
709 $package = load_optional
($package);
711 Load a module that isn
't required but can provide extra functionality. Throw if the module is not available.
716 for my $module (@_) {
717 eval { load $module };
719 throw "Missing dependency: Please install $module to use this feature.\n",
724 return wantarray ? @_ : $_[0];
729 \&memoized_code = memoize(\&code, ...);
731 Memoize a function. Extra arguments are passed through to C<&code> when it is called.
739 return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) };
744 $padded_string = pad_pkcs7($string, $block_size),
746 Pad a block using the PKCS#7 method.
751 my $data = shift // throw 'Must provide a string to pad
';
752 my $size = shift or throw 'Must provide block size
';
754 0 <= $size && $size < 256
755 or throw 'Cannot add PKCS7 padding to a large block size
', size => $size;
757 my $pad_len = $size - length($data) % $size;
758 $data .= chr($pad_len) x $pad_len;
763 $query = query(@where);
766 Generate a function that will run a series of tests on a passed hashref and return true or false depending on
767 if the data record in the hash matched the specified logic.
769 The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration
770 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
773 See L<File::KDBX/"Declarative Syntax"> for examples.
777 sub query { _query(undef, '-or', \@_) }
781 Get either a L</query> or L</simple_expression_query>, depending on the arguments.
788 if (is_coderef($code) || overload::Method($code, '&{}')) {
791 elsif (is_scalarref($code)) {
792 return simple_expression_query($$code, @_);
795 return query($code, @_);
801 $size = read_all($fh, my $buffer, $size);
802 $size = read_all($fh, my $buffer, $size, $offset);
804 Like L<perlfunc/"read FILEHANDLE,SCALAR,LENGTH,OFFSET"> but returns C<undef> if not all C<$size> bytes are
805 read. This is considered an error, distinguishable from other errors by C<$!> not being set.
809 sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes)
810 my $result = @_ == 3 ? read($_[0], $_[1], $_[2])
811 : read($_[0], $_[1], $_[2], $_[3]);
812 return if !defined $result;
813 return if $result != $_[2];
819 \&limited_code = recurse_limit(\&code);
820 \&limited_code = recurse_limit(\&code, $max_depth);
821 \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler);
823 Wrap a function with a guard to prevent deep recursion.
829 my $max_depth = shift // 200;
830 my $error = shift // sub {};
832 return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) };
837 # Generate a query on-the-fly:
838 \@matches = search(\@records, @where);
840 # Use a pre-compiled query:
841 $query = query(@where);
842 \@matches = search(\@records, $query);
844 # Use a simple expression:
845 \@matches = search(\@records, \'query terms', @fields);
846 \
@matches = search
(\
@records, \'query terms
', $operator, @fields);
848 # Use your own subroutine:
849 \@matches = search(\@records, \&query);
850 \@matches = search(\@records, sub { $record = shift; ... });
852 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
858 my $query = query_any(@_);
861 for my $item (@$list) {
862 push @match, $item if $query->($item);
867 =func simple_expression_query
869 $query = simple_expression_query($expression, @fields);
870 $query = simple_expression_query($expression, $operator, @fields);
872 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
873 L<described here|https://keepass.info/help/base/search.html#mode_se>.
875 An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
876 quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
877 one of the given fields.
881 sub simple_expression_query {
883 my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~';
885 my $neg_op = $OP_NEG{$op};
886 my $is_re = $op eq '=~' || $op eq '!~';
888 require Text::ParseWords;
889 my @terms = Text::ParseWords::shellwords($expr);
891 my @query = qw(-and);
893 for my $term (@terms) {
894 my @subquery = qw(-or);
896 my $neg = $term =~ s/^-//;
897 my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)];
900 push @subquery, $field => $condition;
903 push @query, \
@subquery;
906 return query
(\
@query);
911 $string = snakify
($string);
913 Turn a CamelCase string into snake_case
.
919 s/UserName/Username/g;
920 s/([a-z])([A-Z0-9])/${1}_${2}/g;
921 s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g;
927 ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url
($url);
929 Split a URL into its parts
.
931 For example
, C
<http
://user
:pass
@localhost:4000/path
?query
#hash> gets split like:
948 my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m
!
958 $scheme = lc($scheme);
960 $host ||= 'localhost';
963 $path = "/$path" if $path !~ m
!^/!;
965 $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef;
967 my ($username, $password) = split($auth, ':', 2);
969 return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
984 Various typecasting
/ coercive functions
.
988 sub to_bool
{ $_[0] // return; boolean
($_[0]) }
989 sub to_number
{ $_[0] // return; 0+$_[0] }
990 sub to_string
{ $_[0] // return; "$_[0]" }
993 return scalar gmtime($_[0]) if looks_like_number
($_[0]);
994 return scalar gmtime if $_[0] eq 'now';
995 return Time
::Piece-
>strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed
$_[0];
998 sub to_tristate
{ $_[0] // return; boolean
($_[0]) }
1000 my $str = to_string
(@_) // return;
1001 return sprintf('%016s', $str) if length($str) < 16;
1002 return substr($str, 0, 16) if 16 < length($str);
1008 $string = trim
($string);
1010 The ubiquitous C
<trim
> function
. Removes all whitespace from both ends of a string
.
1014 sub trim
($) { ## no critic (ProhibitSubroutinePrototypes)
1015 local $_ = shift // return;
1021 =func try_load_optional
1023 $package = try_load_optional
($package);
1025 Try to load a module that isn
't required but can provide extra functionality, and return true if successful.
1029 sub try_load_optional {
1030 for my $module (@_) {
1031 eval { load $module };
1033 warn $err if 3 <= DEBUG;
1040 =func uri_escape_utf8
1042 $string = uri_escape_utf8($string);
1044 Percent-encode arbitrary text strings, like for a URI.
1048 my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
1049 sub uri_escape_utf8 {
1050 local $_ = shift // return;
1051 $_ = encode('UTF-8
', $_);
1052 # RFC 3986 section 2.3 unreserved characters
1053 s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge;
1057 =func uri_unescape_utf8
1059 $string = uri_unescape_utf8($string);
1061 Inverse of L</uri_escape_utf8>.
1065 sub uri_unescape_utf8 {
1066 local $_ = shift // return;
1067 s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
1068 return decode('UTF-8
', $_);
1073 $raw_uuid = uuid($string_uuid);
1075 Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s
, like
1076 C
<12345678-9ABC-DEFG-1234-56789ABCDEFG
>) into a string of exactly
16 octets
.
1078 This
is the inverse of L
</format_uuid
>.
1083 local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
1085 /^[A-Fa-f0-9]{32}$/ or throw
'Must provide a formatted 128-bit UUID';
1086 return pack('H32', $_);
1092 Get the null UUID
(i
.e
. string of
16 null bytes
).
1096 sub UUID_NULL
() { "\0" x
16 }
1098 ### --------------------------------------------------------------------------
1100 # Determine if an array looks like keypairs from a hash.
1101 sub _looks_like_keypairs
{
1103 return 0 if @$arr % 2 == 1;
1104 for (my $i = 0; $i < @$arr; $i += 2) {
1105 return 0 if is_ref
($arr->[$i]);
1110 sub _is_operand_plain
{
1112 return !(is_hashref
($_) || is_arrayref
($_));
1117 my $subject = shift;
1118 my $op = shift // throw
'Must specify a query operator';
1119 my $operand = shift;
1121 return _query_simple
($op, $subject) if defined $subject && !is_ref
($op) && ($OPS{$subject} || 2) < 2;
1122 return _query_simple
($subject, $op, $operand) if _is_operand_plain
($operand);
1123 return _query_inverse
(_query
($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false';
1124 return _query
($subject, '-and', [%$operand]) if is_hashref
($operand);
1128 my @atoms = @$operand;
1130 if (_looks_like_keypairs
(\
@atoms)) {
1131 my ($atom, $operand) = splice @atoms, 0, 2;
1132 if (my $op_type = $OPS{$atom}) {
1133 if ($op_type == 1 && _is_operand_plain
($operand)) { # unary
1134 push @queries, _query_simple
($operand, $atom);
1137 push @queries, _query
($subject, $atom, $operand);
1140 elsif (!is_ref
($atom)) {
1141 push @queries, _query
($atom, 'eq', $operand);
1145 my $atom = shift @atoms;
1146 if ($OPS{$atom}) { # apply new operator over the rest
1147 push @queries, _query
($subject, $atom, \
@atoms);
1150 else { # apply original operator over this one
1151 push @queries, _query
($subject, $op, $atom);
1156 if (@queries == 1) {
1159 elsif ($op eq '-and') {
1160 return _query_all
(@queries);
1162 elsif ($op eq '-or') {
1163 return _query_any
(@queries);
1165 throw
'Malformed query';
1169 my $subject = shift;
1170 my $op = shift // 'eq';
1171 my $operand = shift;
1173 # these special operators can also act as simple operators
1174 $op = '!!' if $op eq '-true';
1175 $op = '!' if $op eq '-false';
1176 $op = '!' if $op eq '-not';
1178 defined $subject or throw
'Subject is not set in query';
1179 $OPS{$op} >= 0 or throw
'Cannot use a non-simple operator in a simple query';
1180 if (empty
($operand)) {
1181 if ($OPS{$op} < 2) {
1184 # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing.
1185 elsif ($op eq 'eq' || $op eq '==') {
1188 elsif ($op eq 'ne' || $op eq '!=') {
1192 throw
'Operand is required';
1196 my $field = sub { blessed
$_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} };
1199 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand },
1200 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand },
1201 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand },
1202 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand },
1203 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand },
1204 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand },
1205 '==' => sub { local $_ = $field->(@_); defined && $_ == $operand },
1206 '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand },
1207 '<' => sub { local $_ = $field->(@_); defined && $_ < $operand },
1208 '>' => sub { local $_ = $field->(@_); defined && $_ > $operand },
1209 '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand },
1210 '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand },
1211 '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand },
1212 '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand },
1213 '!' => sub { local $_ = $field->(@_); ! $_ },
1214 '!!' => sub { local $_ = $field->(@_); !!$_ },
1215 '-defined' => sub { local $_ = $field->(@_); defined $_ },
1216 '-undef' => sub { local $_ = $field->(@_); !defined $_ },
1217 '-nonempty' => sub { local $_ = $field->(@_); nonempty
$_ },
1218 '-empty' => sub { local $_ = $field->(@_); empty
$_ },
1221 return $map{$op} // throw
"Unexpected operator in query: $op",
1222 subject
=> $subject,
1224 operand
=> $operand;
1227 sub _query_inverse
{
1229 return sub { !$query->(@_) };
1236 all
{ $_->($val) } @queries;
1244 any
{ $_->($val) } @queries;