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_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;
sub extends {
my $parent = shift;
my $caller = caller;
- # load $parent;
- eval qq[require $parent];
+ load $parent;
no strict 'refs'; ## no critic (ProhibitNoStrict)
@{"${caller}::ISA"} = $parent;
}
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 @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}
: qq{$member = \$_[1] if \$#_;};
}
+ push @{$ATTRIBUTES{$package} //= []}, $name;
$line -= 4;
my $code = <<END;
# line $line "$file"
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);
$size = read_all($fh, my $buffer, $size, $offset);
-Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
-distinguishable from other errors by C<$!> not being set.
+Like L<perlfunc/"read FILEHANDLE,SCALAR,LENGTH,OFFSET"> but returns C<undef> if not all C<$size> bytes are
+read. This is considered an error, distinguishable from other errors by C<$!> not being set.
=cut
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;
}
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;
}
}