]> Dogcows Code - chaz/p5-File-KDBX/blobdiff - lib/File/KDBX.pm
Add recursive transactions
[chaz/p5-File-KDBX] / lib / File / KDBX.pm
index 03a055bc62fd7b9968380a39a495a3b702b0ad3d..2326b9b5d403f9ff2b631cc9e20c3b5c9c1ae466 100644 (file)
@@ -9,20 +9,19 @@ use Devel::GlobalDestruction;
 use File::KDBX::Constants qw(:all);
 use File::KDBX::Error;
 use File::KDBX::Safe;
-use File::KDBX::Util qw(:empty erase generate_uuid search simple_expression_query snakify);
+use File::KDBX::Util qw(:empty :uuid :search erase simple_expression_query snakify);
+use Hash::Util::FieldHash qw(fieldhashes);
 use List::Util qw(any);
 use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
-use Scalar::Util qw(blessed refaddr);
+use Scalar::Util qw(blessed);
 use Time::Piece;
 use boolean;
-use warnings::register;
 use namespace::clean;
 
 our $VERSION = '999.999'; # VERSION
 our $WARNINGS = 1;
 
-my %SAFE;
-my %KEYS;
+fieldhashes \my (%SAFE, %KEYS);
 
 =method new
 
@@ -45,7 +44,7 @@ sub new {
     return $self;
 }
 
-sub DESTROY { !in_global_destruction and $_[0]->reset }
+sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset }
 
 =method init
 
@@ -81,7 +80,6 @@ sub reset {
     erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
     erase $self->{raw};
     %$self = ();
-    delete $SAFE{refaddr($self)};
     $self->_remove_safe;
     return $self;
 }
@@ -107,19 +105,24 @@ sub STORABLE_freeze {
 
     my $copy = {%$self};
 
-    return '', $copy, $KEYS{refaddr($self)}, $SAFE{refaddr($self)};
+    return '', $copy, $KEYS{$self} // (), $SAFE{$self} // ();
 }
 
 sub STORABLE_thaw {
     my $self    = shift;
     my $cloning = shift;
+    shift;
     my $clone   = shift;
     my $key     = shift;
     my $safe    = shift;
 
     @$self{keys %$clone} = values %$clone;
-    $KEYS{refaddr($self)} = $key;
-    $SAFE{refaddr($self)} = $safe;
+    $KEYS{$self} = $key;
+    $SAFE{$self} = $safe;
+
+    for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) {
+        $object->kdbx($self);
+    }
 }
 
 ##############################################################################
@@ -220,31 +223,6 @@ sub user_agent_string {
         __PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)});
 }
 
-=attr sig1
-
-=attr sig2
-
-=attr version
-
-=attr headers
-
-=attr inner_headers
-
-=attr meta
-
-=attr binaries
-
-=attr deleted_objects
-
-=attr raw
-
-    $value = $kdbx->$attr;
-    $kdbx->$attr($value);
-
-Get and set attributes.
-
-=cut
-
 my %ATTRS = (
     sig1            => KDBX_SIG1,
     sig2            => KDBX_SIG2_2,
@@ -280,28 +258,28 @@ my %ATTRS_META = (
     generator                       => '',
     header_hash                     => '',
     database_name                   => '',
-    database_name_changed           => sub { gmtime },
+    database_name_changed           => sub { scalar gmtime },
     database_description            => '',
-    database_description_changed    => sub { gmtime },
+    database_description_changed    => sub { scalar gmtime },
     default_username                => '',
-    default_username_changed        => sub { gmtime },
+    default_username_changed        => sub { scalar gmtime },
     maintenance_history_days        => 0,
     color                           => '',
-    master_key_changed              => sub { gmtime },
+    master_key_changed              => sub { scalar gmtime },
     master_key_change_rec           => -1,
     master_key_change_force         => -1,
     # memory_protection               => sub { +{} },
     custom_icons                    => sub { +{} },
     recycle_bin_enabled             => true,
     recycle_bin_uuid                => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
-    recycle_bin_changed             => sub { gmtime },
+    recycle_bin_changed             => sub { scalar gmtime },
     entry_templates_group           => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
-    entry_templates_group_changed   => sub { gmtime },
+    entry_templates_group_changed   => sub { scalar gmtime },
     last_selected_group             => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
     last_top_visible_group          => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
     history_max_items               => HISTORY_DEFAULT_MAX_ITEMS,
     history_max_size                => HISTORY_DEFAULT_MAX_SIZE,
-    settings_changed                => sub { gmtime },
+    settings_changed                => sub { scalar gmtime },
     # binaries                        => sub { +{} },
     # custom_data                     => sub { +{} },
 );
@@ -311,39 +289,9 @@ my %ATTRS_MEMORY_PROTECTION = (
     protect_password            => true,
     protect_url                 => false,
     protect_notes               => false,
-    auto_enable_visual_hiding   => false,
+    auto_enable_visual_hiding   => false,
 );
 
-sub _update_group_uuid {
-    my $self        = shift;
-    my $old_uuid    = shift // return;
-    my $new_uuid    = shift;
-
-    my $meta = $self->meta;
-    $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
-    $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
-    $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // '');
-    $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // '');
-
-    for my $group (@{$self->all_groups}) {
-        $group->last_top_visible_entry($new_uuid) if $old_uuid eq ($group->{last_top_visible_entry} // '');
-        $group->previous_parent_group($new_uuid) if $old_uuid eq ($group->{previous_parent_group} // '');
-    }
-    for my $entry (@{$self->all_entries}) {
-        $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
-    }
-}
-
-sub _update_entry_uuid {
-    my $self        = shift;
-    my $old_uuid    = shift // return;
-    my $new_uuid    = shift;
-
-    for my $entry (@{$self->all_entries}) {
-        $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
-    }
-}
-
 while (my ($attr, $default) = each %ATTRS) {
     no strict 'refs'; ## no critic (ProhibitNoStrict)
     *{$attr} = sub {
@@ -456,7 +404,7 @@ sub minimum_version {
     return KDBX_VERSION_4_1 if any {
         nonempty $_->previous_parent_group || (defined $_->quality_check && !$_->quality_check) ||
         any { nonempty $_->{last_modification_time} } values %{$_->custom_data}
-    } @{$self->all_entries};
+    } @{$self->all_entries(history => 1)};
 
     return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES;
 
@@ -464,7 +412,7 @@ sub minimum_version {
 
     return KDBX_VERSION_4_0 if any {
         nonempty $_->custom_data
-    } @{$self->all_groups}, @{$self->all_entries};
+    } @{$self->all_groups}, @{$self->all_entries(history => 1)};
 
     return KDBX_VERSION_3_1;
 }
@@ -473,6 +421,14 @@ sub minimum_version {
 
 =method add_group
 
+    $kdbx->add_group($group, %options);
+    $kdbx->add_group(%group_attributes, %options);
+
+Add a group to a database. This is equivalent to identifying a parent group and calling
+L<File::KDBX::Group/add_group> on the parent group, forwarding the arguments. Available options:
+
+=for :list
+* C<group> (aka C<parent>) - Group (object or group UUID) to add the group to (default: root group)
 
 =cut
 
@@ -481,16 +437,15 @@ sub add_group {
     my $group   = @_ % 2 == 1 ? shift : undef;
     my %args    = @_;
 
+    # find the right group to add the group to
     my $parent = delete $args{group} // delete $args{parent} // $self->root;
     ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent;
+    $parent or throw 'Invalid group';
 
-    $group = $self->_group($group // [%args]);
-    $group->uuid;
-
-    return $parent->add_group($group);
+    return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
 }
 
-sub _group {
+sub _wrap_group {
     my $self  = shift;
     my $group = shift;
     require File::KDBX::Group;
@@ -509,7 +464,7 @@ Every database has only a single root group at a time. Some old KDB files might
 When reading such files, a single implicit root group is created to contain the other explicit groups. When
 writing to such a format, if the root group looks like it was implicitly created then it won't be written and
 the resulting file might have multiple root groups. This allows working with older files without changing
-their written internal structure while still adhering to the modern restrictions while the database is opened.
+their written internal structure while still adhering to modern semantics while the database is opened.
 
 B<WARNING:> The root group of a KDBX database contains all of the database's entries and other groups. If you
 replace the root group, you are essentially replacing the entire database contents with something else.
@@ -519,20 +474,20 @@ replace the root group, you are essentially replacing the entire database conten
 sub root {
     my $self = shift;
     if (@_) {
-        $self->{root} = $self->_group(@_);
+        $self->{root} = $self->_wrap_group(@_);
         $self->{root}->kdbx($self);
     }
     $self->{root} //= $self->_implicit_root;
-    return $self->_group($self->{root});
+    return $self->_wrap_group($self->{root});
 }
 
 sub _kpx_groups {
     my $self = shift;
     return [] if !$self->{root};
-    return $self->_is_implicit_root ? $self->root->groups : [$self->root];
+    return $self->_has_implicit_root ? $self->root->groups : [$self->root];
 }
 
-sub _is_implicit_root {
+sub _has_implicit_root {
     my $self = shift;
     my $root = $self->root;
     my $temp = __PACKAGE__->_implicit_root;
@@ -561,36 +516,6 @@ sub _implicit_root {
     );
 }
 
-=method group_level
-
-    $level = $kdbx->group_level($group);
-    $level = $kdbx->group_level($group_uuid);
-
-Determine the depth/level of a group. The root group is level 0, its direct children are level 1, etc.
-
-=cut
-
-sub group_level {
-    my $self    = shift;
-    my $group   = $self->_group(shift);
-    my $uuid    = !is_ref($group) ? $group : $group->uuid; # FIXME can't check if it's a UUID after running
-    # through _group
-    return _group_level($uuid, $self->root, 0);
-}
-
-sub _group_level {
-    my ($uuid, $base, $level) = @_;
-
-    return $level if $uuid eq $base->{uuid};
-
-    for my $subgroup (@{$base->{groups} || []}) {
-        my $result = _group_level($uuid, $subgroup, $level + 1);
-        return $result if 0 <= $result;
-    }
-
-    return -1;
-}
-
 =method all_groups
 
     \@groups = $kdbx->all_groups(%options);
@@ -610,7 +535,7 @@ sub all_groups {
     my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
     my $base = $args{base} // $self->root;
 
-    my @groups = $args{include_base} // 1 ? $self->_group($base) : ();
+    my @groups = $args{include_base} // 1 ? $self->_wrap_group($base) : ();
 
     for my $subgroup (@{$base->{groups} || []}) {
         my $more = $self->all_groups($subgroup);
@@ -635,17 +560,23 @@ the database structure.
 
 sub trace_lineage {
     my $self    = shift;
-    my $thing   = shift;
+    my $object  = shift;
+    return $object->lineage(@_);
+}
+
+sub _trace_lineage {
+    my $self    = shift;
+    my $object  = shift;
     my @lineage = @_;
 
     push @lineage, $self->root if !@lineage;
-    my $base = $lineage[-1];
+    my $base = $lineage[-1] or return [];
 
-    my $uuid = $thing->uuid;
+    my $uuid = $object->uuid;
     return \@lineage if any { $_->uuid eq $uuid } @{$base->groups || []}, @{$base->entries || []};
 
     for my $subgroup (@{$base->groups || []}) {
-        my $result = $self->trace_lineage($thing, @lineage, $subgroup);
+        my $result = $self->_trace_lineage($object, @lineage, $subgroup);
         return $result if $result;
     }
 }
@@ -680,6 +611,14 @@ sub remove {
 
 =method add_entry
 
+    $kdbx->add_entry($entry, %options);
+    $kdbx->add_entry(%entry_attributes, %options);
+
+Add a entry to a database. This is equivalent to identifying a parent group and calling
+L<File::KDBX::Group/add_entry> on the parent group, forwarding the arguments. Available options:
+
+=for :list
+* C<group> (aka C<parent>) - Group (object or group UUID) to add the entry to (default: root group)
 
 =cut
 
@@ -688,16 +627,15 @@ sub add_entry {
     my $entry   = @_ % 2 == 1 ? shift : undef;
     my %args    = @_;
 
+    # find the right group to add the entry to
     my $parent = delete $args{group} // delete $args{parent} // $self->root;
     ($parent) = $self->find_groups({uuid => $parent}) if !ref $parent;
+    $parent or throw 'Invalid group';
 
-    $entry = $self->_entry($entry // delete $args{entry} // [%args]);
-    $entry->uuid;
-
-    return $parent->add_entry($entry);
+    return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self);
 }
 
-sub _entry {
+sub _wrap_entry {
     my $self  = shift;
     my $entry = shift;
     require File::KDBX::Entry;
@@ -734,7 +672,7 @@ sub all_entries {
     my @entries;
     if ((!$search || $enable_searching) && (!$auto_type || $enable_auto_type)) {
         push @entries,
-            map { $self->_entry($_) }
+            map { $self->_wrap_entry($_) }
             grep { !$auto_type || $_->{auto_type}{enabled} }
             map { $_, $history ? @{$_->{history} || []} : () }
             @{$base->{entries} || []};
@@ -772,12 +710,18 @@ sub find_entries {
     my $query = shift or throw 'Must provide a query';
     my %args = @_;
     my %all_entries = (
-        base    => $args{base},
-        auto_type    => $args{auto_type},
-        search  => $args{search},
-        history => $args{history},
+        base        => $args{base},
+        auto_type   => $args{auto_type},
+        search      => $args{search},
+        history     => $args{history},
     );
-    return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)};
+    my $limit = delete $args{limit};
+    if (defined $limit) {
+        return @{search_limited($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query, $limit)};
+    }
+    else {
+        return @{search($self->all_entries(%all_entries), is_arrayref($query) ? @$query : $query)};
+    }
 }
 
 sub find_entries_simple {
@@ -1062,15 +1006,16 @@ sub resolve_reference {
         P   => 'expanded_password',
         A   => 'expanded_url',
         N   => 'expanded_notes',
-        I   => 'id',
+        I   => 'uuid',
         O   => 'other_strings',
     );
     $wanted     = $fields{$wanted} or return;
     $search_in  = $fields{$search_in} or return;
 
-    my $query = simple_expression_query($text, ($search_in eq 'id' ? 'eq' : '=~'), $search_in);
+    my $query = $search_in eq 'uuid' ? query($search_in => uuid($text))
+                                     : simple_expression_query($text, '=~', $search_in);
 
-    my ($entry) = $self->find_entries($query);
+    my ($entry) = $self->find_entries($query, limit => 1);
     $entry or return;
 
     return $entry->$wanted;
@@ -1099,15 +1044,15 @@ our %PLACEHOLDERS = (
     'URL:PASSWORD'      => sub { (split_url($_[0]->url))[8] },
     'UUID'              => sub { local $_ = format_uuid($_[0]->uuid); s/-//g; $_ },
     'REF:'              => sub { $_[0]->kdbx->resolve_reference($_[1]) },
-    'INTERNETEXPLORER'  => sub { load_optional('File::Which'); File::Which::which('iexplore') },
-    'FIREFOX'           => sub { load_optional('File::Which'); File::Which::which('firefox') },
-    'GOOGLECHROME'      => sub { load_optional('File::Which'); File::Which::which('google-chrome') },
-    'OPERA'             => sub { load_optional('File::Which'); File::Which::which('opera') },
-    'SAFARI'            => sub { load_optional('File::Which'); File::Which::which('safari') },
+    'INTERNETEXPLORER'  => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('iexplore') },
+    'FIREFOX'           => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('firefox') },
+    'GOOGLECHROME'      => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('google-chrome') },
+    'OPERA'             => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('opera') },
+    'SAFARI'            => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('safari') },
     'APPDIR'            => sub { load_optional('FindBin'); $FindBin::Bin },
-    'GROUP'             => sub { $_[0]->parent->name },
+    'GROUP'             => sub { my $p = $_[0]->parent; $p ? $p->name : undef },
     'GROUP_PATH'        => sub { $_[0]->path },
-    'GROUP_NOTES'       => sub { $_[0]->parent->notes },
+    'GROUP_NOTES'       => sub { my $p = $_[0]->parent; $p ? $p->notes : undef },
     # 'GROUP_SEL'
     # 'GROUP_SEL_PATH'
     # 'GROUP_SEL_NOTES'
@@ -1165,11 +1110,11 @@ state. Returns itself to allow method chaining.
 
 sub _safe {
     my $self = shift;
-    $SAFE{refaddr($self)} = shift if @_;
-    $SAFE{refaddr($self)};
+    $SAFE{$self} = shift if @_;
+    $SAFE{$self};
 }
 
-sub _remove_safe { delete $SAFE{refaddr($_[0])} }
+sub _remove_safe { delete $SAFE{$_[0]} }
 
 sub lock {
     my $self = shift;
@@ -1197,13 +1142,6 @@ itself to allow method chaining.
 
 =cut
 
-sub peek {
-    my $self = shift;
-    my $string = shift;
-    my $safe = $self->_safe or return;
-    return $safe->peek($string);
-}
-
 sub unlock {
     my $self = shift;
     my $safe = $self->_safe or return $self;
@@ -1214,14 +1152,43 @@ sub unlock {
     return $self;
 }
 
-# sub unlock_scoped {
-#     my $self = shift;
-#     return if !$self->is_locked;
-#     require Scope::Guard;
-#     my $guard = Scope::Guard->new(sub { $self->lock });
-#     $self->unlock;
-#     return $guard;
-# }
+=method unlock_scoped
+
+    $guard = $kdbx->unlock_scoped;
+
+Unlock a database temporarily, relocking when the guard is released (typically at the end of a scope). Returns
+C<undef> if the database is already unlocked.
+
+See L</lock> and L</unlock>.
+
+=cut
+
+sub unlock_scoped {
+    throw 'Programmer error: Cannot call unlock_scoped in void context' if !defined wantarray;
+    my $self = shift;
+    return if !$self->is_locked;
+    require Scope::Guard;
+    my $guard = Scope::Guard->new(sub { $self->lock });
+    $self->unlock;
+    return $guard;
+}
+
+=method peek
+
+    $string = $kdbx->peek(\%string);
+    $string = $kdbx->peek(\%binary);
+
+Peek at the value of a protected string or binary without unlocking the whole database. The argument can be
+a string or binary hashref as returned by L<File::KDBX::Entry/string> or L<File::KDBX::Entry/binary>.
+
+=cut
+
+sub peek {
+    my $self = shift;
+    my $string = shift;
+    my $safe = $self->_safe or return;
+    return $safe->peek($string);
+}
 
 =method is_locked
 
@@ -1283,8 +1250,8 @@ dumper when loading or saving a KDBX file.
 
 sub key {
     my $self = shift;
-    $KEYS{refaddr($self)} = File::KDBX::Key->new(@_) if @_;
-    $KEYS{refaddr($self)};
+    $KEYS{$self} = File::KDBX::Key->new(@_) if @_;
+    $KEYS{$self};
 }
 
 =method composite_key
@@ -1471,6 +1438,64 @@ sub check {
 
 #########################################################################################
 
+sub _handle_signal {
+    my $self    = shift;
+    my $object  = shift;
+    my $type    = shift;
+
+    my %handlers = (
+        'entry.uuid.changed'    => \&_update_entry_uuid,
+        'group.uuid.changed'    => \&_update_group_uuid,
+    );
+    my $handler = $handlers{$type} or return;
+    $self->$handler($object, @_);
+}
+
+sub _update_group_uuid {
+    my $self        = shift;
+    my $object      = shift;
+    my $new_uuid    = shift;
+    my $old_uuid    = shift // return;
+
+    my $meta = $self->meta;
+    $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+    $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
+    $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // '');
+    $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // '');
+
+    for my $group (@{$self->all_groups}) {
+        $group->last_top_visible_entry($new_uuid) if $old_uuid eq ($group->{last_top_visible_entry} // '');
+        $group->previous_parent_group($new_uuid) if $old_uuid eq ($group->{previous_parent_group} // '');
+    }
+    for my $entry (@{$self->all_entries}) {
+        $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
+    }
+}
+
+sub _update_entry_uuid {
+    my $self        = shift;
+    my $object      = shift;
+    my $new_uuid    = shift;
+    my $old_uuid    = shift // return;
+
+    my $old_pretty = format_uuid($old_uuid);
+    my $new_pretty = format_uuid($new_uuid);
+    my $fieldref_match = qr/\{REF:([TUPANI])\@I:\Q$old_pretty\E\}/is;
+
+    for my $entry (@{$self->all_entries}) {
+        $entry->previous_parent_group($new_uuid) if $old_uuid eq ($entry->{previous_parent_group} // '');
+
+        for my $string (values %{$entry->strings}) {
+            next if !defined $string->{value} || $string->{value} !~ $fieldref_match;
+            my $txn = $entry->begin_work;
+            $string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g;
+            $txn->commit;
+        }
+    }
+}
+
+#########################################################################################
+
 =attr comment
 
 A text string associated with the database. Often unset.
@@ -1659,7 +1684,7 @@ sub TO_JSON { +{%{$_[0]}} }
 1;
 __END__
 
-=for Pod::Coverage TO_JSON
+=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
 
 =head1 SYNOPSIS
 
@@ -2152,4 +2177,27 @@ when trying to use such features with undersized IVs.
 L<File::KeePass> is a much older alternative. It's good but has a backlog of bugs and lacks support for newer
 KDBX features.
 
+=attr sig1
+
+=attr sig2
+
+=attr version
+
+=attr headers
+
+=attr inner_headers
+
+=attr meta
+
+=attr binaries
+
+=attr deleted_objects
+
+=attr raw
+
+    $value = $kdbx->$attr;
+    $kdbx->$attr($value);
+
+Get and set attributes.
+
 =cut
This page took 0.036301 seconds and 4 git commands to generate.