Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Object.pm

   1 package File::KDBX::Object;
   2 # ABSTRACT: A KDBX database object
   3
   4 use warnings;
   5 use strict;
   6
   7 use Devel::GlobalDestruction;
   8 use File::KDBX::Error;
   9 use File::KDBX::Util qw(:uuid);
  10 use Hash::Util::FieldHash qw(fieldhashes);
  11 use Ref::Util qw(is_arrayref is_plain_hashref is_ref);
  12 use Scalar::Util qw(blessed weaken);
  13 use namespace::clean;
  14
  15 our $VERSION = '999.999'; # VERSION
  16
  17 fieldhashes \my (%KDBX, %PARENT);
  18
  19 =method new
  20
  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);
  25
  26 Construct a new KDBX object.
  27
  28 There is a subtlety to take note of. There is a significant difference between:
  29
  30     File::KDBX::Entry->new(username => 'iambatman');
  31
  32 and:
  33
  34     File::KDBX::Entry->new({username => 'iambatman'}); # WRONG
  35
  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).
  41
  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:
  47
  48     File::KDBX::Entry->new(username => 'iambatman');
  49     File::KDBX::Entry->new({strings => {UserName => {value => 'iambatman'}}});
  50
  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.
  55
  56 =cut
  57
  58 sub new {
  59     my $class = shift;
  60
  61     # copy constructor
  62     return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
  63
  64     my $data;
  65     $data = shift if is_plain_hashref($_[0]);
  66
  67     my $kdbx;
  68     $kdbx = shift if @_ % 2 == 1;
  69
  70     my %args = @_;
  71     $args{kdbx} //= $kdbx if defined $kdbx;
  72
  73     my $self = bless $data // {}, $class;
  74     $self->init(%args);
  75     $self->_set_default_attributes if !$data;
  76     return $self;
  77 }
  78
  79 sub _set_default_attributes { die 'Not implemented' }
  80
  81 =method init
  82
  83     $object = $object->init(%attributes);
  84
  85 Called by the constructor to set attributes. You normally should not call this.
  86
  87 =cut
  88
  89 sub init {
  90     my $self = shift;
  91     my %args = @_;
  92
  93     while (my ($key, $val) = each %args) {
  94         if (my $method = $self->can($key)) {
  95             $self->$method($val);
  96         }
  97     }
  98
  99     return $self;
 100 }
 101
 102 =method wrap
 103
 104     $object = File::KDBX::Object->wrap($object);
 105
 106 Ensure that a KDBX object is blessed.
 107
 108 =cut
 109
 110 sub wrap {
 111     my $class   = shift;
 112     my $object  = shift;
 113     return $object if blessed $object && $object->isa($class);
 114     return $class->new(@_, @$object) if is_arrayref($object);
 115     return $class->new($object, @_);
 116 }
 117
 118 =method label
 119
 120     $label = $object->label;
 121     $object->label($label);
 122
 123 Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label
 124 is its title string. For a group, the label is its name.
 125
 126 =cut
 127
 128 sub label { die 'Not implemented' }
 129
 130 =method clone
 131
 132     $object_copy = $object->clone;
 133     $object_copy = File::KDBX::Object->new($object);
 134
 135 Make a clone of an object. By default the clone is indeed an exact copy that is associated with the same
 136 database but not actually included in the object tree (i.e. it has no parent). Some options are allowed to
 137 get different effects:
 138
 139 =for :list
 140 * C<new_uuid> - If set, generate a new UUID for the copy (default: false)
 141 * C<parent> - If set, add the copy to the same parent group, if any (default: false)
 142 * C<relabel> - If set, append " - Copy" to the object's title or name (default: false)
 143 * C<entries> - If set, copy child entries, if any (default: true)
 144 * C<groups> - If set, copy child groups, if any (default: true)
 145 * C<history> - If set, copy entry history, if any (default: true)
 146 * C<reference_password> - Toggle whether or not cloned entry's Password string should be set as a field
 147     reference to the original entry's Password string (default: false)
 148 * C<reference_username> - Toggle whether or not cloned entry's UserName string should be set as a field
 149     reference to the original entry's UserName string (default: false)
 150
 151 =cut
 152
 153 my %CLONE = (entries => 1, groups => 1, history => 1);
 154 sub clone {
 155     my $self = shift;
 156     my %args = @_;
 157
 158     local $CLONE{new_uuid}              = $args{new_uuid} // $args{parent} // 0;
 159     local $CLONE{entries}               = $args{entries}  // 1;
 160     local $CLONE{groups}                = $args{groups}   // 1;
 161     local $CLONE{history}               = $args{history}  // 1;
 162     local $CLONE{reference_password}    = $args{reference_password} // 0;
 163     local $CLONE{reference_username}    = $args{reference_username} // 0;
 164
 165     require Storable;
 166     my $copy = Storable::dclone($self);
 167
 168     if ($args{relabel} and my $label = $self->label) {
 169         $copy->label("$label - Copy");
 170     }
 171     if ($args{parent} and my $parent = $self->parent) {
 172         $parent->add_object($copy);
 173     }
 174
 175     return $copy;
 176 }
 177
 178 sub STORABLE_freeze {
 179     my $self    = shift;
 180     my $cloning = shift;
 181
 182     my $copy = {%$self};
 183     delete $copy->{entries} if !$CLONE{entries};
 184     delete $copy->{groups}  if !$CLONE{groups};
 185     delete $copy->{history} if !$CLONE{history};
 186
 187     return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy;
 188 }
 189
 190 sub STORABLE_thaw {
 191     my $self    = shift;
 192     my $cloning = shift;
 193     my $addr    = shift;
 194     my $copy    = shift;
 195
 196     @$self{keys %$copy} = values %$copy;
 197
 198     if ($cloning) {
 199         my $kdbx = $KDBX{$addr};
 200         $self->kdbx($kdbx) if $kdbx;
 201     }
 202
 203     if (defined $self->{uuid}) {
 204         if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) {
 205             my $uuid = format_uuid($self->{uuid});
 206             my $clone_obj = do {
 207                 local $CLONE{new_uuid}              = 0;
 208                 local $CLONE{entries}               = 1;
 209                 local $CLONE{groups}                = 1;
 210                 local $CLONE{history}               = 1;
 211                 local $CLONE{reference_password}    = 0;
 212                 local $CLONE{reference_username}    = 0;
 213                 bless Storable::dclone({%$copy}), 'File::KDBX::Entry';
 214             };
 215             my $txn = $self->begin_work($clone_obj);
 216             if ($CLONE{reference_password}) {
 217                 $self->password("{REF:P\@I:$uuid}");
 218             }
 219             if ($CLONE{reference_username}) {
 220                 $self->username("{REF:U\@I:$uuid}");
 221             }
 222             $txn->commit;
 223         }
 224         $self->uuid(generate_uuid) if $CLONE{new_uuid};
 225     }
 226 }
 227
 228 =attr kdbx
 229
 230     $kdbx = $object->kdbx;
 231     $object->kdbx($kdbx);
 232
 233 Get or set the L<File::KDBX> instance associated with this object.
 234
 235 =cut
 236
 237 sub kdbx {
 238     my $self = shift;
 239     $self = $self->new if !ref $self;
 240     if (@_) {
 241         if (my $kdbx = shift) {
 242             $KDBX{$self} = $kdbx;
 243             weaken $KDBX{$self};
 244         }
 245         else {
 246             delete $KDBX{$self};
 247         }
 248     }
 249     $KDBX{$self} or throw 'Object is disassociated from a KDBX database', object => $self;
 250 }
 251
 252 =method id
 253
 254     $string_uuid = $object->id;
 255     $string_uuid = $object->id($delimiter);
 256
 257 Get the unique identifier for this object as a B<formatted> UUID string, typically for display purposes. You
 258 could use this to compare with other identifiers formatted with the same delimiter, but it is more efficient
 259 to use the raw UUID for that purpose (see L</uuid>).
 260
 261 A delimiter can optionally be provided to break up the UUID string visually. See
 262 L<File::KDBX::Util/format_uuid>.
 263
 264 =cut
 265
 266 sub id { format_uuid(shift->uuid, @_) }
 267
 268 =method group
 269
 270 =method parent
 271
 272     $group = $object->group;
 273     # OR equivalently
 274     $group = $object->parent;
 275
 276 Get the parent group to which an object belongs or C<undef> if it belongs to no group.
 277
 278 =cut
 279
 280 sub group {
 281     my $self = shift;
 282     my $addr = Hash::Util::FieldHash::id($self);
 283     if (my $group = $PARENT{$self}) {
 284         my $method = $self->_parent_container;
 285         for my $object (@{$group->$method}) {
 286             return $group if $addr == Hash::Util::FieldHash::id($object);
 287         }
 288         delete $PARENT{$self};
 289     }
 290     # always get lineage from root to leaf because the other way requires parent, so it would be recursive
 291     my $lineage = $self->kdbx->_trace_lineage($self) or return;
 292     my $group = pop @$lineage or return;
 293     $PARENT{$self} = $group; weaken $PARENT{$self};
 294     return $group;
 295 }
 296
 297 sub parent { shift->group(@_) }
 298
 299 sub _set_group {
 300     my $self = shift;
 301     if (my $parent = shift) {
 302         $PARENT{$self} = $parent;
 303         weaken $PARENT{$self};
 304     }
 305     else {
 306         delete $PARENT{$self};
 307     }
 308     return $self;
 309 }
 310
 311 ### Name of the parent attribute expected to contain the object
 312 sub _parent_container { die 'Not implemented' }
 313
 314 =method lineage
 315
 316     \@lineage = $object->lineage;
 317     \@lineage = $object->lineage($base_group);
 318
 319 Get the direct line of ancestors from C<$base_group> (default: the root group) to an object. The lineage
 320 includes the base group but I<not> the target object. Returns C<undef> if the target is not in the database
 321 structure. Returns an empty arrayref is the object itself is a root group.
 322
 323 =cut
 324
 325 sub lineage {
 326     my $self = shift;
 327     my $base = shift;
 328
 329     my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0;
 330
 331     # try leaf to root
 332     my @path;
 333     my $o = $self;
 334     while ($o = $o->parent) {
 335         unshift @path, $o;
 336         last if $base_addr == Hash::Util::FieldHash::id($o);
 337     }
 338     return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root);
 339
 340     # try root to leaf
 341     return $self->kdbx->_trace_lineage($self, $base);
 342 }
 343
 344 =method remove
 345
 346     $object = $object->remove;
 347
 348 Remove the object from the database. If the object is a group, all contained objects are removed as well.
 349
 350 =cut
 351
 352 sub remove {
 353     my $self = shift;
 354     my $parent = $self->parent;
 355     $parent->remove_object($self) if $parent;
 356     return $self;
 357 }
 358
 359 =method tag_list
 360
 361     @tags = $entry->tag_list;
 362
 363 Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace.
 364
 365 =cut
 366
 367 sub tag_list {
 368     my $self = shift;
 369     return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
 370 }
 371
 372 =method custom_icon
 373
 374     $image_data = $object->custom_icon;
 375     $image_data = $object->custom_icon($image_data, %attributes);
 376
 377 Get or set an icon image. Returns C<undef> if there is no custom icon set. Setting a custom icon will change
 378 the L</custom_icon_uuid> attribute.
 379
 380 Custom icon attributes (supported in KDBX4.1 and greater):
 381
 382 =for :list
 383 * C<name> - Name of the icon (text)
 384 * C<last_modification_time> - Just what it says (datetime)
 385
 386 =cut
 387
 388 sub custom_icon {
 389     my $self = shift;
 390     my $kdbx = $self->kdbx;
 391     if (@_) {
 392         my $img = shift;
 393         my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
 394         $self->icon_id(0) if $uuid;
 395         $self->custom_icon_uuid($uuid);
 396         return $img;
 397     }
 398     return $kdbx->custom_icon_data($self->custom_icon_uuid);
 399 }
 400
 401 =method custom_data
 402
 403     \%all_data = $object->custom_data;
 404     $object->custom_data(\%all_data);
 405
 406     \%data = $object->custom_data($key);
 407     $object->custom_data($key => \%data);
 408     $object->custom_data(%data);
 409     $object->custom_data(key => $value, %data);
 410
 411 Get and set custom data. Custom data is metadata associated with an object.
 412
 413 Each data item can have a few attributes associated with it.
 414
 415 =for :list
 416 * C<key> - A unique text string identifier used to look up the data item (required)
 417 * C<value> - A text string value (required)
 418 * C<last_modification_time> (optional, KDBX4.1+)
 419
 420 =cut
 421
 422 sub custom_data {
 423     my $self = shift;
 424     $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
 425     return $self->{custom_data} //= {} if !@_;
 426
 427     my %args = @_     == 2 ? (key => shift, value => shift)
 428              : @_ % 2 == 1 ? (key => shift, @_) : @_;
 429
 430     if (!$args{key} && !$args{value}) {
 431         my %standard = (key => 1, value => 1, last_modification_time => 1);
 432         my @other_keys = grep { !$standard{$_} } keys %args;
 433         if (@other_keys == 1) {
 434             my $key = $args{key} = $other_keys[0];
 435             $args{value} = delete $args{$key};
 436         }
 437     }
 438
 439     my $key = $args{key} or throw 'Must provide a custom_data key to access';
 440
 441     return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
 442
 443     while (my ($field, $value) = each %args) {
 444         $self->{custom_data}{$key}{$field} = $value;
 445     }
 446     return $self->{custom_data}{$key};
 447 }
 448
 449 =method custom_data_value
 450
 451     $value = $object->custom_data_value($key);
 452
 453 Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of
 454 attributes. This is a shortcut for:
 455
 456     my $data = $object->custom_data($key);
 457     my $value = defined $data ? $data->{value} : undef;
 458
 459 =cut
 460
 461 sub custom_data_value {
 462     my $self = shift;
 463     my $data = $self->custom_data(@_) // return undef;
 464     return $data->{value};
 465 }
 466
 467 sub _wrap_group {
 468     my $self  = shift;
 469     my $group = shift;
 470     require File::KDBX::Group;
 471     return File::KDBX::Group->wrap($group, $KDBX{$self});
 472 }
 473
 474 sub _wrap_entry {
 475     my $self  = shift;
 476     my $entry = shift;
 477     require File::KDBX::Entry;
 478     return File::KDBX::Entry->wrap($entry, $KDBX{$self});
 479 }
 480
 481 sub TO_JSON { +{%{$_[0]}} }
 482
 483 1;
 484 __END__
 485
 486 =for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
 487
 488 =head1 DESCRIPTION
 489
 490 KDBX is an object database. This abstract class represents an object. You should not use this class directly
 491 but instead use its subclasses:
 492
 493 =for :list
 494 * L<File::KDBX::Entry>
 495 * L<File::KDBX::Group>
 496
 497 There is some functionality shared by both types of objects, and that's what this class provides.
 498
 499 =cut