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