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 search_limited 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,
}
}
+=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
assert_64bit();
return $thing;
}
+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+
=func dumper
$str = dumper $thing;
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 $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
my $coerce = $args{coerce};
my $is = $args{is} || 'rw';
- my $has_default = is_coderef $default;
- my $has_coerce = is_coderef $coerce;
-
my $store = $args{store};
($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
- my $caller = caller;
- push @{$ATTRIBUTES{$caller} //= []}, $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};
- no strict 'refs'; ## no critic (ProhibitNoStrict)
- if ($store) {
- *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
- $_[0]->$store->{$name} //= scalar $default->($_[0]);
- } : $is eq 'ro' ? sub {
- $_[0]->$store->{$name} //= $default;
- } : $has_default && $has_coerce ? sub {
- $#_ ? $_[0]->$store->{$name} = scalar $coerce->($_[1])
- : $_[0]->$store->{$name} //= scalar $default->($_[0]);
- } : $has_default ? sub {
- $#_ ? $_[0]->$store->{$name} = $_[1]
- : $_[0]->$store->{$name} //= scalar $default->($_[0]);
- } : $has_coerce ? sub {
- $#_ ? $_[0]->$store->{$name} = scalar $coerce->($_[1])
- : $_[0]->$store->{$name} //= $default;
- } : sub {
- $#_ ? $_[0]->$store->{$name} = $_[1]
- : $_[0]->$store->{$name} //= $default;
- };
- }
- else {
- *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
- $_[0]->{$name} //= scalar $default->($_[0]);
- } : $is eq 'ro' ? sub {
- $_[0]->{$name} //= $default;
- } : $has_default && $has_coerce ? sub {
- $#_ ? $_[0]->{$name} = scalar $coerce->($_[1])
- : $_[0]->{$name} //= scalar $default->($_[0]);
- } : $has_default ? sub {
- $#_ ? $_[0]->{$name} = $_[1]
- : $_[0]->{$name} //= scalar $default->($_[0]);
- } : $has_coerce ? sub {
- $#_ ? $_[0]->{$name} = scalar $coerce->($_[1])
- : $_[0]->{$name} //= $default;
- } : sub {
- $#_ ? $_[0]->{$name} = $_[1]
- : ($_[0]->{$name} //= $default);
- };
+
+ 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
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];
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;
-
- 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);
- }
- 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 $query = query_any(@_);
my @match;
for my $item (@$list) {
push @match, $item if $query->($item);
- last if $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>.
sub to_string { $_[0] // return; "$_[0]" }
sub to_time {
$_[0] // return;
- return gmtime($_[0]) if looks_like_number($_[0]);
+ 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];
}
for my $module (@_) {
eval { load $module };
if (my $err = $@) {
- warn $err if $ENV{DEBUG};
+ warn $err if 3 <= DEBUG;
return;
}
}
}
+=func UUID_NULL
+
+Get the null UUID (i.e. string of 16 null bytes).
+
+=cut
+
+sub UUID_NULL() { "\0" x 16 }
+
### --------------------------------------------------------------------------
# Determine if an array looks like keypairs from a hash.
projects / chaz / p5-File-KDBX / blobdiff