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 Ref::Util qw(is_arrayref is_plain_hashref is_ref);
  11 use Scalar::Util qw(blessed refaddr weaken);
  12 use namespace::clean;
  13
  14 our $VERSION = '999.999'; # VERSION
  15
  16 my %KDBX;
  17 my %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 sub DESTROY {
 103     return if in_global_destruction;
 104     my $self = shift;
 105     delete $KDBX{refaddr($self)};
 106     delete $PARENT{refaddr($self)};
 107 }
 108
 109 =method wrap
 110
 111     $object = File::KDBX::Object->wrap($object);
 112
 113 Ensure that a KDBX object is blessed.
 114
 115 =cut
 116
 117 sub wrap {
 118     my $class   = shift;
 119     my $object  = shift;
 120     return $object if blessed $object && $object->isa($class);
 121     return $class->new(@_, @$object) if is_arrayref($object);
 122     return $class->new($object, @_);
 123 }
 124
 125 =method label
 126
 127     $label = $object->label;
 128     $object->label($label);
 129
 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.
 132
 133 =cut
 134
 135 sub label { die 'Not implemented' }
 136
 137 =method clone
 138
 139     $object_copy = $object->clone;
 140     $object_copy = File::KDBX::Object->new($object);
 141
 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:
 145
 146 =for :list
 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)
 157
 158 =cut
 159
 160 my %CLONE = (entries => 1, groups => 1, history => 1);
 161 sub clone {
 162     my $self = shift;
 163     my %args = @_;
 164
 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;
 171
 172     require Storable;
 173     my $copy = Storable::dclone($self);
 174
 175     if ($args{relabel} and my $label = $self->label) {
 176         $copy->label("$label - Copy");
 177     }
 178     if ($args{parent} and my $parent = $self->parent) {
 179         $parent->add_object($copy);
 180     }
 181
 182     return $copy;
 183 }
 184
 185 sub STORABLE_freeze {
 186     my $self    = shift;
 187     my $cloning = shift;
 188
 189     my $copy = {%$self};
 190     delete $copy->{entries} if !$CLONE{entries};
 191     delete $copy->{groups}  if !$CLONE{groups};
 192     delete $copy->{history} if !$CLONE{history};
 193
 194     return refaddr($self) || '', $copy;
 195 }
 196
 197 sub STORABLE_thaw {
 198     my $self    = shift;
 199     my $cloning = shift;
 200     my $addr    = shift;
 201     my $clone   = shift;
 202
 203     @$self{keys %$clone} = values %$clone;
 204
 205     my $kdbx = $KDBX{$addr};
 206     $self->kdbx($kdbx) if $kdbx;
 207
 208     if (defined $self->{uuid}) {
 209         if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) {
 210             my $uuid = format_uuid($self->{uuid});
 211             my $clone_obj = do {
 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';
 219             };
 220             my $txn = $self->begin_work($clone_obj);
 221             if ($CLONE{reference_password}) {
 222                 $self->password("{REF:P\@I:$uuid}");
 223             }
 224             if ($CLONE{reference_username}) {
 225                 $self->username("{REF:U\@I:$uuid}");
 226             }
 227             $txn->commit;
 228         }
 229         $self->uuid(generate_uuid) if $CLONE{new_uuid};
 230     }
 231 }
 232
 233 =attr kdbx
 234
 235     $kdbx = $object->kdbx;
 236     $object->kdbx($kdbx);
 237
 238 Get or set the L<File::KDBX> instance associated with this object.
 239
 240 =cut
 241
 242 sub kdbx {
 243     my $self = shift;
 244     $self = $self->new if !ref $self;
 245     my $addr = refaddr($self);
 246     if (@_) {
 247         $KDBX{$addr} = shift;
 248         if (defined $KDBX{$addr}) {
 249             weaken $KDBX{$addr};
 250         }
 251         else {
 252             delete $KDBX{$addr};
 253         }
 254     }
 255     $KDBX{$addr} or throw 'Object is disassociated from a KDBX database', object => $self;
 256 }
 257
 258 =method id
 259
 260     $string_uuid = $object->id;
 261     $string_uuid = $object->id($delimiter);
 262
 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>).
 266
 267 A delimiter can optionally be provided to break up the UUID string visually. See
 268 L<File::KDBX::Util/format_uuid>.
 269
 270 =cut
 271
 272 sub id { format_uuid(shift->uuid, @_) }
 273
 274 =method group
 275
 276 =method parent
 277
 278     $group = $object->group;
 279     # OR equivalently
 280     $group = $object->parent;
 281
 282 Get the parent group to which an object belongs or C<undef> if it belongs to no group.
 283
 284 =cut
 285
 286 sub group {
 287     my $self = shift;
 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);
 293         }
 294         delete $PARENT{$addr};
 295     }
 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};
 300     return $group;
 301 }
 302
 303 sub parent { shift->group(@_) }
 304
 305 sub _set_group {
 306     my $self = shift;
 307     if (my $parent = shift) {
 308         $PARENT{refaddr($self)} = $parent;
 309     }
 310     else {
 311         delete $PARENT{refaddr($self)};
 312     }
 313     return $self;
 314 }
 315
 316 ### Name of the parent attribute expected to contain the object
 317 sub _parent_container { die 'Not implemented' }
 318
 319 =method lineage
 320
 321     \@lineage = $object->lineage;
 322     \@lineage = $object->lineage($base_group);
 323
 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.
 327
 328 =cut
 329
 330 sub lineage {
 331     my $self = shift;
 332     my $base = shift;
 333
 334     my $base_addr = $base ? refaddr($base) : 0;
 335
 336     # try leaf to root
 337     my @path;
 338     my $o = $self;
 339     while ($o = $o->parent) {
 340         unshift @path, $o;
 341         last if $base_addr == refaddr($o);
 342     }
 343     return \@path if @path && ($base_addr == refaddr($path[0]) || $path[0]->is_root);
 344
 345     # try root to leaf
 346     return $self->kdbx->_trace_lineage($self, $base);
 347 }
 348
 349 =method remove
 350
 351     $object = $object->remove;
 352
 353 Remove the object from the database. If the object is a group, all contained objects are removed as well.
 354
 355 =cut
 356
 357 sub remove {
 358     my $self = shift;
 359     my $parent = $self->parent;
 360     $parent->remove_object($self) if $parent;
 361     return $self;
 362 }
 363
 364 =method tag_list
 365
 366     @tags = $entry->tag_list;
 367
 368 Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace.
 369
 370 =cut
 371
 372 sub tag_list {
 373     my $self = shift;
 374     return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
 375 }
 376
 377 =method custom_icon
 378
 379     $image_data = $object->custom_icon;
 380     $image_data = $object->custom_icon($image_data, %attributes);
 381
 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.
 384
 385 Custom icon attributes (supported in KDBX4.1 and greater):
 386
 387 =for :list
 388 * C<name> - Name of the icon (text)
 389 * C<last_modification_time> - Just what it says (datetime)
 390
 391 =cut
 392
 393 sub custom_icon {
 394     my $self = shift;
 395     my $kdbx = $self->kdbx;
 396     if (@_) {
 397         my $img = shift;
 398         my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
 399         $self->icon_id(0) if $uuid;
 400         $self->custom_icon_uuid($uuid);
 401         return $img;
 402     }
 403     return $kdbx->custom_icon_data($self->custom_icon_uuid);
 404 }
 405
 406 =method custom_data
 407
 408     \%all_data = $object->custom_data;
 409     $object->custom_data(\%all_data);
 410
 411     \%data = $object->custom_data($key);
 412     $object->custom_data($key => \%data);
 413     $object->custom_data(%data);
 414     $object->custom_data(key => $value, %data);
 415
 416 Get and set custom data. Custom data is metadata associated with an object.
 417
 418 Each data item can have a few attributes associated with it.
 419
 420 =for :list
 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+)
 424
 425 =cut
 426
 427 sub custom_data {
 428     my $self = shift;
 429     $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
 430     return $self->{custom_data} //= {} if !@_;
 431
 432     my %args = @_     == 2 ? (key => shift, value => shift)
 433              : @_ % 2 == 1 ? (key => shift, @_) : @_;
 434
 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};
 441         }
 442     }
 443
 444     my $key = $args{key} or throw 'Must provide a custom_data key to access';
 445
 446     return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
 447
 448     while (my ($field, $value) = each %args) {
 449         $self->{custom_data}{$key}{$field} = $value;
 450     }
 451     return $self->{custom_data}{$key};
 452 }
 453
 454 =method custom_data_value
 455
 456     $value = $object->custom_data_value($key);
 457
 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:
 460
 461     my $data = $object->custom_data($key);
 462     my $value = defined $data ? $data->{value} : undef;
 463
 464 =cut
 465
 466 sub custom_data_value {
 467     my $self = shift;
 468     my $data = $self->custom_data(@_) // return undef;
 469     return $data->{value};
 470 }
 471
 472 sub _wrap_group {
 473     my $self  = shift;
 474     my $group = shift;
 475     require File::KDBX::Group;
 476     return File::KDBX::Group->wrap($group, $KDBX{refaddr($self)});
 477 }
 478
 479 sub _wrap_entry {
 480     my $self  = shift;
 481     my $entry = shift;
 482     require File::KDBX::Entry;
 483     return File::KDBX::Entry->wrap($entry, $KDBX{refaddr($self)});
 484 }
 485
 486 sub TO_JSON { +{%{$_[0]}} }
 487
 488 1;
 489 __END__
 490
 491 =for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
 492
 493 =head1 DESCRIPTION
 494
 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:
 497
 498 =for :list
 499 * L<File::KDBX::Entry>
 500 * L<File::KDBX::Group>
 501
 502 There is some functionality shared by both types of objects, and that's what this class provides.
 503
 504 =cut