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