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

   1 package File::KDBX::Entry;
   2 # ABSTRACT: A KDBX database entry
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Misc 0.029 qw(decode_b64 encode_b32r);
   8 use Devel::GlobalDestruction;
   9 use Encode qw(encode);
  10 use File::KDBX::Constants qw(:history :icon);
  11 use File::KDBX::Error;
  12 use File::KDBX::Util qw(:assert :class :coercion :erase :function :uri generate_uuid load_optional);
  13 use Hash::Util::FieldHash;
  14 use List::Util qw(first sum0);
  15 use Ref::Util qw(is_coderef is_hashref is_plain_hashref);
  16 use Scalar::Util qw(blessed looks_like_number);
  17 use Storable qw(dclone);
  18 use Time::Piece;
  19 use boolean;
  20 use namespace::clean;
  21
  22 extends 'File::KDBX::Object';
  23
  24 our $VERSION = '999.999'; # VERSION
  25
  26 my $PLACEHOLDER_MAX_DEPTH = 10;
  27 my %PLACEHOLDERS;
  28 my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes);
  29
  30 =attr foreground_color
  31
  32 Text color represented as a string of the form C<#000000>.
  33
  34 =attr background_color
  35
  36 Background color represented as a string of the form C<#FFFFFF>.
  37
  38 =attr override_url
  39
  40 TODO
  41
  42 =attr auto_type_enabled
  43
  44 Whether or not the entry is eligible to be matched for auto-typing.
  45
  46 =attr auto_type_obfuscation
  47
  48 Whether or not to use some kind of obfuscation when sending keystroke sequences to applications.
  49
  50 =attr auto_type_default_sequence
  51
  52 The default auto-type keystroke sequence.
  53
  54 =attr auto_type_associations
  55
  56 An array of window title / keystroke sequence associations.
  57
  58     {
  59         window              => 'Example Window Title',
  60         keystroke_sequence  => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
  61     }
  62
  63 Keystroke sequences can have </Placeholders>, most commonly C<{USERNAME}> and C<{PASSWORD}>.
  64
  65 =attr quality_check
  66
  67 Boolean indicating whether the entry password should be tested for weakness and show up in reports.
  68
  69 =attr strings
  70
  71 Hash with entry strings, including the standard strings as well as any custom ones.
  72
  73     {
  74         # Every entry has these five strings:
  75         Title    => { value => 'Example Entry' },
  76         UserName => { value => 'jdoe' },
  77         Password => { value => 's3cr3t', protect => true },
  78         URL      => { value => 'https://example.com' }
  79         Notes    => { value => '' },
  80         # May also have custom strings:
  81         MySystem => { value => 'The mainframe' },
  82     }
  83
  84 There are methods available to provide more convenient access to strings, including L</string>,
  85 L</string_value>, L</expand_string_value> and L</string_peek>.
  86
  87 =attr binaries
  88
  89 Files or attachments. Binaries are similar to strings except they have a value of bytes instead of test
  90 characters.
  91
  92     {
  93         'myfile.txt'    => {
  94             value   => '...',
  95         },
  96         'mysecrets.txt' => {
  97             value   => '...',
  98             protect => true,
  99         },
 100     }
 101
 102 There are methods available to provide more convenient access to binaries, including L</binary> and
 103 L</binary_value>.
 104
 105 =attr history
 106
 107 Array of historical entries. Historical entries are prior versions of the same entry so they all share the
 108 same UUID with the current entry.
 109
 110 =attr notes
 111
 112 Alias for the B<Notes> string value.
 113
 114 =attr password
 115
 116 Alias for the B<Password> string value.
 117
 118 =attr title
 119
 120 Alias for the B<Title> string value.
 121
 122 =attr url
 123
 124 Alias for the B<URL> string value.
 125
 126 =attr username
 127
 128 Aliases for the B<UserName> string value.
 129
 130 =cut
 131
 132 sub uuid {
 133     my $self = shift;
 134     if (@_ || !defined $self->{uuid}) {
 135         my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
 136         my $old_uuid = $self->{uuid};
 137         my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
 138         for my $entry (@{$self->history}) {
 139             $entry->{uuid} = $uuid;
 140         }
 141         $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid && $self->is_current;
 142     }
 143     $self->{uuid};
 144 }
 145
 146 # has uuid                    => sub { generate_uuid(printable => 1) };
 147 has icon_id                 => ICON_PASSWORD,   coerce => \&to_icon_constant;
 148 has custom_icon_uuid        => undef,           coerce => \&to_uuid;
 149 has foreground_color        => '',              coerce => \&to_string;
 150 has background_color        => '',              coerce => \&to_string;
 151 has override_url            => '',              coerce => \&to_string;
 152 has tags                    => '',              coerce => \&to_string;
 153 has auto_type               => {};
 154 has previous_parent_group   => undef,           coerce => \&to_uuid;
 155 has quality_check           => true,            coerce => \&to_bool;
 156 has strings                 => {};
 157 has binaries                => {};
 158 has times                   => {};
 159 # has custom_data             => {};
 160 # has history                 => [];
 161
 162 has last_modification_time  => sub { gmtime }, store => 'times', coerce => \&to_time;
 163 has creation_time           => sub { gmtime }, store => 'times', coerce => \&to_time;
 164 has last_access_time        => sub { gmtime }, store => 'times', coerce => \&to_time;
 165 has expiry_time             => sub { gmtime }, store => 'times', coerce => \&to_time;
 166 has expires                 => false,          store => 'times', coerce => \&to_bool;
 167 has usage_count             => 0,              store => 'times', coerce => \&to_number;
 168 has location_changed        => sub { gmtime }, store => 'times', coerce => \&to_time;
 169
 170 # has 'auto_type.auto_type_enabled'                   => true, coerce => \&to_bool;
 171 has 'auto_type_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation',
 172     coerce => \&to_number;
 173 has 'auto_type_default_sequence'          => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
 174     path => 'auto_type.default_sequence', coerce => \&to_string;
 175 has 'auto_type_associations'              => [], path => 'auto_type.associations';
 176
 177 my %ATTRS_STRINGS = (
 178     title                   => 'Title',
 179     username                => 'UserName',
 180     password                => 'Password',
 181     url                     => 'URL',
 182     notes                   => 'Notes',
 183 );
 184 while (my ($attr, $string_key) = each %ATTRS_STRINGS) {
 185     no strict 'refs'; ## no critic (ProhibitNoStrict)
 186     *{$attr} = sub { shift->string_value($string_key, @_) };
 187     *{"expand_${attr}"} = sub { shift->expand_string_value($string_key, @_) };
 188 }
 189
 190 my @ATTRS = qw(uuid custom_data history auto_type_enabled);
 191 sub _set_nonlazy_attributes {
 192     my $self = shift;
 193     $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self);
 194 }
 195
 196 sub init {
 197     my $self = shift;
 198     my %args = @_;
 199
 200     while (my ($key, $val) = each %args) {
 201         if (my $method = $self->can($key)) {
 202             $self->$method($val);
 203         }
 204         else {
 205             $self->string($key => $val);
 206         }
 207     }
 208
 209     return $self;
 210 }
 211
 212 ##############################################################################
 213
 214 =method string
 215
 216     \%string = $entry->string($string_key);
 217
 218     $entry->string($string_key, \%string);
 219     $entry->string($string_key, %attributes);
 220     $entry->string($string_key, $value); # same as: value => $value
 221
 222 Get or set a string. Every string has a unique (to the entry) key and flags and so are returned as a hash
 223 structure. For example:
 224
 225     $string = {
 226         value   => 'Password',
 227         protect => true,    # optional
 228     };
 229
 230 Every string should have a value (but might be C<undef> due to memory protection) and these optional flags
 231 which might exist:
 232
 233 =for :list
 234 * C<protect> - Whether or not the string value should be memory-protected.
 235
 236 =cut
 237
 238 sub string {
 239     my $self = shift;
 240     my %args = @_     == 2 ? (key => shift, value => shift)
 241              : @_ % 2 == 1 ? (key => shift, @_) : @_;
 242
 243     if (!defined $args{key} && !defined $args{value}) {
 244         my %standard = (value => 1, protect => 1);
 245         my @other_keys = grep { !$standard{$_} } keys %args;
 246         if (@other_keys == 1) {
 247             my $key = $args{key} = $other_keys[0];
 248             $args{value} = delete $args{$key};
 249         }
 250     }
 251
 252     my $key = delete $args{key} or throw 'Must provide a string key to access';
 253
 254     return $self->{strings}{$key} = $args{value} if is_plain_hashref($args{value});
 255
 256     while (my ($field, $value) = each %args) {
 257         $self->{strings}{$key}{$field} = $value;
 258     }
 259
 260     # Auto-vivify the standard strings.
 261     if ($STANDARD_STRINGS{$key}) {
 262         return $self->{strings}{$key} //= {value => '', $self->_protect($key) ? (protect => true) : ()};
 263     }
 264     return $self->{strings}{$key};
 265 }
 266
 267 ### Get whether or not a standard string is configured to be protected
 268 sub _protect {
 269     my $self = shift;
 270     my $key  = shift;
 271     return false if !$STANDARD_STRINGS{$key};
 272     if (my $kdbx = eval { $self->kdbx }) {
 273         my $protect = $kdbx->memory_protection($key);
 274         return $protect if defined $protect;
 275     }
 276     return $key eq 'Password';
 277 }
 278
 279 =method string_value
 280
 281     $string = $entry->string_value($string_key);
 282
 283 Access a string value directly. The arguments are the same as for L</string>. Returns C<undef> if the string
 284 is not set or is currently memory-protected. This is just a shortcut for:
 285
 286     my $string = do {
 287         my $s = $entry->string(...);
 288         defined $s ? $s->{value} : undef;
 289     };
 290
 291 =cut
 292
 293 sub string_value {
 294     my $self = shift;
 295     my $string = $self->string(@_) // return undef;
 296     return $string->{value};
 297 }
 298
 299 =method expand_string_value
 300
 301     $string = $entry->expand_string_value;
 302
 303 Same as L</string_value> but will substitute placeholders and resolve field references. Any placeholders that
 304 do not expand to values are left as-is.
 305
 306 See L</Placeholders>.
 307
 308 Some placeholders (notably field references) require the entry be connected to a database and will throw an
 309 error if it is not.
 310
 311 =cut
 312
 313 sub _expand_placeholder {
 314     my $self = shift;
 315     my $placeholder = shift;
 316     my $arg = shift;
 317
 318     require File::KDBX;
 319
 320     my $placeholder_key = $placeholder;
 321     if (defined $arg) {
 322         $placeholder_key = $File::KDBX::PLACEHOLDERS{"${placeholder}:${arg}"} ? "${placeholder}:${arg}"
 323                                                                               : "${placeholder}:";
 324     }
 325     return if !defined $File::KDBX::PLACEHOLDERS{$placeholder_key};
 326
 327     my $local_key = join('/', Hash::Util::FieldHash::id($self), $placeholder_key);
 328     local $PLACEHOLDERS{$local_key} = my $handler = $PLACEHOLDERS{$local_key} // do {
 329         my $handler = $File::KDBX::PLACEHOLDERS{$placeholder_key} or next;
 330         memoize recurse_limit($handler, $PLACEHOLDER_MAX_DEPTH, sub {
 331             alert "Detected deep recursion while expanding $placeholder placeholder",
 332                 placeholder => $placeholder;
 333             return; # undef
 334         });
 335     };
 336
 337     return $handler->($self, $arg, $placeholder);
 338 }
 339
 340 sub _expand_string {
 341     my $self    = shift;
 342     my $str     = shift;
 343
 344     my $expand = memoize $self->can('_expand_placeholder'), $self;
 345
 346     # placeholders (including field references):
 347     $str =~ s!\{([^:\}]+)(?::([^\}]*))?\}!$expand->(uc($1), $2, @_) // $&!egi;
 348
 349     # environment variables (alt syntax):
 350     my $vars = join('|', map { quotemeta($_) } keys %ENV);
 351     $str =~ s!\%($vars)\%!$expand->(ENV => $1, @_) // $&!eg;
 352
 353     return $str;
 354 }
 355
 356 sub expand_string_value {
 357     my $self = shift;
 358     my $str  = $self->string_peek(@_) // return undef;
 359     my $cleanup = erase_scoped $str;
 360     return $self->_expand_string($str);
 361 }
 362
 363 =attr expand_notes
 364
 365 Shortcut equivalent to C<< ->expand_string_value('Notes') >>.
 366
 367 =attr expand_password
 368
 369 Shortcut equivalent to C<< ->expand_string_value('Password') >>.
 370
 371 =attr expand_title
 372
 373 Shortcut equivalent to C<< ->expand_string_value('Title') >>.
 374
 375 =attr expand_url
 376
 377 Shortcut equivalent to C<< ->expand_string_value('URL') >>.
 378
 379 =attr expand_username
 380
 381 Shortcut equivalent to C<< ->expand_string_value('UserName') >>.
 382
 383 =method other_strings
 384
 385     $other = $entry->other_strings;
 386     $other = $entry->other_strings($delimiter);
 387
 388 Get a concatenation of all non-standard string values. The default delimiter is a newline. This is is useful
 389 for executing queries to search for entities based on the contents of these other strings (if any).
 390
 391 =cut
 392
 393 sub other_strings {
 394     my $self    = shift;
 395     my $delim   = shift // "\n";
 396
 397     my @strings = map { $self->string_value($_) } grep { !$STANDARD_STRINGS{$_} } sort keys %{$self->strings};
 398     return join($delim, @strings);
 399 }
 400
 401 =method string_peek
 402
 403     $string = $entry->string_peek($string_key);
 404
 405 Same as L</string_value> but can also retrieve the value from protected-memory if the value is currently
 406 protected.
 407
 408 =cut
 409
 410 sub string_peek {
 411     my $self = shift;
 412     my $string = $self->string(@_);
 413     return defined $string->{value} ? $string->{value} : $self->kdbx->peek($string);
 414 }
 415
 416 ##############################################################################
 417
 418 =method add_auto_type_association
 419
 420     $entry->add_auto_type_association(\%association);
 421
 422 Add a new auto-type association to an entry.
 423
 424 =cut
 425
 426 sub add_auto_type_association {
 427     my $self        = shift;
 428     my $association = shift;
 429     push @{$self->auto_type_associations}, $association;
 430 }
 431
 432 =method expand_keystroke_sequence
 433
 434     $string = $entry->expand_keystroke_sequence($keystroke_sequence);
 435     $string = $entry->expand_keystroke_sequence(\%association);
 436     $string = $entry->expand_keystroke_sequence;    # use default auto-type sequence
 437
 438 Get a keystroke sequence after placeholder expansion.
 439
 440 =cut
 441
 442 sub expand_keystroke_sequence {
 443     my $self = shift;
 444     my $association = shift;
 445
 446     my $keys;
 447     if ($association) {
 448         $keys = is_hashref($association) && exists $association->{keystroke_sequence} ?
 449         $association->{keystroke_sequence} : defined $association ? $association : '';
 450     }
 451
 452     $keys = $self->auto_type_default_sequence if !$keys;
 453     # TODO - Fall back to getting default sequence from parent group, which probably means we shouldn't be
 454     # setting a default value in the entry..
 455
 456     return $self->_expand_string($keys);
 457 }
 458
 459 ##############################################################################
 460
 461 =method binary
 462
 463     \%binary = $entry->binary($binary_key);
 464
 465     $entry->binary($binary_key, \%binary);
 466     $entry->binary($binary_key, %attributes);
 467     $entry->binary($binary_key, $value); # same as: value => $value
 468
 469 Get or set a binary. Every binary has a unique (to the entry) key and flags and so are returned as a hash
 470 structure. For example:
 471
 472     $binary = {
 473         value   => '...',
 474         protect => true,    # optional
 475     };
 476
 477 Every binary should have a value (but might be C<undef> due to memory protection) and these optional flags
 478 which might exist:
 479
 480 =for :list
 481 * C<protect> - Whether or not the binary value should be memory-protected.
 482
 483 =cut
 484
 485 sub binary {
 486     my $self = shift;
 487     my %args = @_     == 2 ? (key => shift, value => shift)
 488              : @_ % 2 == 1 ? (key => shift, @_) : @_;
 489
 490     if (!defined $args{key} && !defined $args{value}) {
 491         my %standard = (value => 1, protect => 1);
 492         my @other_keys = grep { !$standard{$_} } keys %args;
 493         if (@other_keys == 1) {
 494             my $key = $args{key} = $other_keys[0];
 495             $args{value} = delete $args{$key};
 496         }
 497     }
 498
 499     my $key = delete $args{key} or throw 'Must provide a binary key to access';
 500
 501     return $self->{binaries}{$key} = $args{value} if is_plain_hashref($args{value});
 502
 503     assert { !defined $args{value} || !utf8::is_utf8($args{value}) };
 504     while (my ($field, $value) = each %args) {
 505         $self->{binaries}{$key}{$field} = $value;
 506     }
 507     return $self->{binaries}{$key};
 508 }
 509
 510 =method binary_value
 511
 512     $binary = $entry->binary_value($binary_key);
 513
 514 Access a binary value directly. The arguments are the same as for L</binary>. Returns C<undef> if the binary
 515 is not set or is currently memory-protected. This is just a shortcut for:
 516
 517     my $binary = do {
 518         my $b = $entry->binary(...);
 519         defined $b ? $b->{value} : undef;
 520     };
 521
 522 =cut
 523
 524 sub binary_value {
 525     my $self = shift;
 526     my $binary = $self->binary(@_) // return undef;
 527     return $binary->{value};
 528 }
 529
 530 ##############################################################################
 531
 532 =method hmac_otp
 533
 534     $otp = $entry->hmac_otp(%options);
 535
 536 Generate an HMAC-based one-time password, or C<undef> if HOTP is not configured for the entry. The entry's
 537 strings generally must first be unprotected, just like when accessing the password. Valid options are:
 538
 539 =for :list
 540 * C<counter> - Specify the counter value
 541
 542 To configure HOTP, see L</"One-time Passwords">.
 543
 544 =cut
 545
 546 sub hmac_otp {
 547     my $self = shift;
 548     load_optional('Pass::OTP');
 549
 550     my %params = ($self->_hotp_params, @_);
 551     return if !defined $params{type} || !defined $params{secret};
 552
 553     $params{secret} = encode_b32r($params{secret}) if !$params{base32};
 554     $params{base32} = 1;
 555
 556     my $otp = eval {Pass::OTP::otp(%params, @_) };
 557     if (my $err = $@) {
 558         throw 'Unable to generate HOTP', error => $err;
 559     }
 560
 561     $self->_hotp_increment_counter($params{counter});
 562
 563     return $otp;
 564 }
 565
 566 =method time_otp
 567
 568     $otp = $entry->time_otp(%options);
 569
 570 Generate a time-based one-time password, or C<undef> if TOTP is not configured for the entry. The entry's
 571 strings generally must first be unprotected, just like when accessing the password. Valid options are:
 572
 573 =for :list
 574 * C<now> - Specify the value for determining the time-step counter
 575
 576 To configure TOTP, see L</"One-time Passwords">.
 577
 578 =cut
 579
 580 sub time_otp {
 581     my $self = shift;
 582     load_optional('Pass::OTP');
 583
 584     my %params = ($self->_totp_params, @_);
 585     return if !defined $params{type} || !defined $params{secret};
 586
 587     $params{secret} = encode_b32r($params{secret}) if !$params{base32};
 588     $params{base32} = 1;
 589
 590     my $otp = eval {Pass::OTP::otp(%params, @_) };
 591     if (my $err = $@) {
 592         throw 'Unable to generate TOTP', error => $err;
 593     }
 594
 595     return $otp;
 596 }
 597
 598 =method hmac_otp_uri
 599
 600 =method time_otp_uri
 601
 602     $uri_string = $entry->hmac_otp_uri;
 603     $uri_string = $entry->time_otp_uri;
 604
 605 Get a HOTP or TOTP otpauth URI for the entry, if available.
 606
 607 To configure OTP, see L</"One-time Passwords">.
 608
 609 =cut
 610
 611 sub hmac_otp_uri { $_[0]->_otp_uri($_[0]->_hotp_params) }
 612 sub time_otp_uri { $_[0]->_otp_uri($_[0]->_totp_params) }
 613
 614 sub _otp_uri {
 615     my $self = shift;
 616     my %params = @_;
 617
 618     return if 4 != grep { defined } @params{qw(type secret issuer account)};
 619     return if $params{type} !~ /^[ht]otp$/i;
 620
 621     my $label = delete $params{label};
 622     $params{$_} = uri_escape_utf8($params{$_}) for keys %params;
 623
 624     my $type    = lc($params{type});
 625     my $issuer  = $params{issuer};
 626     my $account = $params{account};
 627
 628     $label //= "$issuer:$account";
 629
 630     my $secret = $params{secret};
 631     $secret = uc(encode_b32r($secret)) if !$params{base32};
 632
 633     delete $params{algorithm} if defined $params{algorithm} && $params{algorithm} eq 'sha1';
 634     delete $params{period}    if defined $params{period} && $params{period} == 30;
 635     delete $params{digits}    if defined $params{digits} && $params{digits} == 6;
 636     delete $params{counter}   if defined $params{counter} && $params{counter} == 0;
 637
 638     my $uri = "otpauth://$type/$label?secret=$secret&issuer=$issuer";
 639
 640     if (defined $params{encoder}) {
 641         $uri .= "&encoder=$params{encoder}";
 642         return $uri;
 643     }
 644     $uri .= '&algorithm=' . uc($params{algorithm}) if defined $params{algorithm};
 645     $uri .= "&digits=$params{digits}"   if defined $params{digits};
 646     $uri .= "&counter=$params{counter}" if defined $params{counter};
 647     $uri .= "&period=$params{period}"   if defined $params{period};
 648
 649     return $uri;
 650 }
 651
 652 sub _hotp_params {
 653     my $self = shift;
 654
 655     my %params = (
 656         type    => 'hotp',
 657         issuer  => $self->title     || 'KDBX',
 658         account => $self->username  || 'none',
 659         digits  => 6,
 660         counter => $self->string_value('HmacOtp-Counter') // 0,
 661         $self->_otp_secret_params('Hmac'),
 662     );
 663     return %params if $params{secret};
 664
 665     my %otp_params = $self->_otp_params;
 666     return () if !$otp_params{secret} || $otp_params{type} ne 'hotp';
 667
 668     # $otp_params{counter} = 0
 669
 670     return (%params, %otp_params);
 671 }
 672
 673 sub _totp_params {
 674     my $self = shift;
 675
 676     my %algorithms = (
 677         'HMAC-SHA-1'    => 'sha1',
 678         'HMAC-SHA-256'  => 'sha256',
 679         'HMAC-SHA-512'  => 'sha512',
 680     );
 681     my %params = (
 682         type        => 'totp',
 683         issuer      => $self->title     || 'KDBX',
 684         account     => $self->username  || 'none',
 685         digits      => $self->string_value('TimeOtp-Length') // 6,
 686         algorithm   => $algorithms{$self->string_value('TimeOtp-Algorithm') || ''} || 'sha1',
 687         period      => $self->string_value('TimeOtp-Period') // 30,
 688         $self->_otp_secret_params('Time'),
 689     );
 690     return %params if $params{secret};
 691
 692     my %otp_params = $self->_otp_params;
 693     return () if !$otp_params{secret} || $otp_params{type} ne 'totp';
 694
 695     return (%params, %otp_params);
 696 }
 697
 698 # KeePassXC style
 699 sub _otp_params {
 700     my $self = shift;
 701     load_optional('Pass::OTP::URI');
 702
 703     my $uri = $self->string_value('otp') || '';
 704     my %params;
 705     %params = Pass::OTP::URI::parse($uri) if $uri =~ m!^otpauth://!;
 706     return () if !$params{secret} || !$params{type};
 707
 708     if (($params{encoder} // '') eq 'steam') {
 709         $params{digits} = 5;
 710         $params{chars}  = '23456789BCDFGHJKMNPQRTVWXY';
 711     }
 712
 713     # Pass::OTP::URI doesn't provide the issuer and account separately, so get them from the label
 714     my ($issuer, $user) = split(':', $params{label} // ':', 2);
 715     $params{issuer}  //= uri_unescape_utf8($issuer);
 716     $params{account} //= uri_unescape_utf8($user);
 717
 718     $params{algorithm}  = lc($params{algorithm}) if $params{algorithm};
 719     $params{counter}    = $self->string_value('HmacOtp-Counter') if $params{type} eq 'hotp';
 720
 721     return %params;
 722 }
 723
 724 sub _otp_secret_params {
 725     my $self = shift;
 726     my $type = shift // return ();
 727
 728     my $secret_txt = $self->string_value("${type}Otp-Secret");
 729     my $secret_hex = $self->string_value("${type}Otp-Secret-Hex");
 730     my $secret_b32 = $self->string_value("${type}Otp-Secret-Base32");
 731     my $secret_b64 = $self->string_value("${type}Otp-Secret-Base64");
 732
 733     my $count = grep { defined } ($secret_txt, $secret_hex, $secret_b32, $secret_b64);
 734     return () if $count == 0;
 735     alert "Found multiple ${type}Otp-Secret strings", count => $count if 1 < $count;
 736
 737     return (secret => $secret_b32, base32 => 1) if defined $secret_b32;
 738     return (secret => decode_b64($secret_b64))  if defined $secret_b64;
 739     return (secret => pack('H*', $secret_hex))  if defined $secret_hex;
 740     return (secret => encode('UTF-8', $secret_txt));
 741 }
 742
 743 sub _hotp_increment_counter {
 744     my $self    = shift;
 745     my $counter = shift // $self->string_value('HmacOtp-Counter') || 0;
 746
 747     looks_like_number($counter) or throw 'HmacOtp-Counter value must be a number', value => $counter;
 748     my $next = $counter + 1;
 749     $self->string('HmacOtp-Counter', $next);
 750     return $next;
 751 }
 752
 753 ##############################################################################
 754
 755 =method size
 756
 757     $size = $entry->size;
 758
 759 Get the size (in bytes) of an entry.
 760
 761 B<NOTE:> This is not an exact figure because there is no canonical serialization of an entry. This size should
 762 only be used as a rough estimate for comparison with other entries or to impose data size limitations.
 763
 764 =cut
 765
 766 sub size {
 767     my $self = shift;
 768
 769     my $size = 0;
 770
 771     # tags
 772     $size += length(encode('UTF-8', $self->tags // ''));
 773
 774     # attributes (strings)
 775     while (my ($key, $string) = each %{$self->strings}) {
 776         next if !defined $string->{value};
 777         $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $string->{value} // ''));
 778     }
 779
 780     # custom data
 781     while (my ($key, $item) = each %{$self->custom_data}) {
 782         next if !defined $item->{value};
 783         $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $item->{value} // ''));
 784     }
 785
 786     # binaries
 787     while (my ($key, $binary) = each %{$self->binaries}) {
 788         next if !defined $binary->{value};
 789         my $value_len = utf8::is_utf8($binary->{value}) ? length(encode('UTF-8', $binary->{value}))
 790             : length($binary->{value});
 791         $size += length(encode('UTF-8', $key)) + $value_len;
 792     }
 793
 794     # autotype associations
 795     for my $association (@{$self->auto_type->{associations} || []}) {
 796         $size += length(encode('UTF-8', $association->{window}))
 797             + length(encode('UTF-8', $association->{keystroke_sequence} // ''));
 798     }
 799
 800     return $size;
 801 }
 802
 803 ##############################################################################
 804
 805 sub history {
 806     my $self = shift;
 807     my $entries = $self->{history} //= [];
 808     if (@$entries && !blessed($entries->[0])) {
 809         @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
 810     }
 811     assert { !any { !blessed $_ } @$entries };
 812     return $entries;
 813 }
 814
 815 =method history_size
 816
 817     $size = $entry->history_size;
 818
 819 Get the size (in bytes) of all historical entries combined.
 820
 821 =cut
 822
 823 sub history_size {
 824     my $self = shift;
 825     return sum0 map { $_->size } @{$self->history};
 826 }
 827
 828 =method prune_history
 829
 830     @removed_historical_entries = $entry->prune_history(%options);
 831
 832 Remove just as many older historical entries as necessary to get under the database limits. The limits are
 833 taken from the connected database (if any) or can be overridden with C<%options>:
 834
 835 =for :list
 836 * C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1)
 837 * C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1)
 838 * C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1)
 839
 840 =cut
 841
 842 sub prune_history {
 843     my $self = shift;
 844     my %args = @_;
 845
 846     my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } // HISTORY_DEFAULT_MAX_ITEMS;
 847     my $max_size  = $args{max_size}  // eval { $self->kdbx->history_max_size }  // HISTORY_DEFAULT_MAX_SIZE;
 848     my $max_age   = $args{max_age}   // HISTORY_DEFAULT_MAX_AGE;
 849
 850     # history is ordered oldest to newest
 851     my $history = $self->history;
 852
 853     my @removed;
 854
 855     if (0 <= $max_items && $max_items < @$history) {
 856         push @removed, splice @$history, -$max_items;
 857     }
 858
 859     if (0 <= $max_size) {
 860         my $current_size = $self->history_size;
 861         while ($max_size < $current_size) {
 862             push @removed, my $entry = shift @$history;
 863             $current_size -= $entry->size;
 864         }
 865     }
 866
 867     if (0 <= $max_age) {
 868         my $cutoff = gmtime - ($max_age * 86400);
 869         for (my $i = @$history - 1; 0 <= $i; --$i) {
 870             my $entry = $history->[$i];
 871             next if $cutoff <= $entry->last_modification_time;
 872             push @removed, splice @$history, $i, 1;
 873         }
 874     }
 875
 876     @removed = sort { $a->last_modification_time <=> $b->last_modification_time } @removed;
 877     return @removed;
 878 }
 879
 880 =method add_historical_entry
 881
 882     $entry->add_historical_entry($entry);
 883
 884 Add an entry to the history.
 885
 886 =cut
 887
 888 sub add_historical_entry {
 889     my $self = shift;
 890     delete $_->{history} for @_;
 891     push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_;
 892 }
 893
 894 =method remove_historical_entry
 895
 896     $entry->remove_historical_entry($historical_entry);
 897
 898 Remove an entry from the history.
 899
 900 =cut
 901
 902 sub remove_historical_entry {
 903     my $self    = shift;
 904     my $entry   = shift;
 905     my $history = $self->history;
 906
 907     my @removed;
 908     for (my $i = @$history - 1; 0 <= $i; --$i) {
 909         my $item = $history->[$i];
 910         next if Hash::Util::FieldHash::id($entry) != Hash::Util::FieldHash::id($item);
 911         push @removed, splice @{$self->{history}}, $i, 1;
 912     }
 913     return @removed;
 914 }
 915
 916 =method current_entry
 917
 918     $current_entry = $entry->current_entry;
 919
 920 Get an entry's current entry. If the entry itself is current (not historical), itself is returned.
 921
 922 =cut
 923
 924 sub current_entry {
 925     my $self    = shift;
 926     my $parent  = $self->group;
 927
 928     if ($parent) {
 929         my $id = $self->uuid;
 930         my $entry = first { $id eq $_->uuid } @{$parent->entries};
 931         return $entry if $entry;
 932     }
 933
 934     return $self;
 935 }
 936
 937 =method is_current
 938
 939     $bool = $entry->is_current;
 940
 941 Get whether or not an entry is considered current (i.e. not historical). An entry is current if it is directly
 942 in the parent group's entry list.
 943
 944 =cut
 945
 946 sub is_current {
 947     my $self    = shift;
 948     my $current = $self->current_entry;
 949     return Hash::Util::FieldHash::id($self) == Hash::Util::FieldHash::id($current);
 950 }
 951
 952 =method is_historical
 953
 954     $bool = $entry->is_historical;
 955
 956 Get whether or not an entry is considered historical (i.e. not current).
 957
 958 This is just the inverse of L</is_current>.
 959
 960 =cut
 961
 962 sub is_historical { !$_[0]->is_current }
 963
 964 =method remove
 965
 966     $entry = $entry->remove;
 967
 968 Remove an entry from its parent group. If the entry is historical, remove it from the history of the current
 969 entry. If the entry is current, this behaves the same as L<File::KDBX::Object/remove>.
 970
 971 =cut
 972
 973 sub remove {
 974     my $self    = shift;
 975     my $current = $self->current_entry;
 976     return $self if $current->remove_historical_entry($self);
 977     $self->SUPER::remove(@_);
 978 }
 979
 980 ##############################################################################
 981
 982 =method searching_enabled
 983
 984     $bool = $entry->searching_enabled;
 985
 986 Get whether or not an entry may show up in search results. This is determine from the entry's parent group's
 987 L<File::KDBX::Group/effective_enable_searching> value.
 988
 989 Throws if entry has no parent group or if the entry is not connected to a database.
 990
 991 =cut
 992
 993 sub searching_enabled {
 994     my $self = shift;
 995     my $parent = $self->group;
 996     return $parent->effective_enable_searching if $parent;
 997     return true;
 998 }
 999
1000 sub auto_type_enabled {
1001     my $self = shift;
1002     $self->auto_type->{enabled} = to_bool(shift) if @_;
1003     $self->auto_type->{enabled} //= true;
1004     return false if !$self->auto_type->{enabled};
1005     return true if !$self->is_connected;
1006     my $parent = $self->group;
1007     return $parent->effective_enable_auto_type if $parent;
1008     return true;
1009 }
1010
1011 ##############################################################################
1012
1013 sub _signal {
1014     my $self = shift;
1015     my $type = shift;
1016     return $self->SUPER::_signal("entry.$type", @_);
1017 }
1018
1019 sub _commit {
1020     my $self = shift;
1021     my $orig = shift;
1022     $self->add_historical_entry($orig);
1023     my $time = gmtime;
1024     $self->last_modification_time($time);
1025     $self->last_access_time($time);
1026 }
1027
1028 sub label { shift->expand_title(@_) }
1029
1030 ### Name of the parent attribute expected to contain the object
1031 sub _parent_container { 'entries' }
1032
1033 1;
1034 __END__
1035
1036 =for Pod::Coverage auto_type times
1037
1038 =head1 DESCRIPTION
1039
1040 An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also
1041 called "files" or "attachments"). Every string and binary has a key or name. There is a default set of strings
1042 that every entry has:
1043
1044 =for :list
1045 * B<Title>
1046 * B<UserName>
1047 * B<Password>
1048 * B<URL>
1049 * B<Notes>
1050
1051 Beyond this, you can store any number of other strings and any number of binaries that you can use for
1052 whatever purpose you want.
1053
1054 There is also some metadata associated with an entry. Each entry in a database is identified uniquely by
1055 a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at
1056 the attributes to see what's available.
1057
1058 A B<File::KDBX::Entry> is a subclass of L<File::KDBX::Object>.
1059
1060 =head2 Placeholders
1061
1062 Entry string and auto-type key sequences can have placeholders or template tags that can be replaced by other
1063 values. Placeholders can appear like C<{PLACEHOLDER}>. For example, a B<URL> string might have a value of
1064 C<http://example.com?user={USERNAME}>. C<{USERNAME}> is a placeholder for the value of the B<UserName> string
1065 of the same entry. If the B<UserName> string had a value of "batman", the B<URL> string would expand to
1066 C<http://example.com?user=batman>.
1067
1068 Some placeholders take an argument, where the argument follows the tag after a colon but before the closing
1069 brace, like C<{PLACEHOLDER:ARGUMENT}>.
1070
1071 Placeholders are documented in the L<KeePass Help Center|https://keepass.info/help/base/placeholders.html>.
1072 This software supports many (but not all) of the placeholders documented there.
1073
1074 =head3 Entry Placeholders
1075
1076 =for :list
1077 * ☑ C<{TITLE}> - B<Title> string
1078 * ☑ C<{USERNAME}> - B<UserName> string
1079 * ☑ C<{PASSWORD}> - B<Password> string
1080 * ☑ C<{NOTES}> - B<Notes> string
1081 * ☑ C<{URL}> - B<URL> string
1082 * ☑ C<{URL:SCM}> / C<{URL:SCHEME}>
1083 * ☑ C<{URL:USERINFO}>
1084 * ☑ C<{URL:USERNAME}>
1085 * ☑ C<{URL:PASSWORD}>
1086 * ☑ C<{URL:HOST}>
1087 * ☑ C<{URL:PORT}>
1088 * ☑ C<{URL:PATH}>
1089 * ☑ C<{URL:QUERY}>
1090 * ☑ C<{URL:FRAGMENT}> / C<{URL:HASH}>
1091 * ☑ C<{URL:RMVSCM}> / C<{URL:WITHOUTSCHEME}>
1092 * ☑ C<{S:Name}> - Custom string where C<Name> is the name or key of the string
1093 * ☑ C<{UUID}> - Identifier (32 hexidecimal characters)
1094 * ☑ C<{HMACOTP}> - Generate an HMAC-based one-time password (its counter B<will> be incremented)
1095 * ☑ C<{TIMEOTP}> - Generate a time-based one-time password
1096 * ☑ C<{GROUP_NOTES}> - Notes of the parent group
1097 * ☑ C<{GROUP_PATH}> - Full path of the parent group
1098 * ☑ C<{GROUP}> - Name of the parent group
1099
1100 =head3 Field References
1101
1102 =for :list
1103 * ☑ C<{REF:Wanted@SearchIn:Text}> - See L<File::KDBX/resolve_reference>
1104
1105 =head3 File path Placeholders
1106
1107 =for :list
1108 * ☑ C<{APPDIR}> - Program directory path
1109 * ☑ C<{FIREFOX}> - Path to the Firefox browser executable
1110 * ☑ C<{GOOGLECHROME}> - Path to the Chrome browser executable
1111 * ☑ C<{INTERNETEXPLORER}> - Path to the Firefox browser executable
1112 * ☑ C<{OPERA}> - Path to the Opera browser executable
1113 * ☑ C<{SAFARI}> - Path to the Safari browser executable
1114 * ☒ C<{DB_PATH}> - Full file path of the database
1115 * ☒ C<{DB_DIR}> - Directory path of the database
1116 * ☒ C<{DB_NAME}> - File name (including extension) of the database
1117 * ☒ C<{DB_BASENAME}> - File name (excluding extension) of the database
1118 * ☒ C<{DB_EXT}> - File name extension
1119 * ☑ C<{ENV_DIRSEP}> - Directory separator
1120 * ☑ C<{ENV_PROGRAMFILES_X86}> - One of C<%ProgramFiles(x86)%> or C<%ProgramFiles%>
1121
1122 =head3 Date and Time Placeholders
1123
1124 =for :list
1125 * ☑ C<{DT_SIMPLE}> - Current local date and time as a sortable string
1126 * ☑ C<{DT_YEAR}> - Year component of the current local date
1127 * ☑ C<{DT_MONTH}> - Month component of the current local date
1128 * ☑ C<{DT_DAY}> - Day component of the current local date
1129 * ☑ C<{DT_HOUR}> - Hour component of the current local time
1130 * ☑ C<{DT_MINUTE}> - Minute component of the current local time
1131 * ☑ C<{DT_SECOND}> - Second component of the current local time
1132 * ☑ C<{DT_UTC_SIMPLE}> - Current UTC date and time as a sortable string
1133 * ☑ C<{DT_UTC_YEAR}> - Year component of the current UTC date
1134 * ☑ C<{DT_UTC_MONTH}> - Month component of the current UTC date
1135 * ☑ C<{DT_UTC_DAY}> - Day component of the current UTC date
1136 * ☑ C<{DT_UTC_HOUR}> - Hour component of the current UTC time
1137 * ☑ C<{DT_UTC_MINUTE}> Minute Year component of the current UTC time
1138 * ☑ C<{DT_UTC_SECOND}> - Second component of the current UTC time
1139
1140 If the current date and time is C<2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>.
1141
1142 =head3 Special Key Placeholders
1143
1144 Certain placeholders for use in auto-type key sequences are not supported for replacement, but they will
1145 remain as-is so that an auto-type engine (not included) can parse and replace them with the appropriate
1146 virtual key presses. For completeness, here is the list that the KeePass program claims to support:
1147
1148 C<{TAB}>, C<{ENTER}>, C<{UP}>, C<{DOWN}>, C<{LEFT}>, C<{RIGHT}>, C<{HOME}>, C<{END}>, C<{PGUP}>, C<{PGDN}>,
1149 C<{INSERT}>, C<{DELETE}>, C<{SPACE}>
1150
1151 C<{BACKSPACE}>, C<{BREAK}>, C<{CAPSLOCK}>, C<{ESC}>, C<{WIN}>, C<{LWIN}>, C<{RWIN}>, C<{APPS}>, C<{HELP}>,
1152 C<{NUMLOCK}>, C<{PRTSC}>, C<{SCROLLLOCK}>
1153
1154 C<{F1}>, C<{F2}>, C<{F3}>, C<{F4}>, C<{F5}>, C<{F6}>, C<{F7}>, C<{F8}>, C<{F9}>, C<{F10}>, C<{F11}>, C<{F12}>,
1155 C<{F13}>, C<{F14}>, C<{F15}>, C<{F16}>
1156
1157 C<{ADD}>, C<{SUBTRACT}>, C<{MULTIPLY}>, C<{DIVIDE}>, C<{NUMPAD0}>, C<{NUMPAD1}>, C<{NUMPAD2}>, C<{NUMPAD3}>,
1158 C<{NUMPAD4}>, C<{NUMPAD5}>, C<{NUMPAD6}>, C<{NUMPAD7}>, C<{NUMPAD8}>, C<{NUMPAD9}>
1159
1160 =head3 Miscellaneous Placeholders
1161
1162 =for :list
1163 * ☒ C<{BASE}>
1164 * ☒ C<{BASE:SCM}> / C<{BASE:SCHEME}>
1165 * ☒ C<{BASE:USERINFO}>
1166 * ☒ C<{BASE:USERNAME}>
1167 * ☒ C<{BASE:PASSWORD}>
1168 * ☒ C<{BASE:HOST}>
1169 * ☒ C<{BASE:PORT}>
1170 * ☒ C<{BASE:PATH}>
1171 * ☒ C<{BASE:QUERY}>
1172 * ☒ C<{BASE:FRAGMENT}> / C<{BASE:HASH}>
1173 * ☒ C<{BASE:RMVSCM}> / C<{BASE:WITHOUTSCHEME}>
1174 * ☒ C<{CLIPBOARD-SET:/Text/}>
1175 * ☒ C<{CLIPBOARD}>
1176 * ☒ C<{CMD:/CommandLine/Options/}>
1177 * ☑ C<{C:Comment}> - Comments are simply replaced by nothing
1178 * ☑ C<{ENV:}> and C<%ENV%> - Environment variables
1179 * ☒ C<{GROUP_SEL_NOTES}>
1180 * ☒ C<{GROUP_SEL_PATH}>
1181 * ☒ C<{GROUP_SEL}>
1182 * ☒ C<{NEWPASSWORD}>
1183 * ☒ C<{NEWPASSWORD:/Profile/}>
1184 * ☒ C<{PASSWORD_ENC}>
1185 * ☒ C<{PICKCHARS}>
1186 * ☒ C<{PICKCHARS:Field:Options}>
1187 * ☒ C<{PICKFIELD}>
1188 * ☒ C<{T-CONV:/Text/Type/}>
1189 * ☒ C<{T-REPLACE-RX:/Text/Type/Replace/}>
1190
1191 Some of these that remain unimplemented, such as C<{CLIPBOARD}>, cannot be implemented portably. Some of these
1192 I haven't implemented (yet) just because they don't seem very useful. You can create your own placeholder to
1193 augment the list of default supported placeholders or to replace a built-in placeholder handler. To create
1194 a placeholder, just set it in the C<%File::KDBX::PLACEHOLDERS> hash. For example:
1195
1196     $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER'} = sub {
1197         my ($entry) = @_;
1198         ...;
1199     };
1200
1201 If the placeholder is expanded in the context of an entry, C<$entry> is the B<File::KDBX::Entry> object in
1202 context. Otherwise it is C<undef>. An entry is in context if, for example, the placeholder is in an entry's
1203 strings or auto-type key sequences.
1204
1205     $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER:'} = sub {
1206         my ($entry, $arg) = @_;         #    ^ Notice the colon here
1207         ...;
1208     };
1209
1210 If the name of the placeholder ends in a colon, then it is expected to receive an argument. During expansion,
1211 everything after the colon and before the end of the placeholder is passed to your placeholder handler
1212 subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value B<whatever>.
1213
1214 An argument is required for placeholders than take one. I.e. The placeholder handler won't be called if there
1215 is no argument. If you want a placeholder to support an optional argument, you'll need to set the placeholder
1216 both with and without a colon (or they could be different subroutines):
1217
1218     $File::KDBX::PLACEHOLDERS{'RAND'} = $File::KDBX::PLACEHOLDERS{'RAND:'} = sub {
1219         (undef, my $arg) = @_;
1220         return defined $arg ? rand($arg) : rand;
1221     };
1222
1223 You can also remove placeholder handlers. If you want to disable placeholder expansion entirely, just delete
1224 all the handlers:
1225
1226     %File::KDBX::PLACEHOLDERS = ();
1227
1228 =head2 One-time Passwords
1229
1230 An entry can be configured to generate one-time passwords, both HOTP (HMAC-based) and TOTP (time-based). The
1231 configuration storage isn't completely standardized, but this module supports two predominant configuration
1232 styles:
1233
1234 =for :list
1235 * L<KeePass 2|https://keepass.info/help/base/placeholders.html#otp>
1236 * KeePassXC
1237
1238 B<NOTE:> To use this feature, you must install the suggested dependency:
1239
1240 =for :list
1241 * L<Pass::OTP>
1242
1243 To configure TOTP in the KeePassXC style, there is only one string to set: C<otp>. The value should be any
1244 valid otpauth URI. When generating an OTP, all of the relevant OTP properties are parsed from the URI.
1245
1246 To configure TOTP in the KeePass 2 style, set the following strings:
1247
1248 =for :list
1249 * C<TimeOtp-Algorithm> - Cryptographic algorithm, one of C<HMAC-SHA-1> (default), C<HMAC-SHA-256> and
1250     C<HMAC-SHA-512>
1251 * C<TimeOtp-Length> - Number of digits each one-time password is (default: 6, maximum: 8)
1252 * C<TimeOtp-Period> - Time-step size in seconds (default: 30)
1253 * C<TimeOtp-Secret> - Text string secret, OR
1254 * C<TimeOtp-Secret-Hex> - Hexidecimal-encoded secret, OR
1255 * C<TimeOtp-Secret-Base32> - Base32-encoded secret (most common), OR
1256 * C<TimeOtp-Secret-Base64> - Base64-encoded secret
1257
1258 To configure HOTP in the KeePass 2 style, set the following strings:
1259
1260 =for :list
1261 * C<HmacOtp-Counter> - Counting value in decimal, starts on C<0> by default and increments when L</hmac_otp>
1262     is called
1263 * C<HmacOtp-Secret> - Text string secret, OR
1264 * C<HmacOtp-Secret-Hex> - Hexidecimal-encoded secret, OR
1265 * C<HmacOtp-Secret-Base32> - Base32-encoded secret (most common), OR
1266 * C<HmacOtp-Secret-Base64> - Base64-encoded secret
1267
1268 B<NOTE:> The multiple "Secret" strings are simply a way to store a secret in different formats. Only one of
1269 these should actually be set or an error will be thrown.
1270
1271 Here's a basic example:
1272
1273     $entry->string(otp => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer');
1274     # OR
1275     $entry->string('TimeOtp-Secret-Base32' => 'NBSWY3DP');
1276
1277     my $otp = $entry->time_otp;
1278
1279 =cut