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