1 package File
::KDBX
::Object
;
2 # ABSTRACT: A KDBX database object
7 use Devel
::GlobalDestruction
;
9 use File
::KDBX
::Util
qw(:uuid);
10 use Ref
::Util
qw(is_arrayref is_plain_hashref is_ref);
11 use Scalar
::Util
qw(blessed refaddr weaken);
14 our $VERSION = '999.999'; # VERSION
21 $object = File
::KDBX
::Object-
>new;
22 $object = File
::KDBX
::Object-
>new(%attributes);
23 $object = File
::KDBX
::Object-
>new(\
%data);
24 $object = File
::KDBX
::Object-
>new(\
%data, $kdbx);
26 Construct a new KDBX object
.
28 There
is a subtlety to
take note of
. There
is a significant difference between
:
30 File
::KDBX
::Entry-
>new(username
=> 'iambatman');
34 File
::KDBX
::Entry-
>new({username
=> 'iambatman'}); # WRONG
36 In the first
, an empty object
is first created
and then initialized with whatever I
<attributes
> are
given. In
37 the second
, a hashref
is blessed
and essentially becomes the object
. The significance
is that the hashref
38 key-value pairs will remain as-is so the structure
is expected to adhere to the shape of a raw B
<Object
>
39 (which varies based on the type of object
), whereas with the first the attributes will set the structure
in
40 the correct way
(just like using the object accessors
/ getters / setters
).
42 The second example isn
't I<generally> wrong -- this type of construction is supported for a reason, to allow
43 for working with KDBX objects at a low level -- but it is wrong in this specific case only because
44 C<< {username => $str} >> isn't a valid raw KDBX entry object
. The L
</username
> attribute
is really a proxy
45 for the C
<UserName
> string
, so the equivalent raw entry object should be
46 C
<< {strings
=> {UserName
=> {value
=> $str}}} >>. These are roughly equivalent
:
48 File
::KDBX
::Entry-
>new(username
=> 'iambatman');
49 File
::KDBX
::Entry-
>new({strings
=> {UserName
=> {value
=> 'iambatman'}}});
51 If this explanation went over your head
, that
's fine. Just stick with the attributes since they are typically
52 easier to use correctly and provide the most convenience. If in the future you think of some kind of KDBX
53 object manipulation you want to do that isn't supported by the accessors
and methods
, just know you I
<can
>
54 access an object
's data directly.
62 return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
65 $data = shift if is_plain_hashref($_[0]);
68 $kdbx = shift if @_ % 2 == 1;
71 $args{kdbx} //= $kdbx if defined $kdbx;
73 my $self = bless $data // {}, $class;
75 $self->_set_default_attributes if !$data;
79 sub _set_default_attributes { die 'Not implemented
' }
83 $object = $object->init(%attributes);
85 Called by the constructor to set attributes. You normally should not call this.
93 while (my ($key, $val) = each %args) {
94 if (my $method = $self->can($key)) {
103 return if in_global_destruction;
105 delete $KDBX{refaddr($self)};
106 delete $PARENT{refaddr($self)};
111 $object = File::KDBX::Object->wrap($object);
113 Ensure that a KDBX object is blessed.
120 return $object if blessed $object && $object->isa($class);
121 return $class->new(@_, @$object) if is_arrayref($object);
122 return $class->new($object, @_);
127 $label = $object->label;
128 $object->label($label);
130 Get or set the object's label
, a text string that can act as a non-unique identifier
. For an entry
, the label
131 is its title string
. For a group
, the label
is its name
.
135 sub label
{ die 'Not implemented' }
139 $object_copy = $object->clone;
140 $object_copy = File
::KDBX
::Object-
>new($object);
142 Make a clone of an object
. By
default the clone
is indeed an exact copy that
is associated with the same
143 database but
not actually included
in the object tree
(i
.e
. it
has no parent
). Some options are allowed to
144 get different effects
:
147 * C<new_uuid> - If set, generate a new UUID for the copy (default: false)
148 * C<parent> - If set, add the copy to the same parent group, if any (default: false)
149 * C<relabel> - If set, append " - Copy" to the object's title or name (default: false)
150 * C<entries> - If set, copy child entries, if any (default: true)
151 * C<groups> - If set, copy child groups, if any (default: true)
152 * C<history> - If set, copy entry history, if any (default: true)
153 * C<reference_password> - Toggle whether or not cloned entry's Password string should be set as a field
154 reference to the original entry's Password string (default: false)
155 * C<reference_username> - Toggle whether or not cloned entry's UserName string should be set as a field
156 reference to the original entry's UserName string (default: false)
160 my %CLONE = (entries
=> 1, groups
=> 1, history
=> 1);
165 local $CLONE{new_uuid
} = $args{new_uuid
} // $args{parent
} // 0;
166 local $CLONE{entries
} = $args{entries
} // 1;
167 local $CLONE{groups
} = $args{groups
} // 1;
168 local $CLONE{history
} = $args{history
} // 1;
169 local $CLONE{reference_password
} = $args{reference_password
} // 0;
170 local $CLONE{reference_username
} = $args{reference_username
} // 0;
173 my $copy = Storable
::dclone
($self);
175 if ($args{relabel
} and my $label = $self->label) {
176 $copy->label("$label - Copy");
178 if ($args{parent
} and my $parent = $self->parent) {
179 $parent->add_object($copy);
185 sub STORABLE_freeze
{
190 delete $copy->{entries
} if !$CLONE{entries
};
191 delete $copy->{groups
} if !$CLONE{groups
};
192 delete $copy->{history
} if !$CLONE{history
};
194 return refaddr
($self) || '', $copy;
203 @$self{keys %$clone} = values %$clone;
205 my $kdbx = $KDBX{$addr};
206 $self->kdbx($kdbx) if $kdbx;
208 if (defined $self->{uuid
}) {
209 if (($CLONE{reference_password
} || $CLONE{reference_username
}) && $self->can('strings')) {
210 my $uuid = format_uuid
($self->{uuid
});
212 local $CLONE{new_uuid
} = 0;
213 local $CLONE{entries
} = 1;
214 local $CLONE{groups
} = 1;
215 local $CLONE{history
} = 1;
216 local $CLONE{reference_password
} = 0;
217 local $CLONE{reference_username
} = 0;
218 bless Storable
::dclone
({%$clone}), 'File::KDBX::Entry';
220 my $txn = $self->begin_work($clone_obj);
221 if ($CLONE{reference_password
}) {
222 $self->password("{REF:P\@I:$uuid}");
224 if ($CLONE{reference_username
}) {
225 $self->username("{REF:U\@I:$uuid}");
229 $self->uuid(generate_uuid
) if $CLONE{new_uuid
};
235 $kdbx = $object->kdbx;
236 $object->kdbx($kdbx);
238 Get
or set the L
<File
::KDBX
> instance associated with this object
.
244 $self = $self->new if !ref $self;
245 my $addr = refaddr
($self);
247 $KDBX{$addr} = shift;
248 if (defined $KDBX{$addr}) {
255 $KDBX{$addr} or throw
'Object is disassociated from a KDBX database', object
=> $self;
260 $string_uuid = $object->id;
261 $string_uuid = $object->id($delimiter);
263 Get the unique identifier
for this object as a B
<formatted
> UUID string
, typically
for display purposes
. You
264 could
use this to compare with other identifiers formatted with the same delimiter
, but it
is more efficient
265 to
use the raw UUID
for that purpose
(see L
</uuid
>).
267 A delimiter can optionally be provided to
break up the UUID string visually
. See
268 L
<File
::KDBX
::Util
/format_uuid
>.
272 sub id
{ format_uuid
(shift-
>uuid, @_) }
278 $group = $object->group;
280 $group = $object->parent;
282 Get the parent group to which an object belongs
or C
<undef> if it belongs to
no group
.
288 my $addr = refaddr
($self);
289 if (my $group = $PARENT{$addr}) {
290 my $method = $self->_parent_container;
291 for my $object (@{$group->$method}) {
292 return $group if $addr == refaddr
($object);
294 delete $PARENT{$addr};
296 # always get lineage from root to leaf because the other way requires parent, so it would be recursive
297 my $lineage = $self->kdbx->_trace_lineage($self) or return;
298 my $group = pop @$lineage or return;
299 $PARENT{$addr} = $group; weaken
$PARENT{$addr};
303 sub parent
{ shift-
>group(@_) }
307 if (my $parent = shift) {
308 $PARENT{refaddr
($self)} = $parent;
311 delete $PARENT{refaddr
($self)};
316 ### Name of the parent attribute expected to contain the object
317 sub _parent_container
{ die 'Not implemented' }
321 \
@lineage = $object->lineage;
322 \
@lineage = $object->lineage($base_group);
324 Get the direct line of ancestors from C
<$base_group> (default: the root group
) to an object
. The lineage
325 includes the base group but I
<not> the target object
. Returns C
<undef> if the target
is not in the database
326 structure
. Returns an empty arrayref
is the object itself
is a root group
.
334 my $base_addr = $base ? refaddr
($base) : 0;
339 while ($o = $o->parent) {
341 last if $base_addr == refaddr
($o);
343 return \
@path if @path && ($base_addr == refaddr
($path[0]) || $path[0]->is_root);
346 return $self->kdbx->_trace_lineage($self, $base);
351 $object = $object->remove;
353 Remove the object from the database
. If the object
is a group
, all contained objects are removed as well
.
359 my $parent = $self->parent;
360 $parent->remove_object($self) if $parent;
366 @tags = $entry->tag_list;
368 Get a list of tags
, split from L
</tag
> using delimiters C
<,>, C
<.>, C
<:>, C
<;> and whitespace
.
374 return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim
($self->tags) // '');
379 $image_data = $object->custom_icon;
380 $image_data = $object->custom_icon($image_data, %attributes);
382 Get
or set an icon image
. Returns C
<undef> if there
is no custom icon set
. Setting a custom icon will change
383 the L
</custom_icon_uuid
> attribute
.
385 Custom icon attributes
(supported
in KDBX4
.1
and greater
):
388 * C<name> - Name of the icon (text)
389 * C<last_modification_time> - Just what it says (datetime)
395 my $kdbx = $self->kdbx;
398 my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
399 $self->icon_id(0) if $uuid;
400 $self->custom_icon_uuid($uuid);
403 return $kdbx->custom_icon_data($self->custom_icon_uuid);
408 \
%all_data = $object->custom_data;
409 $object->custom_data(\
%all_data);
411 \
%data = $object->custom_data($key);
412 $object->custom_data($key => \
%data);
413 $object->custom_data(%data);
414 $object->custom_data(key
=> $value, %data);
416 Get
and set custom data
. Custom data
is metadata associated with an object
.
418 Each data item can have a few attributes associated with it
.
421 * C<key> - A unique text string identifier used to look up the data item (required)
422 * C<value> - A text string value (required)
423 * C<last_modification_time> (optional, KDBX4.1+)
429 $self->{custom_data
} = shift if @_ == 1 && is_plain_hashref
($_[0]);
430 return $self->{custom_data
} //= {} if !@_;
432 my %args = @_ == 2 ? (key
=> shift, value
=> shift)
433 : @_ % 2 == 1 ? (key
=> shift, @_) : @_;
435 if (!$args{key
} && !$args{value
}) {
436 my %standard = (key
=> 1, value
=> 1, last_modification_time
=> 1);
437 my @other_keys = grep { !$standard{$_} } keys %args;
438 if (@other_keys == 1) {
439 my $key = $args{key
} = $other_keys[0];
440 $args{value
} = delete $args{$key};
444 my $key = $args{key
} or throw
'Must provide a custom_data key to access';
446 return $self->{custom_data
}{$key} = $args{value
} if is_plain_hashref
($args{value
});
448 while (my ($field, $value) = each %args) {
449 $self->{custom_data
}{$key}{$field} = $value;
451 return $self->{custom_data
}{$key};
454 =method custom_data_value
456 $value = $object->custom_data_value($key);
458 Exactly the same as L
</custom_data
> except returns just the custom data
's value rather than a structure of
459 attributes. This is a shortcut for:
461 my $data = $object->custom_data($key);
462 my $value = defined $data ? $data->{value} : undef;
466 sub custom_data_value {
468 my $data = $self->custom_data(@_) // return undef;
469 return $data->{value};
475 require File::KDBX::Group;
476 return File::KDBX::Group->wrap($group, $KDBX{refaddr($self)});
482 require File::KDBX::Entry;
483 return File::KDBX::Entry->wrap($entry, $KDBX{refaddr($self)});
486 sub TO_JSON { +{%{$_[0]}} }
491 =for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
495 KDBX is an object database. This abstract class represents an object. You should not use this class directly
496 but instead use its subclasses:
499 * L<File::KDBX::Entry>
500 * L<File::KDBX::Group>
502 There is some functionality shared by both types of objects, and that's what this
class provides
.