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
  18 =method new
  19
  20     $object = File::KDBX::Entry->new;
  21     $object = File::KDBX::Entry->new(%attributes);
  22     $object = File::KDBX::Entry->new($data);
  23     $object = File::KDBX::Entry->new($data, $kdbx);
  24
  25 Construct a new KDBX object.
  26
  27 There is a subtlety to take note of. There is a significant difference between:
  28
  29     File::KDBX::Entry->new(username => 'iambatman');
  30
  31 and:
  32
  33     File::KDBX::Entry->new({username => 'iambatman'}); # WRONG
  34
  35 In the first, an empty entry is first created and then initialized with whatever I<attributes> are given. In
  36 the second, a hashref is blessed and essentially becomes the entry. The significance is that the hashref
  37 key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B<Entry>,
  38 whereas with the first the attributes will set the structure in the correct way (just like using the entry
  39 object accessors / getters / setters).
  40
  41 The second example isn't I<generally> wrong -- this type of construction is supported for a reason, to allow
  42 for working with KDBX objects at a low level -- but it is wrong in this specific case only because
  43 C<< {username => $str} >> isn't a valid raw KDBX entry object. The L</username> attribute is really a proxy
  44 for the C<UserName> string, so the equivalent raw entry object should be
  45 C<< {strings => {UserName => {value => $str}}} >>. These are roughly equivalent:
  46
  47     File::KDBX::Entry->new(username => 'iambatman');
  48     File::KDBX::Entry->new({strings => {UserName => {value => 'iambatman'}}});
  49
  50 If this explanation went over your head, that's fine. Just stick with the attributes since they are typically
  51 easier to use correctly and provide the most convenience. If in the future you think of some kind of KDBX
  52 object manipulation you want to do that isn't supported by the accessors and methods, just know you I<can>
  53 access an object's data directly.
  54
  55 =cut
  56
  57 sub new {
  58     my $class = shift;
  59
  60     # copy constructor
  61     return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
  62
  63     my $data;
  64     $data = shift if is_plain_hashref($_[0]);
  65
  66     my $kdbx;
  67     $kdbx = shift if @_ % 2 == 1;
  68
  69     my %args = @_;
  70     $args{kdbx} //= $kdbx if defined $kdbx;
  71
  72     my $self = bless $data // {}, $class;
  73     $self->init(%args);
  74     $self->_set_default_attributes if !$data;
  75     return $self;
  76 }
  77
  78 sub init {
  79     my $self = shift;
  80     my %args = @_;
  81
  82     while (my ($key, $val) = each %args) {
  83         if (my $method = $self->can($key)) {
  84             $self->$method($val);
  85         }
  86     }
  87
  88     return $self;
  89 }
  90
  91 sub DESTROY {
  92     return if in_global_destruction;
  93     my $self = shift;
  94     delete $KDBX{refaddr($self)};
  95 }
  96
  97 =method wrap
  98
  99     $object = File::KDBX::Object->wrap($object);
 100
 101 Ensure that a KDBX object is blessed.
 102
 103 =cut
 104
 105 sub wrap {
 106     my $class = shift;
 107     my $object = shift;
 108     return $object if blessed $object && $object->isa($class);
 109     return $class->new(@_, @$object) if is_arrayref($object);
 110     return $class->new($object, @_);
 111 }
 112
 113 =method label
 114
 115     $label = $object->label;
 116     $object->label($label);
 117
 118 Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label
 119 is its title. For a group, the label is its name.
 120
 121 =cut
 122
 123 sub label { die "Not implemented" }
 124
 125 =method clone
 126
 127     $object_copy = $object->clone;
 128     $object_copy = File::KDBX::Object->new($object);
 129
 130 Make a clone of an entry. By default the clone is indeed an exact copy that is associated with the same
 131 database but not actually included in the object tree (i.e. it has no parent), but some options are allowed to
 132 get different effects:
 133
 134 =for :list
 135 * C<new_uuid> - Set a new UUID; value can be the new UUID, truthy to generate a random UUID, or falsy to keep
 136     the original UUID (default: same value as C<parent>)
 137 * C<parent> - If set, add the copy to the same parent (default: false)
 138 * C<relabel> - If set, change the name or title of the copy to "C<$original_title> - Copy".
 139 * C<entries> - Toggle whether or not to copy child entries, if any (default: true)
 140 * C<groups> - Toggle whether or not to copy child groups, if any (default: true)
 141 * C<history> - Toggle whether or not to copy the entry history, if any (default: true)
 142 * C<reference_password> - Toggle whether or not cloned entry's Password string should be set to a reference to
 143     their original entry's Password string.
 144 * C<reference_username> - Toggle whether or not cloned entry's UserName string should be set to a reference to
 145     their original entry's UserName string.
 146
 147 =cut
 148
 149 my %CLONE = (entries => 1, groups => 1, history => 1);
 150 sub clone {
 151     my $self = shift;
 152     my %args = @_;
 153
 154     local $CLONE{new_uuid}              = $args{new_uuid} // $args{parent} // 0;
 155     local $CLONE{entries}               = $args{entries}  // 1;
 156     local $CLONE{groups}                = $args{groups}   // 1;
 157     local $CLONE{history}               = $args{history}  // 1;
 158     local $CLONE{reference_password}    = $args{reference_password} // 0;
 159     local $CLONE{reference_username}    = $args{reference_username} // 0;
 160
 161     require Storable;
 162     my $copy = Storable::dclone($self);
 163
 164     if ($args{relabel} and my $label = $self->label) {
 165         $copy->label("$label - Copy");
 166     }
 167     if ($args{parent} and my $parent = $self->parent) {
 168         $parent->add_object($copy);
 169     }
 170
 171     return $copy;
 172 }
 173
 174 sub STORABLE_freeze {
 175     my $self    = shift;
 176     my $cloning = shift;
 177
 178     my $copy = {%$self};
 179     delete $copy->{entries} if !$CLONE{entries};
 180     delete $copy->{groups}  if !$CLONE{groups};
 181     delete $copy->{history} if !$CLONE{history};
 182
 183     return refaddr($self) || '', $copy;
 184 }
 185
 186 sub STORABLE_thaw {
 187     my $self    = shift;
 188     my $cloning = shift;
 189     my $addr    = shift;
 190     my $clone   = shift;
 191
 192     @$self{keys %$clone} = values %$clone;
 193
 194     my $kdbx = $KDBX{$addr};
 195     $self->kdbx($kdbx) if $kdbx;
 196
 197     if ($self->{uuid}) {
 198         if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->isa('File::KDBX::Entry')) {
 199             my $uuid = format_uuid($self->{uuid});
 200             my $clone_obj = do {
 201                 local $CLONE{new_uuid}              = 0;
 202                 local $CLONE{entries}               = 1;
 203                 local $CLONE{groups}                = 1;
 204                 local $CLONE{history}               = 1;
 205                 local $CLONE{reference_password}    = 0;
 206                 local $CLONE{reference_username}    = 0;
 207                 bless Storable::dclone({%$clone}),  'File::KDBX::Entry';
 208             };
 209             my $txn = $self->begin_work($clone_obj);
 210             if ($CLONE{reference_password}) {
 211                 $self->password("{REF:P\@I:$uuid}");
 212             }
 213             if ($CLONE{reference_username}) {
 214                 $self->username("{REF:U\@I:$uuid}");
 215             }
 216             $txn->commit;
 217         }
 218         $self->uuid(generate_uuid) if $CLONE{new_uuid};
 219     }
 220 }
 221
 222 =attr kdbx
 223
 224     $kdbx = $object->kdbx;
 225     $object->kdbx($kdbx);
 226
 227 Get or set the L<File::KDBX> instance associated with this object.
 228
 229 =cut
 230
 231 sub kdbx {
 232     my $self = shift;
 233     $self = $self->new if !ref $self;
 234     my $addr = refaddr($self);
 235     if (@_) {
 236         $KDBX{$addr} = shift;
 237         if (defined $KDBX{$addr}) {
 238             weaken $KDBX{$addr};
 239         }
 240         else {
 241             delete $KDBX{$addr};
 242         }
 243     }
 244     $KDBX{$addr} or throw 'Object is disassociated from a KDBX database', object => $self;
 245 }
 246
 247 =method id
 248
 249     $string_uuid = $object->id;
 250     $string_uuid = $object->id($delimiter);
 251
 252 Get the unique identifier for this object as a B<formatted> UUID string, typically for display purposes. You
 253 could use this to compare with other identifiers formatted with the same delimiter, but it is more efficient
 254 to use the raw UUID for that purpose (see L</uuid>).
 255
 256 A delimiter can optionally be provided to break up the UUID string visually. See
 257 L<File::KDBX::Util/format_uuid>.
 258
 259 =cut
 260
 261 sub id { format_uuid(shift->uuid, @_) }
 262
 263 =method group
 264
 265     $group = $object->group;
 266
 267 Get the parent group to which an object belongs or C<undef> if it belongs to no group.
 268
 269 Alias: C<parent>
 270
 271 =cut
 272
 273 sub group {
 274     my $self = shift;
 275     my $lineage = $self->kdbx->trace_lineage($self) or return;
 276     return pop @$lineage;
 277 }
 278
 279 sub parent { shift->group(@_) }
 280
 281 =method remove
 282
 283     $object = $object->remove;
 284
 285 Remove the object from the database. If the object is a group, all contained objects are removed as well.
 286
 287 =cut
 288
 289 sub remove {
 290     my $self = shift;
 291     my $parent = $self->parent;
 292     $parent->remove_object($self) if $parent;
 293     return $self;
 294 }
 295
 296 =method tag_list
 297
 298     @tags = $entry->tag_list;
 299
 300 Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace.
 301
 302 =cut
 303
 304 sub tag_list {
 305     my $self = shift;
 306     return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
 307 }
 308
 309 =method custom_icon
 310
 311     $image_data = $object->custom_icon;
 312     $image_data = $object->custom_icon($image_data, %attributes);
 313
 314 Get or set an icon image. Returns C<undef> if there is no custom icon set. Setting a custom icon will change
 315 the L</custom_icon_uuid> attribute.
 316
 317 Custom icon attributes (supported in KDBX4.1 and greater):
 318
 319 =for :list
 320 * C<name> - Name of the icon (text)
 321 * C<last_modification_time> - Just what it says (datetime)
 322
 323 =cut
 324
 325 sub custom_icon {
 326     my $self = shift;
 327     my $kdbx = $self->kdbx;
 328     if (@_) {
 329         my $img = shift;
 330         my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
 331         $self->icon_id(0) if $uuid;
 332         $self->custom_icon_uuid($uuid);
 333         return $img;
 334     }
 335     return $kdbx->custom_icon_data($self->custom_icon_uuid);
 336 }
 337
 338 =method custom_data
 339
 340     \%all_data = $object->custom_data;
 341     $object->custom_data(\%all_data);
 342
 343     \%data = $object->custom_data($key);
 344     $object->custom_data($key => \%data);
 345     $object->custom_data(%data);
 346     $object->custom_data(key => $value, %data);
 347
 348 Get and set custom data. Custom data is metadata associated with an object.
 349
 350 Each data item can have a few attributes associated with it.
 351
 352 =for :list
 353 * C<key> - A unique text string identifier used to look up the data item (required)
 354 * C<value> - A text string value (required)
 355 * C<last_modification_time> (optional, KDBX4.1+)
 356
 357 =cut
 358
 359 sub custom_data {
 360     my $self = shift;
 361     $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
 362     return $self->{custom_data} //= {} if !@_;
 363
 364     my %args = @_     == 2 ? (key => shift, value => shift)
 365              : @_ % 2 == 1 ? (key => shift, @_) : @_;
 366
 367     if (!$args{key} && !$args{value}) {
 368         my %standard = (key => 1, value => 1, last_modification_time => 1);
 369         my @other_keys = grep { !$standard{$_} } keys %args;
 370         if (@other_keys == 1) {
 371             my $key = $args{key} = $other_keys[0];
 372             $args{value} = delete $args{$key};
 373         }
 374     }
 375
 376     my $key = $args{key} or throw 'Must provide a custom_data key to access';
 377
 378     return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
 379
 380     while (my ($field, $value) = each %args) {
 381         $self->{custom_data}{$key}{$field} = $value;
 382     }
 383     return $self->{custom_data}{$key};
 384 }
 385
 386 =method custom_data_value
 387
 388     $value = $object->custom_data_value($key);
 389
 390 Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of
 391 attributes. This is a shortcut for:
 392
 393     my $data = $object->custom_data($key);
 394     my $value = defined $data ? $data->{value} : undef;
 395
 396 =cut
 397
 398 sub custom_data_value {
 399     my $self = shift;
 400     my $data = $self->custom_data(@_) // return undef;
 401     return $data->{value};
 402 }
 403
 404 1;
 405 __END__
 406
 407 =head1 DESCRIPTION
 408
 409 KDBX is an object database. This abstract class represents an object. You should not use this class directly
 410 but instead use its subclasses:
 411
 412 =for :list
 413 * L<File::KDBX::Entry>
 414 * L<File::KDBX::Group>
 415
 416 There is some functionality shared by both types of objects, and that's what this class provides.
 417
 418 =cut