Don't open already-open files on Windows

[chaz/p5-File-KDBX] / lib / File / KDBX / Util.pm

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index a09d2863d9177d69f902140f2159c0083bf50bc0..a27f4dd70393a4d9aaa21c68d5f39cb9e32f8517 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -33,7 +33,7 @@ our %EXPORT_TAGS = (
     gzip        => [qw(gzip gunzip)],
     io          => [qw(is_readable is_writable read_all)],
     load        => [qw(load_optional load_xs try_load_optional)],
     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_NULL)],
     uri         => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
     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)],


@@ -231,6 +231,10 @@ sub clone_nomagic {
     return $thing;
 }
 
     return $thing;
 }
 

+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+

 =func dumper
 
     $str = dumper $thing;
 =func dumper
 
     $str = dumper $thing;


@@ -411,8 +415,7 @@ Set up the current module to inheret from another module.
 sub extends {
     my $parent  = shift;
     my $caller  = caller;
 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;
 }
     no strict 'refs'; ## no critic (ProhibitNoStrict)
     @{"${caller}::ISA"} = $parent;
 }


@@ -443,11 +446,13 @@ sub has {
 
     my $store = $args{store};
     ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
 
     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}
 
     my $default_code = is_coderef $default ? q{scalar $default->($_[0])}
                         : defined $default ? q{$default}


@@ -461,6 +466,7 @@ sub has {
                                   : qq{$member = \$_[1] if \$#_;};
     }
 
                                   : qq{$member = \$_[1] if \$#_;};
     }
 

+    push @{$ATTRIBUTES{$package} //= []}, $name;

     $line -= 4;
     my $code = <<END;
 # line $line "$file"
     $line -= 4;
     my $code = <<END;
 # line $line "$file"


@@ -679,19 +685,39 @@ The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES
 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
 having its own bugs.
 
 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', \@_) }
 
 
 =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);
 
 =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
 
 
 =cut
 


@@ -740,23 +766,11 @@ sub recurse_limit {
 
 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
 
 
 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;
 =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 $query   = query_any(@_);

 
     my @match;
     for my $item (@$list) {
 
     my @match;
     for my $item (@$list) {


@@ -891,7 +905,8 @@ sub to_number { $_[0] // return; 0+$_[0] }
 sub to_string { $_[0] // return; "$_[0]" }
 sub to_time   {
     $_[0] // return;
 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];
 }
     return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0];
     return $_[0];
 }