Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Util.pm

   1 package File::KDBX::Util;
   2 # ABSTRACT: Utility functions for working with KDBX files
   3
   4 use warnings;
   5 use strict;
   6
   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);
  13 use Module::Load;
  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);
  16 use Time::Piece;
  17 use boolean;
  18 use namespace::clean -except => 'import';
  19
  20 our $VERSION = '999.999'; # VERSION
  21
  22 our %EXPORT_TAGS = (
  23     assert      => [qw(assert_64bit)],
  24     class       => [qw(extends has)],
  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(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 search_limited simple_expression_query)],
  37     text        => [qw(snakify trim)],
  38     uuid        => [qw(format_uuid generate_uuid is_uuid uuid)],
  39     uri         => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
  40 );
  41
  42 $EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
  43 our @EXPORT_OK = @{$EXPORT_TAGS{all}};
  44
  45 my %OPS = (
  46     'eq'        =>  2, # binary
  47     'ne'        =>  2,
  48     'lt'        =>  2,
  49     'gt'        =>  2,
  50     'le'        =>  2,
  51     'ge'        =>  2,
  52     '=='        =>  2,
  53     '!='        =>  2,
  54     '<'         =>  2,
  55     '>'         =>  2,
  56     '<='        =>  2,
  57     '>='        =>  2,
  58     '=~'        =>  2,
  59     '!~'        =>  2,
  60     '!'         =>  1, # unary
  61     '!!'        =>  1,
  62     '-not'      =>  1, # special
  63     '-false'    =>  1,
  64     '-true'     =>  1,
  65     '-defined'  =>  1,
  66     '-undef'    =>  1,
  67     '-empty'    =>  1,
  68     '-nonempty' =>  1,
  69     '-or'       => -1,
  70     '-and'      => -1,
  71 );
  72 my %OP_NEG = (
  73     'eq'    =>  'ne',
  74     'ne'    =>  'eq',
  75     'lt'    =>  'ge',
  76     'gt'    =>  'le',
  77     'le'    =>  'gt',
  78     'ge'    =>  'lt',
  79     '=='    =>  '!=',
  80     '!='    =>  '==',
  81     '<'     =>  '>=',
  82     '>'     =>  '<=',
  83     '<='    =>  '>',
  84     '>='    =>  '<',
  85     '=~'    =>  '!~',
  86     '!~'    =>  '=~',
  87 );
  88
  89 =func load_xs
  90
  91     $bool = load_xs();
  92     $bool = load_xs($version);
  93
  94 Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> is loaded. If C<$version> is given, it will check
  95 that at least the given version is loaded.
  96
  97 =cut
  98
  99 my $XS_LOADED;
 100 sub load_xs {
 101     my $version = shift;
 102
 103     goto IS_LOADED if defined $XS_LOADED;
 104
 105     if ($ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS})) {
 106         return $XS_LOADED = FALSE;
 107     }
 108
 109     $XS_LOADED = !!eval { require File::KDBX::XS; 1 };
 110
 111     IS_LOADED:
 112     {
 113         local $@;
 114         return $XS_LOADED if !$version;
 115         return !!eval { File::KDBX::XS->VERSION($version); 1 };
 116     }
 117 }
 118
 119 =func assert_64bit
 120
 121     assert_64bit();
 122
 123 Throw if perl doesn't support 64-bit IVs.
 124
 125 =cut
 126
 127 sub assert_64bit() {
 128     require Config;
 129     $Config::Config{ivsize} < 8
 130         and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize};
 131 }
 132
 133 =func can_fork
 134
 135     $bool = can_fork;
 136
 137 Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>.
 138
 139 =cut
 140
 141 sub can_fork {
 142     require Config;
 143     return 1 if $Config::Config{d_fork};
 144     return 0 if $^O ne 'MSWin32' && $^O ne 'NetWare';
 145     return 0 if !$Config::Config{useithreads};
 146     return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/;
 147     return 0 if $] < 5.008001;
 148     if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc' && $Config::Config{gccversion}) {
 149         return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/;
 150         my @parts = split(/[\.\s]+/, $Config::Config{gccversion});
 151         return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
 152     }
 153     return 0 if $INC{'Devel/Cover.pm'};
 154     return 1;
 155 }
 156
 157 =func clone
 158
 159     $clone = clone($thing);
 160
 161 Clone deeply. This is an unadorned alias to L<Storable> C<dclone>.
 162
 163 =cut
 164
 165 sub clone {
 166     require Storable;
 167     goto &Storable::dclone;
 168 }
 169
 170 =func clone_nomagic
 171
 172     $clone = clone_nomagic($thing);
 173
 174 Clone deeply without keeping [most of] the magic.
 175
 176 B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data or recursive
 177 structures.
 178
 179 =cut
 180
 181 sub clone_nomagic {
 182     my $thing = shift;
 183     if (is_arrayref($thing)) {
 184         my @arr = map { clone_nomagic($_) } @$thing;
 185         return \@arr;
 186     }
 187     elsif (is_hashref($thing)) {
 188         my %hash;
 189         $hash{$_} = clone_nomagic($thing->{$_}) for keys %$thing;
 190         return \%hash;
 191     }
 192     elsif (is_ref($thing)) {
 193         return clone($thing);
 194     }
 195     return $thing;
 196 }
 197
 198 =func dumper
 199
 200     $str = dumper $thing;
 201     dumper $thing;  # in void context, prints to STDERR
 202
 203 Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>.
 204
 205 =cut
 206
 207 sub dumper {
 208     require Data::Dumper;
 209     # avoid "once" warnings
 210     local $Data::Dumper::Deepcopy = $Data::Dumper::Deepcopy = 1;
 211     local $Data::Dumper::Deparse = $Data::Dumper::Deparse = 1;
 212     local $Data::Dumper::Indent = 1;
 213     local $Data::Dumper::Quotekeys = 0;
 214     local $Data::Dumper::Sortkeys = 1;
 215     local $Data::Dumper::Terse = 1;
 216     local $Data::Dumper::Trailingcomma = 1;
 217     local $Data::Dumper::Useqq = 1;
 218
 219     my @dumps;
 220     for my $struct (@_) {
 221         my $str = Data::Dumper::Dumper($struct);
 222
 223         # boolean
 224         $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
 225         # Time::Piece
 226         $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/
 227             "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges;
 228
 229         print STDERR $str if !defined wantarray;
 230         push @dumps, $str;
 231         return $str;
 232     }
 233     return join("\n", @dumps);
 234 }
 235
 236 =func empty
 237
 238 =func nonempty
 239
 240     $bool = empty $thing;
 241
 242     $bool = nonempty $thing;
 243
 244 Test whether a thing is empty (or nonempty). An empty thing is one of these:
 245
 246 =for :list
 247 * nonexistent
 248 * C<undef>
 249 * zero-length string
 250 * zero-length array
 251 * hash with zero keys
 252 * reference to an empty thing (recursive)
 253
 254 Note in particular that zero C<0> is not considered empty because it is an actual value.
 255
 256 =cut
 257
 258 sub empty    {  _empty(@_) }
 259 sub nonempty { !_empty(@_) }
 260
 261 sub _empty {
 262     return 1 if @_ == 0;
 263     local $_ = shift;
 264     return !defined $_
 265         || $_ eq ''
 266         || (is_arrayref($_)  && @$_ == 0)
 267         || (is_hashref($_)   && keys %$_ == 0)
 268         || (is_scalarref($_) && (!defined $$_ || $$_ eq ''))
 269         || (is_refref($_)    && _empty($$_));
 270 }
 271
 272 =func erase
 273
 274     erase($string, ...);
 275     erase(\$string, ...);
 276
 277 Overwrite the memory used by one or more string.
 278
 279 =cut
 280
 281 BEGIN {
 282     if (load_xs) {
 283         *_CowREFCNT = \&File::KDBX::XS::CowREFCNT;
 284     }
 285     elsif (eval { require B::COW; 1 }) {
 286         *_CowREFCNT = \&B::COW::cowrefcnt;
 287     }
 288     else {
 289         *_CowREFCNT = sub { undef };
 290     }
 291 }
 292
 293 sub erase {
 294     # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
 295     # creating a copy and erasing the copy.
 296     # TODO - Is this worth doing? Need some benchmarking.
 297     for (@_) {
 298         if (!is_ref($_)) {
 299             next if !defined $_ || readonly $_;
 300             my $cowrefcnt = _CowREFCNT($_);
 301             goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt;
 302             # if (__PACKAGE__->can('erase_xs')) {
 303             #     erase_xs($_);
 304             # }
 305             # else {
 306                 substr($_, 0, length($_), "\0" x length($_));
 307             # }
 308             FREE_NONREF: {
 309                 no warnings 'uninitialized';
 310                 undef $_;
 311             }
 312         }
 313         elsif (is_scalarref($_)) {
 314             next if !defined $$_ || readonly $$_;
 315             my $cowrefcnt = _CowREFCNT($$_);
 316             goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt;
 317             # if (__PACKAGE__->can('erase_xs')) {
 318             #     erase_xs($$_);
 319             # }
 320             # else {
 321                 substr($$_, 0, length($$_), "\0" x length($$_));
 322             # }
 323             FREE_REF: {
 324                 no warnings 'uninitialized';
 325                 undef $$_;
 326             }
 327         }
 328         elsif (is_arrayref($_)) {
 329             erase(@$_);
 330             @$_ = ();
 331         }
 332         elsif (is_hashref($_)) {
 333             erase(values %$_);
 334             %$_ = ();
 335         }
 336         else {
 337             throw 'Cannot erase this type of scalar', type => ref $_, what => $_;
 338         }
 339     }
 340 }
 341
 342 =func erase_scoped
 343
 344     $scope_guard = erase_scoped($string, ...);
 345     $scope_guard = erase_scoped(\$string, ...);
 346     undef $scope_guard; # erase happens here
 347
 348 Get a scope guard that will cause scalars to be erased later (i.e. when the scope ends). This is useful if you
 349 want to make sure a string gets erased after you're done with it, even if the scope ends abnormally.
 350
 351 See L</erase>.
 352
 353 =cut
 354
 355 sub erase_scoped {
 356     throw 'Programmer error: Cannot call erase_scoped in void context' if !defined wantarray;
 357     my @args;
 358     for (@_) {
 359         !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
 360             or throw 'Cannot erase this type of scalar', type => ref $_, what => $_;
 361         push @args, is_ref($_) ? $_ : \$_;
 362     }
 363     require Scope::Guard;
 364     return Scope::Guard->new(sub { erase(@args) });
 365 }
 366
 367 =func extends
 368
 369     extends $class;
 370
 371 Set up the current module to inheret from another module.
 372
 373 =cut
 374
 375 sub extends {
 376     my $parent  = shift;
 377     my $caller  = caller;
 378     load $parent;
 379     no strict 'refs'; ## no critic (ProhibitNoStrict)
 380     @{"${caller}::ISA"} = $parent;
 381 }
 382
 383 =func has
 384
 385     has $name => %options;
 386
 387 Create an attribute getter/setter. Possible options:
 388
 389 =for :list
 390 * C<is> - Either "rw" (default) or "ro"
 391 * C<default> - Default value
 392 * C<coerce> - Coercive function
 393
 394 =cut
 395
 396 sub has {
 397     my $name = shift;
 398     my %args = @_ % 2 == 1 ? (default => shift, @_) : @_;
 399
 400     my $d = $args{default};
 401     my $default = is_arrayref($d) ? sub { [%$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
 402     my $coerce  = $args{coerce};
 403     my $is      = $args{is} || 'rw';
 404
 405     my $has_default = is_coderef $default;
 406     my $has_coerce  = is_coderef $coerce;
 407
 408     my $caller = caller;
 409     no strict 'refs'; ## no critic (ProhibitNoStrict)
 410     if (my $store = $args{store}) {
 411         *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
 412             $_[0]->$store->{$name} //= scalar $default->($_[0]);
 413         } : $is eq 'ro' ? sub {
 414             $_[0]->$store->{$name} //= $default;
 415         } : $has_default && $has_coerce ? sub {
 416             $#_ ? $_[0]->$store->{$name} = scalar $coerce->($_[1])
 417                 : $_[0]->$store->{$name} //= scalar $default->($_[0]);
 418         } : $has_default ? sub {
 419             $#_ ? $_[0]->$store->{$name} = $_[1]
 420                 : $_[0]->$store->{$name} //= scalar $default->($_[0]);
 421         } : $has_coerce ? sub {
 422             $#_ ? $_[0]->$store->{$name} = scalar $coerce->($_[1])
 423                 : $_[0]->$store->{$name} //= $default;
 424         } : sub {
 425             $#_ ? $_[0]->$store->{$name} = $_[1]
 426                 : $_[0]->$store->{$name} //= $default;
 427         };
 428     }
 429     else {
 430         *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
 431             $_[0]->{$name} //= scalar $default->($_[0]);
 432         } : $is eq 'ro' ? sub {
 433             $_[0]->{$name} //= $default;
 434         } : $has_default && $has_coerce ? sub {
 435             $#_ ? $_[0]->{$name} = scalar $coerce->($_[1])
 436                 : $_[0]->{$name} //= scalar $default->($_[0]);
 437         } : $has_default ? sub {
 438             $#_ ? $_[0]->{$name} = $_[1]
 439                 : $_[0]->{$name} //= scalar $default->($_[0]);
 440         } : $has_coerce ? sub {
 441             $#_ ? $_[0]->{$name} = scalar $coerce->($_[1])
 442                 : $_[0]->{$name} //= $default;
 443         } : sub {
 444             $#_ ? $_[0]->{$name} = $_[1]
 445                 : ($_[0]->{$name} //= $default);
 446         };
 447     }
 448 }
 449
 450 =func format_uuid
 451
 452     $string_uuid = format_uuid($raw_uuid);
 453     $string_uuid = format_uuid($raw_uuid, $delimiter);
 454
 455 Format a 128-bit UUID (given as a string of 16 octets) into a hexidecimal string, optionally with a delimiter
 456 to break up the UUID visually into five parts. Examples:
 457
 458     my $uuid = uuid('01234567-89AB-CDEF-0123-456789ABCDEF');
 459     say format_uuid($uuid);         # -> 0123456789ABCDEF0123456789ABCDEF
 460     say format_uuid($uuid, '-');    # -> 01234567-89AB-CDEF-0123-456789ABCDEF
 461
 462 This is the inverse of L</uuid>.
 463
 464 =cut
 465
 466 sub format_uuid {
 467     local $_    = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
 468     my $delim   = shift // '';
 469     length($_) == 16 or throw 'Must provide a 16-bytes UUID', size => length($_), str => $_;
 470     return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_)));
 471 }
 472
 473 =func generate_uuid
 474
 475     $uuid = generate_uuid;
 476     $uuid = generate_uuid(\%set);
 477     $uuid = generate_uuid(\&test_uuid);
 478
 479 Generate a new random UUID. It's pretty unlikely that this will generate a repeat, but if you're worried about
 480 that you can provide either a set of existing UUIDs (as a hashref where the keys are the elements of a set) or
 481 a function to check for existing UUIDs, and this will be sure to not return a UUID already in provided set.
 482 Perhaps an example will make it clear:
 483
 484     my %uuid_set = (
 485         uuid('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever',
 486     );
 487     $uuid = generate_uuid(\%uuid_set);
 488     # OR
 489     $uuid = generate_uuid(sub { !$uuid_set{$_} });
 490
 491 Here, C<$uuid> can't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack
 492 a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example.
 493
 494 =cut
 495
 496 sub generate_uuid {
 497     my $set  = @_ % 2 == 1 ? shift : undef;
 498     my %args = @_;
 499     my $test = $set //= $args{test};
 500     $test   = sub { !$set->{$_} } if is_hashref($test);
 501     $test //= sub { 1 };
 502     my $printable = $args{printable} // $args{print};
 503     local $_ = '';
 504     do {
 505         $_ = $printable ? random_string(16) : random_bytes(16);
 506     } while (!$test->($_));
 507     return $_;
 508 }
 509
 510 =func gunzip
 511
 512     $unzipped = gunzip($string);
 513
 514 Decompress an octet stream.
 515
 516 =cut
 517
 518 sub gunzip {
 519     load_optional('Compress::Raw::Zlib');
 520     local $_ = shift;
 521     my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
 522     $status == Compress::Raw::Zlib::Z_OK()
 523         or throw 'Failed to initialize compression library', status => $status;
 524     $status = $i->inflate($_, my $out);
 525     $status == Compress::Raw::Zlib::Z_STREAM_END()
 526         or throw 'Failed to decompress data', status => $status;
 527     return $out;
 528 }
 529
 530 =func gzip
 531
 532     $zipped = gzip($string);
 533
 534 Compress an octet stream.
 535
 536 =cut
 537
 538 sub gzip {
 539     load_optional('Compress::Raw::Zlib');
 540     local $_ = shift;
 541     my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
 542     $status == Compress::Raw::Zlib::Z_OK()
 543         or throw 'Failed to initialize compression library', status => $status;
 544     $status = $d->deflate($_, my $out);
 545     $status == Compress::Raw::Zlib::Z_OK()
 546         or throw 'Failed to compress data', status => $status;
 547     $status = $d->flush($out);
 548     $status == Compress::Raw::Zlib::Z_OK()
 549         or throw 'Failed to compress data', status => $status;
 550     return $out;
 551 }
 552
 553 =func is_readable
 554
 555 =func is_writable
 556
 557     $bool = is_readable($mode);
 558     $bool = is_writable($mode);
 559
 560 Determine of an C<fopen>-style mode is readable, writable or both.
 561
 562 =cut
 563
 564 sub is_readable { $_[0] !~ /^[aw]b?$/ }
 565 sub is_writable { $_[0] !~ /^rb?$/ }
 566
 567 =func is_uuid
 568
 569     $bool = is_uuid($thing);
 570
 571 Check if a thing is a UUID (i.e. scalar string of length 16).
 572
 573 =cut
 574
 575 sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
 576
 577 =func load_optional
 578
 579     $package = load_optional($package);
 580
 581 Load a module that isn't required but can provide extra functionality. Throw if the module is not available.
 582
 583 =cut
 584
 585 sub load_optional {
 586     for my $module (@_) {
 587         eval { load $module };
 588         if (my $err = $@) {
 589             warn $err if $ENV{DEBUG};
 590             throw "Missing dependency: Please install $module to use this feature.\n", module => $module;
 591         }
 592     }
 593     return wantarray ? @_ : $_[0];
 594 }
 595
 596 =func memoize
 597
 598     \&memoized_code = memoize(\&code, ...);
 599
 600 Memoize a function. Extra arguments are passed through to C<&code> when it is called.
 601
 602 =cut
 603
 604 sub memoize {
 605     my $func = shift;
 606     my @args = @_;
 607     my %cache;
 608     return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) };
 609 }
 610
 611 =func pad_pkcs7
 612
 613     $padded_string = pad_pkcs7($string, $block_size),
 614
 615 Pad a block using the PKCS#7 method.
 616
 617 =cut
 618
 619 sub pad_pkcs7 {
 620     my $data = shift // throw 'Must provide a string to pad';
 621     my $size = shift or throw 'Must provide block size';
 622
 623     0 <= $size && $size < 256
 624         or throw 'Cannot add PKCS7 padding to a large block size', size => $size;
 625
 626     my $pad_len = $size - length($data) % $size;
 627     $data .= chr($pad_len) x $pad_len;
 628 }
 629
 630 =func query
 631
 632     $query = query(@where);
 633     $query->(\%data);
 634
 635 Generate a function that will run a series of tests on a passed hashref and return true or false depending on
 636 if the data record in the hash matched the specified logic.
 637
 638 The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration
 639 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
 640 having its own bugs.
 641
 642 See L<File::KDBX/QUERY> for examples.
 643
 644 =cut
 645
 646 sub query { _query(undef, '-or', \@_) }
 647
 648 =func read_all
 649
 650     $size = read_all($fh, my $buffer, $size);
 651     $size = read_all($fh, my $buffer, $size, $offset);
 652
 653 Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
 654 distinguishable from other errors by C<$!> not being set.
 655
 656 =cut
 657
 658 sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes)
 659     my $result = @_ == 3 ? read($_[0], $_[1], $_[2])
 660                          : read($_[0], $_[1], $_[2], $_[3]);
 661     return if !defined $result;
 662     return if $result != $_[2];
 663     return $result;
 664 }
 665
 666 =func recurse_limit
 667
 668     \&limited_code = recurse_limit(\&code);
 669     \&limited_code = recurse_limit(\&code, $max_depth);
 670     \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler);
 671
 672 Wrap a function with a guard to prevent deep recursion.
 673
 674 =cut
 675
 676 sub recurse_limit {
 677     my $func        = shift;
 678     my $max_depth   = shift // 200;
 679     my $error       = shift // sub {};
 680     my $depth = 0;
 681     return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) };
 682 };
 683
 684 =func search
 685
 686     # Generate a query on-the-fly:
 687     \@matches = search(\@records, @where);
 688
 689     # Use a pre-compiled query:
 690     $query = query(@where);
 691     \@matches = search(\@records, $query);
 692
 693     # Use a simple expression:
 694     \@matches = search(\@records, \'query terms', @fields);
 695     \@matches = search(\@records, \'query terms', $operator, @fields);
 696
 697     # Use your own subroutine:
 698     \@matches = search(\@records, \&query);
 699     \@matches = search(\@records, sub { $record = shift; ... });
 700
 701 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
 702
 703 This is the search engine described with many examples at L<File::KDBX/QUERY>.
 704
 705 =cut
 706
 707 sub search {
 708     my $list    = shift;
 709     my $query   = shift;
 710
 711     if (is_coderef($query) && !@_) {
 712         # already a query
 713     }
 714     elsif (is_scalarref($query)) {
 715         $query = simple_expression_query($$query, @_);
 716     }
 717     else {
 718         $query = query($query, @_);
 719     }
 720
 721     my @match;
 722     for my $item (@$list) {
 723         push @match, $item if $query->($item);
 724     }
 725     return \@match;
 726 }
 727
 728 =for Pod::Coverage search_limited
 729
 730 =cut
 731
 732 sub search_limited {
 733     my $list    = shift;
 734     my $query   = shift;
 735     my $limit   = shift // 1;
 736
 737     if (is_coderef($query) && !@_) {
 738         # already a query
 739     }
 740     elsif (is_scalarref($query)) {
 741         $query = simple_expression_query($$query, @_);
 742     }
 743     else {
 744         $query = query($query, @_);
 745     }
 746
 747     my @match;
 748     for my $item (@$list) {
 749         push @match, $item if $query->($item);
 750         last if $limit <= @match;
 751     }
 752     return \@match;
 753 }
 754
 755 =func simple_expression_query
 756
 757     $query = simple_expression_query($expression, @fields);
 758
 759 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
 760 L<described here|https://keepass.info/help/base/search.html#mode_se>.
 761
 762 An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
 763 quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
 764 one of the given fields.
 765
 766 =cut
 767
 768 sub simple_expression_query {
 769     my $expr = shift;
 770     my $op   = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~';
 771
 772     my $neg_op = $OP_NEG{$op};
 773     my $is_re  = $op eq '=~' || $op eq '!~';
 774
 775     require Text::ParseWords;
 776     my @terms = Text::ParseWords::shellwords($expr);
 777
 778     my @query = qw(-and);
 779
 780     for my $term (@terms) {
 781         my @subquery = qw(-or);
 782
 783         my $neg = $term =~ s/^-//;
 784         my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)];
 785
 786         for my $field (@_) {
 787             push @subquery, $field => $condition;
 788         }
 789
 790         push @query, \@subquery;
 791     }
 792
 793     return query(\@query);
 794 }
 795
 796 =func snakify
 797
 798     $string = snakify($string);
 799
 800 Turn a CamelCase string into snake_case.
 801
 802 =cut
 803
 804 sub snakify {
 805     local $_ = shift;
 806     s/UserName/Username/g;
 807     s/([a-z])([A-Z0-9])/${1}_${2}/g;
 808     s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g;
 809     return lc($_);
 810 }
 811
 812 =func split_url
 813
 814     ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url($url);
 815
 816 Split a URL into its parts.
 817
 818 For example, C<http://user:pass@localhost:4000/path?query#hash> gets split like:
 819
 820 =for :list
 821 * C<http>
 822 * C<user:pass>
 823 * C<host>
 824 * C<4000>
 825 * C</path>
 826 * C<?query>
 827 * C<#hash>
 828 * C<user>
 829 * C<pass>
 830
 831 =cut
 832
 833 sub split_url {
 834     local $_ = shift;
 835     my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m!
 836         ^([^:/\?\#]+) ://
 837         (?:([^\@]+)\@)
 838         ([^:/\?\#]*)
 839         (?::(\d+))?
 840         ([^\?\#]*)
 841         (\?[^\#]*)?
 842         (\#(.*))?
 843     !x;
 844
 845     $scheme = lc($scheme);
 846
 847     $host ||= 'localhost';
 848     $host = lc($host);
 849
 850     $path = "/$path" if $path !~ m!^/!;
 851
 852     $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef;
 853
 854     my ($username, $password) = split($auth, ':', 2);
 855
 856     return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
 857 }
 858
 859 =func to_bool
 860
 861 =func to_number
 862
 863 =func to_string
 864
 865 =func to_time
 866
 867 =func to_tristate
 868
 869 =func to_uuid
 870
 871 Various typecasting / coercive functions.
 872
 873 =cut
 874
 875 sub to_bool   { $_[0] // return; boolean($_[0]) }
 876 sub to_number { $_[0] // return; 0+$_[0] }
 877 sub to_string { $_[0] // return; "$_[0]" }
 878 sub to_time   {
 879     $_[0] // return;
 880     return gmtime($_[0]) if looks_like_number($_[0]);
 881     return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0];
 882     return $_[0];
 883 }
 884 sub to_tristate { $_[0] // return; boolean($_[0]) }
 885 sub to_uuid {
 886     my $str = to_string(@_) // return;
 887     return sprintf('%016s', $str) if length($str) < 16;
 888     return substr($str, 0, 16) if 16 < length($str);
 889     return $str;
 890 }
 891
 892 =func trim
 893
 894     $string = trim($string);
 895
 896 The ubiquitous C<trim> function. Removes all whitespace from both ends of a string.
 897
 898 =cut
 899
 900 sub trim($) { ## no critic (ProhibitSubroutinePrototypes)
 901     local $_ = shift // return;
 902     s/^\s*//;
 903     s/\s*$//;
 904     return $_;
 905 }
 906
 907 =func try_load_optional
 908
 909     $package = try_load_optional($package);
 910
 911 Try to load a module that isn't required but can provide extra functionality, and return true if successful.
 912
 913 =cut
 914
 915 sub try_load_optional {
 916     for my $module (@_) {
 917         eval { load $module };
 918         if (my $err = $@) {
 919             warn $err if $ENV{DEBUG};
 920             return;
 921         }
 922     }
 923     return @_;
 924 }
 925
 926 =func uri_escape_utf8
 927
 928     $string = uri_escape_utf8($string);
 929
 930 Percent-encode arbitrary text strings, like for a URI.
 931
 932 =cut
 933
 934 my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
 935 sub uri_escape_utf8 {
 936     local $_ = shift // return;
 937     $_ = encode('UTF-8', $_);
 938     # RFC 3986 section 2.3 unreserved characters
 939     s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge;
 940     return $_;
 941 }
 942
 943 =func uri_unescape_utf8
 944
 945     $string = uri_unescape_utf8($string);
 946
 947 Inverse of L</uri_escape_utf8>.
 948
 949 =cut
 950
 951 sub uri_unescape_utf8 {
 952     local $_ = shift // return;
 953     s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
 954     return decode('UTF-8', $_);
 955 }
 956
 957 =func uuid
 958
 959     $raw_uuid = uuid($string_uuid);
 960
 961 Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s, like
 962 C<12345678-9ABC-DEFG-1234-56789ABCDEFG>) into a string of exactly 16 octets.
 963
 964 This is the inverse of L</format_uuid>.
 965
 966 =cut
 967
 968 sub uuid {
 969     local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
 970     s/-//g;
 971     /^[A-Fa-f0-9]{32}$/ or throw 'Must provide a formatted 128-bit UUID';
 972     return pack('H32', $_);
 973
 974 }
 975
 976 ### --------------------------------------------------------------------------
 977
 978 # Determine if an array looks like keypairs from a hash.
 979 sub _looks_like_keypairs {
 980     my $arr = shift;
 981     return 0 if @$arr % 2 == 1;
 982     for (my $i = 0; $i < @$arr; $i += 2) {
 983         return 0 if is_ref($arr->[$i]);
 984     }
 985     return 1;
 986 }
 987
 988 sub _is_operand_plain {
 989     local $_ = shift;
 990     return !(is_hashref($_) || is_arrayref($_));
 991 }
 992
 993 sub _query {
 994     # dumper \@_;
 995     my $subject = shift;
 996     my $op      = shift // throw 'Must specify a query operator';
 997     my $operand = shift;
 998
 999     return _query_simple($op, $subject) if defined $subject && !is_ref($op) && ($OPS{$subject} || 2) < 2;
1000     return _query_simple($subject, $op, $operand) if _is_operand_plain($operand);
1001     return _query_inverse(_query($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false';
1002     return _query($subject, '-and', [%$operand]) if is_hashref($operand);
1003
1004     my @queries;
1005
1006     my @atoms = @$operand;
1007     while (@atoms) {
1008         if (_looks_like_keypairs(\@atoms)) {
1009             my ($atom, $operand) = splice @atoms, 0, 2;
1010             if (my $op_type = $OPS{$atom}) {
1011                 if ($op_type == 1 && _is_operand_plain($operand)) { # unary
1012                     push @queries, _query_simple($operand, $atom);
1013                 }
1014                 else {
1015                     push @queries, _query($subject, $atom, $operand);
1016                 }
1017             }
1018             elsif (!is_ref($atom)) {
1019                 push @queries, _query($atom, 'eq', $operand);
1020             }
1021         }
1022         else {
1023             my $atom = shift @atoms;
1024             if ($OPS{$atom}) {     # apply new operator over the rest
1025                 push @queries, _query($subject, $atom, \@atoms);
1026                 last;
1027             }
1028             else {  # apply original operator over this one
1029                 push @queries, _query($subject, $op, $atom);
1030             }
1031         }
1032     }
1033
1034     if (@queries == 1) {
1035         return $queries[0];
1036     }
1037     elsif ($op eq '-and') {
1038         return _query_all(@queries);
1039     }
1040     elsif ($op eq '-or') {
1041         return _query_any(@queries);
1042     }
1043     throw 'Malformed query';
1044 }
1045
1046 sub _query_simple {
1047     my $subject = shift;
1048     my $op      = shift // 'eq';
1049     my $operand = shift;
1050
1051     # these special operators can also act as simple operators
1052     $op = '!!' if $op eq '-true';
1053     $op = '!'  if $op eq '-false';
1054     $op = '!'  if $op eq '-not';
1055
1056     defined $subject or throw 'Subject is not set in query';
1057     $OPS{$op} >= 0   or throw 'Cannot use a non-simple operator in a simple query';
1058     if (empty($operand)) {
1059         if ($OPS{$op} < 2) {
1060             # no operand needed
1061         }
1062         # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing.
1063         elsif ($op eq 'eq' || $op eq '==') {
1064             $op = '-empty';
1065         }
1066         elsif ($op eq 'ne' || $op eq '!=') {
1067             $op = '-nonempty';
1068         }
1069         else {
1070             throw 'Operand is required';
1071         }
1072     }
1073
1074     my $field = sub { blessed $_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} };
1075
1076     my %map = (
1077         'eq'        => sub { local $_ = $field->(@_); defined && $_ eq $operand },
1078         'ne'        => sub { local $_ = $field->(@_); defined && $_ ne $operand },
1079         'lt'        => sub { local $_ = $field->(@_); defined && $_ lt $operand },
1080         'gt'        => sub { local $_ = $field->(@_); defined && $_ gt $operand },
1081         'le'        => sub { local $_ = $field->(@_); defined && $_ le $operand },
1082         'ge'        => sub { local $_ = $field->(@_); defined && $_ ge $operand },
1083         '=='        => sub { local $_ = $field->(@_); defined && $_ == $operand },
1084         '!='        => sub { local $_ = $field->(@_); defined && $_ != $operand },
1085         '<'         => sub { local $_ = $field->(@_); defined && $_ <  $operand },
1086         '>'         => sub { local $_ = $field->(@_); defined && $_ >  $operand },
1087         '<='        => sub { local $_ = $field->(@_); defined && $_ <= $operand },
1088         '>='        => sub { local $_ = $field->(@_); defined && $_ >= $operand },
1089         '=~'        => sub { local $_ = $field->(@_); defined && $_ =~ $operand },
1090         '!~'        => sub { local $_ = $field->(@_); defined && $_ !~ $operand },
1091         '!'         => sub { local $_ = $field->(@_); ! $_ },
1092         '!!'        => sub { local $_ = $field->(@_); !!$_ },
1093         '-defined'  => sub { local $_ = $field->(@_);  defined $_ },
1094         '-undef'    => sub { local $_ = $field->(@_); !defined $_ },
1095         '-nonempty' => sub { local $_ = $field->(@_); nonempty $_ },
1096         '-empty'    => sub { local $_ = $field->(@_); empty    $_ },
1097     );
1098
1099     return $map{$op} // throw "Unexpected operator in query: $op",
1100         subject     => $subject,
1101         operator    => $op,
1102         operand     => $operand;
1103 }
1104
1105 sub _query_inverse {
1106     my $query = shift;
1107     return sub { !$query->(@_) };
1108 }
1109
1110 sub _query_all {
1111     my @queries = @_;
1112     return sub {
1113         my $val = shift;
1114         all { $_->($val) } @queries;
1115     };
1116 }
1117
1118 sub _query_any {
1119     my @queries = @_;
1120     return sub {
1121         my $val = shift;
1122         any { $_->($val) } @queries;
1123     };
1124 }
1125
1126 1;