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