Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Util.pm

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