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)],
+ assert => [qw(DEBUG assert 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)],
+ debug => [qw(DEBUG dumper)],
fork => [qw(can_fork)],
function => [qw(memoize recurse_limit)],
empty => [qw(empty nonempty)],
gzip => [qw(gzip gunzip)],
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 query_any search 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)],
);
$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
our @EXPORT_OK = @{$EXPORT_TAGS{all}};
+BEGIN {
+ my $debug = $ENV{DEBUG};
+ $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
+ *DEBUG = $debug == 1 ? sub() { 1 } :
+ $debug == 2 ? sub() { 2 } :
+ $debug == 3 ? sub() { 3 } :
+ $debug == 4 ? sub() { 4 } : sub() { 0 };
+}
+
my %OPS = (
'eq' => 2, # binary
'ne' => 2,
'=~' => '!~',
'!~' => '=~',
);
+my %ATTRIBUTES;
+
+=func load_xs
+
+ $bool = load_xs();
+ $bool = load_xs($version);
+
+Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> 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
+
+ assert { ... };
+
+Write an executable comment. Only executed if C<DEBUG> is set in the environment.
+
+=cut
+
+sub assert(&) { ## no critic (ProhibitSubroutinePrototypes)
+ return if !DEBUG;
+ my $code = shift;
+ return if $code->();
+
+ (undef, my $file, my $line) = caller;
+ $file =~ s!([^/\\]+)$!$1!;
+ my $assertion = '';
+ if (try_load_optional('B::Deparse')) {
+ my $deparse = B::Deparse->new(qw{-P -x9});
+ $assertion = $deparse->coderef2text($code);
+ $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s;
+ $assertion =~ s/\s+/ /gs;
+ $assertion = ": $assertion";
+ }
+ die "$0: $file:$line: Assertion failed$assertion\n";
+}
=func assert_64bit
return $thing;
}
+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+
=func dumper
$str = dumper $thing;
# 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;
=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
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($_);
# }
}
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($$_);
# }
=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($_)
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;
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ @{"${caller}::ISA"} = $parent;
+}
+
+=func has
+
+ has $name => %options;
+
+Create an attribute getter/setter. Possible options:
+
+=for :list
+* C<is> - Either "rw" (default) or "ro"
+* C<default> - Default value
+* C<coerce> - 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 =~ /\./;
+
+ my @path = split(/\./, $args{path} || '');
+ my $last = pop @path;
+ my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}}
+ : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}};
+ my $member = qq{\$_[0]$path};
+
+
+ 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 \$#_;};
+ }
+
+ push @{$ATTRIBUTES{$package} //= []}, $name;
+ $line -= 4;
+ my $code = <<END;
+# line $line "$file"
+sub ${package}::${name} {
+ return $default_code if !Scalar::Util::blessed(\$_[0]);
+ $set
+ $get
+}
+END
+ eval $code; ## no critic (ProhibitStringyEval)
+}
+
=func format_uuid
$string_uuid = format_uuid($raw_uuid);
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);
for my $module (@_) {
eval { load $module };
if (my $err = $@) {
- warn $err if $ENV{DEBUG};
- throw "Missing dependency: Please install $module to use this feature.\n", module => $module;
+ throw "Missing dependency: Please install $module to use this feature.\n",
+ module => $module,
+ error => $err;
}
}
return wantarray ? @_ : $_[0];
}
-=func load_xs
-
- $bool = load_xs();
- $bool = load_xs($version);
-
-Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> 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, ...);
for this function, but this code is distinct, supporting an overlapping but not identical feature set and
having its own bugs.
-See L<File::KDBX/QUERY> for examples.
+See L<File::KDBX/"Declarative Syntax"> for examples.
=cut
sub query { _query(undef, '-or', \@_) }
+=func query_any
+
+Get either a L</query> or L</simple_expression_query>, depending on the arguments.
+
+=cut
+
+sub query_any {
+ my $code = shift;
+
+ if (is_coderef($code) || overload::Method($code, '&{}')) {
+ return $code;
+ }
+ elsif (is_scalarref($code)) {
+ return simple_expression_query($$code, @_);
+ }
+ else {
+ return query($code, @_);
+ }
+}
+
=func read_all
$size = read_all($fh, my $buffer, $size);
Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
-This is the search engine described with many examples at L<File::KDBX/QUERY>.
-
=cut
sub search {
my $list = shift;
- my $query = shift;
- # my %args = @_;
-
- if (is_coderef($query) && !@_) {
- # already a query
- }
- elsif (is_scalarref($query)) {
- $query = simple_expression_query($$query, @_);
- }
- else {
- $query = query($query, @_);
- }
-
- # my $limit = $args{limit};
+ my $query = query_any(@_);
my @match;
for my $item (@$list) {
push @match, $item if $query->($item);
- # last if defined $limit && $limit <= @match;
}
return \@match;
}
=func simple_expression_query
$query = simple_expression_query($expression, @fields);
+ $query = simple_expression_query($expression, $operator, @fields);
Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
L<described here|https://keepass.info/help/base/search.html#mode_se>.
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 scalar gmtime($_[0]) if looks_like_number($_[0]);
+ return scalar gmtime if $_[0] eq 'now';
+ 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);
for my $module (@_) {
eval { load $module };
if (my $err = $@) {
- warn $err if $ENV{DEBUG};
+ warn $err if 3 <= DEBUG;
return;
}
}
}
-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 }
### --------------------------------------------------------------------------
projects / chaz / p5-File-KDBX / blobdiff