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