X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-File-KDBX;a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FUtil.pm;h=b1795a71c111d1144995dc7e82d7769f47e018fa;hp=4b4c2c71b9828eecabac99d9153f644f7a6aad24;hb=c98fc7d0294e641cf8844306808333bdec4fea2f;hpb=1b913e5c8826cae2355b0076ec5701aa3ce63c63 diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 4b4c2c7..b1795a7 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -7,18 +7,23 @@ 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 looks_like_number readonly); +use Time::Piece; +use boolean; use namespace::clean -except => 'import'; our $VERSION = '999.999'; # VERSION our %EXPORT_TAGS = ( assert => [qw(assert_64bit)], + class => [qw(extends has list_attributes)], clone => [qw(clone clone_nomagic)], + coercion => [qw(to_bool to_number to_string to_time to_tristate to_uuid)], crypt => [qw(pad_pkcs7)], debug => [qw(dumper)], fork => [qw(can_fork)], @@ -26,11 +31,11 @@ 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)], + uuid => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)], uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)], ); @@ -80,6 +85,37 @@ my %OP_NEG = ( '=~' => '!~', '!~' => '=~', ); +my %ATTRIBUTES; + +=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 @@ -188,7 +224,8 @@ sub dumper { # boolean $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs; # Time::Piece - $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \)/Time::Piece->new($1)/gs; + $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/ + "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges; print STDERR $str if !defined wantarray; push @dumps, $str; @@ -242,7 +279,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 @@ -251,10 +298,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($_); # } @@ -268,10 +313,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($$_); # } @@ -311,6 +354,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($_) @@ -321,6 +365,79 @@ sub erase_scoped { return Scope::Guard->new(sub { erase(@args) }); } +=func extends + + extends $class; + +Set up the current module to inheret from another module. + +=cut + +sub extends { + my $parent = shift; + my $caller = caller; + # load $parent; + eval qq[require $parent]; + no strict 'refs'; ## no critic (ProhibitNoStrict) + @{"${caller}::ISA"} = $parent; +} + +=func has + + has $name => %options; + +Create an attribute getter/setter. Possible options: + +=for :list +* C - Either "rw" (default) or "ro" +* C - Default value +* C - Coercive function + +=cut + +sub has { + my $name = shift; + my %args = @_ % 2 == 1 ? (default => shift, @_) : @_; + + my ($package, $file, $line) = caller; + + my $d = $args{default}; + my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d; + my $coerce = $args{coerce}; + my $is = $args{is} || 'rw'; + + my $store = $args{store}; + ($store, $name) = split(/\./, $name, 2) if $name =~ /\./; + push @{$ATTRIBUTES{$package} //= []}, $name; + + my $store_code = ''; + $store_code = qq{->$store} if $store; + my $member = qq{\$_[0]$store_code\->{'$name'}}; + + my $default_code = is_coderef $default ? q{scalar $default->($_[0])} + : defined $default ? q{$default} + : q{undef}; + my $get = qq{$member //= $default_code;}; + + my $set = ''; + if ($is eq 'rw') { + $set = is_coderef $coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;} + : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \$#_;} + : qq{$member = \$_[1] if \$#_;}; + } + + $line -= 4; + my $code = <-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); @@ -434,6 +565,19 @@ Check if a thing is a UUID (i.e. scalar string of length 16). sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 } +=func list_attributes + + @attributes = list_attributes($package); + +Get a list of attributes for a class. + +=cut + +sub list_attributes { + my $package = shift; + return @{$ATTRIBUTES{$package} // []}; +} + =func load_optional $package = load_optional($package); @@ -453,34 +597,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, ...); @@ -595,7 +711,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 @@ -607,12 +722,36 @@ sub search { $query = query($query, @_); } - # my $limit = $args{limit}; + my @match; + for my $item (@$list) { + push @match, $item if $query->($item); + } + return \@match; +} + +=for Pod::Coverage search_limited + +=cut + +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; } @@ -620,6 +759,7 @@ sub search { =func simple_expression_query $query = simple_expression_query($expression, @fields); + $query = simple_expression_query($expression, $operator, @fields); Generate a query, like L, to be used with L but built from a "simple expression" as L. @@ -721,6 +861,39 @@ sub split_url { return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password); } +=func to_bool + +=func to_number + +=func to_string + +=func to_time + +=func to_tristate + +=func to_uuid + +Various typecasting / coercive functions. + +=cut + +sub to_bool { $_[0] // return; boolean($_[0]) } +sub to_number { $_[0] // return; 0+$_[0] } +sub to_string { $_[0] // return; "$_[0]" } +sub to_time { + $_[0] // return; + return gmtime($_[0]) if looks_like_number($_[0]); + return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0]; + return $_[0]; +} +sub to_tristate { $_[0] // return; boolean($_[0]) } +sub to_uuid { + my $str = to_string(@_) // return; + return sprintf('%016s', $str) if length($str) < 16; + return substr($str, 0, 16) if 16 < length($str); + return $str; +} + =func trim $string = trim($string); @@ -805,10 +978,13 @@ sub uuid { } -BEGIN { - my $use_cowrefcnt = eval { require B::COW; 1 }; - *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 }; -} +=func UUID_NULL + +Get the null UUID (i.e. string of 16 null bytes). + +=cut + +sub UUID_NULL() { "\0" x 16 } ### --------------------------------------------------------------------------