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