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