X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FUtil.pm;h=a09d2863d9177d69f902140f2159c0083bf50bc0;hb=331a54019664704eb4a10186cb4abd7a2a722f30;hp=3141c3fe969c35369482d84bd85c911a87b81647;hpb=4919a87027c9f0501a636fbea0cbd2a6510afb38;p=chaz%2Fp5-File-KDBX

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index 3141c3f..a09d286 100644
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -20,12 +20,12 @@ use namespace::clean -except => 'import';
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
-    assert      => [qw(assert_64bit)],
-    class       => [qw(extends has)],
+    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)],
@@ -33,15 +33,24 @@ our %EXPORT_TAGS = (
     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 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,
@@ -85,6 +94,7 @@ my %OP_NEG = (
     '=~'    =>  '!~',
     '!~'    =>  '=~',
 );
+my %ATTRIBUTES;
 
 =func load_xs
 
@@ -116,6 +126,32 @@ sub load_xs {
     }
 }
 
+=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();
@@ -375,7 +411,8 @@ Set up the current module to inheret from another module.
 sub extends {
     my $parent  = shift;
     my $caller  = caller;
-    load $parent;
+    # load $parent;
+    eval qq[require $parent];
     no strict 'refs'; ## no critic (ProhibitNoStrict)
     @{"${caller}::ISA"} = $parent;
 }
@@ -397,54 +434,43 @@ 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 $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 =~ /\./;
+    push @{$ATTRIBUTES{$package} //= []}, $name;
 
-    my $caller = caller;
-    no strict 'refs'; ## no critic (ProhibitNoStrict)
-    if (my $store = $args{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 $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 = <<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
@@ -574,6 +600,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);
@@ -586,8 +625,9 @@ sub load_optional {
     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];
@@ -725,36 +765,10 @@ sub search {
     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 $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>.
@@ -916,7 +930,7 @@ sub try_load_optional {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {
-            warn $err if $ENV{DEBUG};
+            warn $err if 3 <= DEBUG;
             return;
         }
     }
@@ -973,6 +987,14 @@ sub uuid {
 
 }
 
+=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.