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