X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FUtil.pm;h=3355d41fa1d3454c119a14dbd98d900abef70083;hb=05e0bcef1c2165c556b910314312866dc4a667b7;hp=2d830742e949e3730a452fc25ef6713f7d2a3d03;hpb=f63182fc62b25269b1c38588dca2b3535ed1a1a2;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 2d83074..3355d41 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -7,11 +7,12 @@ use strict; use Crypt::PRNG qw(random_bytes random_string); use Encode qw(decode encode); use Exporter qw(import); +use File::KDBX::Constants qw(:bool); use File::KDBX::Error; use List::Util 1.33 qw(any all); use Module::Load; -use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref is_ref); -use Scalar::Util qw(blessed isdual looks_like_number readonly refaddr); +use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref); +use Scalar::Util qw(blessed readonly); use namespace::clean -except => 'import'; our $VERSION = '999.999'; # VERSION @@ -26,9 +27,9 @@ our %EXPORT_TAGS = ( empty => [qw(empty nonempty)], erase => [qw(erase erase_scoped)], gzip => [qw(gzip gunzip)], - io => [qw(read_all)], + io => [qw(is_readable is_writable read_all)], load => [qw(load_optional load_xs try_load_optional)], - search => [qw(query search simple_expression_query)], + search => [qw(query search search_limited simple_expression_query)], text => [qw(snakify trim)], uuid => [qw(format_uuid generate_uuid is_uuid uuid)], uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)], @@ -81,6 +82,36 @@ my %OP_NEG = ( '!~' => '=~', ); +=func load_xs + + $bool = load_xs(); + $bool = load_xs($version); + +Attempt to load L. Return truthy if C is loaded. If C<$version> is given, it will check +that at least the given version is loaded. + +=cut + +my $XS_LOADED; +sub load_xs { + my $version = shift; + + goto IS_LOADED if defined $XS_LOADED; + + if ($ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS})) { + return $XS_LOADED = FALSE; + } + + $XS_LOADED = !!eval { require File::KDBX::XS; 1 }; + + IS_LOADED: + { + local $@; + return $XS_LOADED if !$version; + return !!eval { File::KDBX::XS->VERSION($version); 1 }; + } +} + =func assert_64bit assert_64bit(); @@ -119,13 +150,11 @@ sub can_fork { return 1; } -=func clone_nomagic - - $clone = clone_nomagic($thing); +=func clone -Clone deeply without keeping [most of] the magic. + $clone = clone($thing); -B At the moment the implementation is naïve and won't respond well to nontrivial data. +Clone deeply. This is an unadorned alias to L C. =cut @@ -134,6 +163,17 @@ sub clone { goto &Storable::dclone; } +=func clone_nomagic + + $clone = clone_nomagic($thing); + +Clone deeply without keeping [most of] the magic. + +B At the moment the implementation is naïve and won't respond well to nontrivial data or recursive +structures. + +=cut + sub clone_nomagic { my $thing = shift; if (is_arrayref($thing)) { @@ -153,7 +193,8 @@ sub clone_nomagic { =func dumper - $str = dumper $struct; + $str = dumper $thing; + dumper $thing; # in void context, prints to STDERR Like L but slightly terser in some cases relevent to L. @@ -232,7 +273,17 @@ Overwrite the memory used by one or more string. =cut -# use File::KDBX::XS; +BEGIN { + if (load_xs) { + *_CowREFCNT = \&File::KDBX::XS::CowREFCNT; + } + elsif (eval { require B::COW; 1 }) { + *_CowREFCNT = \&B::COW::cowrefcnt; + } + else { + *_CowREFCNT = sub { undef }; + } +} sub erase { # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just @@ -241,10 +292,8 @@ sub erase { for (@_) { if (!is_ref($_)) { next if !defined $_ || readonly $_; - if (USE_COWREFCNT()) { - my $cowrefcnt = B::COW::cowrefcnt($_); - goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; - } + my $cowrefcnt = _CowREFCNT($_); + goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt; # if (__PACKAGE__->can('erase_xs')) { # erase_xs($_); # } @@ -258,10 +307,8 @@ sub erase { } elsif (is_scalarref($_)) { next if !defined $$_ || readonly $$_; - if (USE_COWREFCNT()) { - my $cowrefcnt = B::COW::cowrefcnt($$_); - goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; - } + my $cowrefcnt = _CowREFCNT($$_); + goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt; # if (__PACKAGE__->can('erase_xs')) { # erase_xs($$_); # } @@ -301,6 +348,7 @@ See L. =cut sub erase_scoped { + throw 'Programmer error: Cannot call erase_scoped in void context' if !defined wantarray; my @args; for (@_) { !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_) @@ -391,7 +439,7 @@ sub gunzip { return $out; } -=func gunzip +=func gzip $zipped = gzip($string); @@ -414,6 +462,20 @@ sub gzip { return $out; } +=func is_readable + +=func is_writable + + $bool = is_readable($mode); + $bool = is_writable($mode); + +Determine of an C-style mode is readable, writable or both. + +=cut + +sub is_readable { $_[0] !~ /^[aw]b?$/ } +sub is_writable { $_[0] !~ /^rb?$/ } + =func is_uuid $bool = is_uuid($thing); @@ -443,34 +505,6 @@ sub load_optional { return wantarray ? @_ : $_[0]; } -=func load_xs - - $bool = load_xs(); - $bool = load_xs($version); - -Attempt to load L. Return truthy if C is loaded. If C<$version> is given, it will check -that at least the given version is loaded. - -=cut - -sub load_xs { - my $version = shift; - - require File::KDBX; - - my $has_xs = File::KDBX->can('XS_LOADED'); - return $has_xs->() && ($version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1) if $has_xs; - - my $try_xs = 1; - $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS}); - - my $use_xs = 0; - $use_xs = try_load_optional('File::KDBX::XS') if $try_xs; - - *File::KDBX::XS_LOADED = *File::KDBX::XS_LOADED = $use_xs ? sub() { 1 } : sub() { 0 }; - return $version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1; -} - =func memoize \&memoized_code = memoize(\&code, ...); @@ -585,7 +619,6 @@ This is the search engine described with many examples at L. sub search { my $list = shift; my $query = shift; - # my %args = @_; if (is_coderef($query) && !@_) { # already a query @@ -597,12 +630,32 @@ sub search { $query = query($query, @_); } - # my $limit = $args{limit}; + my @match; + for my $item (@$list) { + push @match, $item if $query->($item); + } + return \@match; +} + +sub search_limited { + my $list = shift; + my $query = shift; + my $limit = shift // 1; + + if (is_coderef($query) && !@_) { + # already a query + } + elsif (is_scalarref($query)) { + $query = simple_expression_query($$query, @_); + } + else { + $query = query($query, @_); + } my @match; for my $item (@$list) { push @match, $item if $query->($item); - # last if defined $limit && $limit <= @match; + last if $limit <= @match; } return \@match; } @@ -762,6 +815,14 @@ sub uri_escape_utf8 { return $_; } +=func uri_unescape_utf8 + + $string = uri_unescape_utf8($string); + +Inverse of L. + +=cut + sub uri_unescape_utf8 { local $_ = shift // return; s/\%([A-Fa-f0-9]{2})/chr(hex($1))/; @@ -787,11 +848,6 @@ sub uuid { } -BEGIN { - my $use_cowrefcnt = eval { require B::COW; 1 }; - *USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 }; -} - ### -------------------------------------------------------------------------- # Determine if an array looks like keypairs from a hash.