From 4dc2a1996dfcf2dfda3c554daa2f5f59fa763494 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Sun, 24 Apr 2022 14:11:10 -0600 Subject: [PATCH] Further expand support for attributes --- lib/File/KDBX.pm | 160 +++++++++++++++++-------------------- lib/File/KDBX/Constants.pm | 40 +++++----- lib/File/KDBX/Dumper/V3.pm | 2 +- lib/File/KDBX/Dumper/V4.pm | 5 +- lib/File/KDBX/Entry.pm | 65 +++++++-------- lib/File/KDBX/Group.pm | 69 +++++++--------- lib/File/KDBX/Loader/V3.pm | 2 +- lib/File/KDBX/Loader/V4.pm | 32 ++++---- lib/File/KDBX/Object.pm | 4 +- lib/File/KDBX/Util.pm | 23 +++++- t/entry.t | 8 ++ 11 files changed, 197 insertions(+), 213 deletions(-) diff --git a/lib/File/KDBX.pm b/lib/File/KDBX.pm index a0f815e..2e7c1e5 100644 --- a/lib/File/KDBX.pm +++ b/lib/File/KDBX.pm @@ -40,7 +40,7 @@ sub new { my $self = bless {}, $class; $self->init(@_); - $self->_set_default_attributes if empty $self; + $self->_set_nonlazy_attributes if empty $self; return $self; } @@ -120,6 +120,9 @@ sub STORABLE_thaw { $KEYS{$self} = $key; $SAFE{$self} = $safe; + # Dualvars aren't cloned as dualvars, so coerce the compression flags. + $self->compression_flags($self->compression_flags); + for my $object (@{$self->all_groups}, @{$self->all_entries(history => 1)}) { $object->kdbx($self); } @@ -223,99 +226,82 @@ sub user_agent_string { __PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)}); } -my %ATTRS = ( - sig1 => [KDBX_SIG1, coerce => \&to_number], - sig2 => [KDBX_SIG2_2, coerce => \&to_number], - version => [KDBX_VERSION_3_1, coerce => \&to_number], - headers => [{}], - inner_headers => [{}], - meta => [{}], - binaries => [{}], - deleted_objects => [{}], - raw => [undef, coerce => \&to_string], -); -my %ATTRS_HEADERS = ( - HEADER_COMMENT() => ['', coerce => \&to_string], - HEADER_CIPHER_ID() => [CIPHER_UUID_CHACHA20, coerce => \&to_uuid], - HEADER_COMPRESSION_FLAGS() => [COMPRESSION_GZIP, coerce => sub { compression($_[0]) }], - HEADER_MASTER_SEED() => [sub { random_bytes(32) }, coerce => \&to_string], - # HEADER_TRANSFORM_SEED() => sub { random_bytes(32) }, - # HEADER_TRANSFORM_ROUNDS() => 100_000, - HEADER_ENCRYPTION_IV() => [sub { random_bytes(16) }, coerce => \&to_string], - # HEADER_INNER_RANDOM_STREAM_KEY() => sub { random_bytes(32) }, # 64? - HEADER_STREAM_START_BYTES() => [sub { random_bytes(32) }, coerce => \&to_string], - # HEADER_INNER_RANDOM_STREAM_ID() => STREAM_ID_CHACHA20, - HEADER_KDF_PARAMETERS() => [sub { - +{ - KDF_PARAM_UUID() => KDF_UUID_AES, - KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS, - KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32), - }; - }], - # HEADER_PUBLIC_CUSTOM_DATA() => sub { +{} }, -); -my %ATTRS_META = ( - generator => ['', coerce => \&to_string], - header_hash => ['', coerce => \&to_string], - database_name => ['', coerce => \&to_string], - database_name_changed => [sub { gmtime }, coerce => \&to_time], - database_description => ['', coerce => \&to_string], - database_description_changed => [sub { gmtime }, coerce => \&to_time], - default_username => ['', coerce => \&to_string], - default_username_changed => [sub { gmtime }, coerce => \&to_time], - maintenance_history_days => [0, coerce => \&to_number], - color => ['', coerce => \&to_string], - master_key_changed => [sub { gmtime }, coerce => \&to_time], - master_key_change_rec => [-1, coerce => \&to_number], - master_key_change_force => [-1, coerce => \&to_number], - # memory_protection => {}, - custom_icons => [{}], - recycle_bin_enabled => [true, coerce => \&to_bool], - recycle_bin_uuid => ["\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", coerce => \&to_uuid], - recycle_bin_changed => [sub { gmtime }, coerce => \&to_time], - entry_templates_group => ["\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", coerce => \&to_uuid], - entry_templates_group_changed => [sub { gmtime }, coerce => \&to_time], - last_selected_group => ["\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", coerce => \&to_uuid], - last_top_visible_group => ["\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", coerce => \&to_uuid], - history_max_items => [HISTORY_DEFAULT_MAX_ITEMS, coerce => \&to_number], - history_max_size => [HISTORY_DEFAULT_MAX_SIZE, coerce => \&to_number], - settings_changed => [sub { gmtime }, coerce => \&to_time], - # binaries => {}, - # custom_data => {}, -); -my %ATTRS_MEMORY_PROTECTION = ( - protect_title => [false, coerce => \&to_bool], - protect_username => [false, coerce => \&to_bool], - protect_password => [true, coerce => \&to_bool], - protect_url => [false, coerce => \&to_bool], - protect_notes => [false, coerce => \&to_bool], - # auto_enable_visual_hiding => false, -); - -while (my ($attr, $default) = each %ATTRS) { - has $attr => @$default; -} -while (my ($attr, $default) = each %ATTRS_HEADERS) { - has $attr => @$default, store => 'headers'; -} -while (my ($attr, $default) = each %ATTRS_META) { - has $attr => @$default, store => 'meta'; -} -while (my ($attr, $default) = each %ATTRS_MEMORY_PROTECTION) { - has $attr => @$default, store => 'memory_protection'; -} - -my @ATTRS_OTHER = ( +has sig1 => KDBX_SIG1, coerce => \&to_number; +has sig2 => KDBX_SIG2_2, coerce => \&to_number; +has version => KDBX_VERSION_3_1, coerce => \&to_number; +has headers => {}; +has inner_headers => {}; +has meta => {}; +has binaries => {}; +has deleted_objects => {}; +has raw => coerce => \&to_string; + +# HEADERS +has 'headers.comment' => '', coerce => \&to_string; +has 'headers.cipher_id' => CIPHER_UUID_CHACHA20, coerce => \&to_uuid; +has 'headers.compression_flags' => COMPRESSION_GZIP, coerce => \&to_compression_constant; +has 'headers.master_seed' => sub { random_bytes(32) }, coerce => \&to_string; +has 'headers.encryption_iv' => sub { random_bytes(16) }, coerce => \&to_string; +has 'headers.stream_start_bytes' => sub { random_bytes(32) }, coerce => \&to_string; +has 'headers.kdf_parameters' => sub { + +{ + KDF_PARAM_UUID() => KDF_UUID_AES, + KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS, + KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32), + }; +}; +# has 'headers.transform_seed' => sub { random_bytes(32) }; +# has 'headers.transform_rounds' => 100_000; +# has 'headers.inner_random_stream_key' => sub { random_bytes(32) }; # 64 ? +# has 'headers.inner_random_stream_id' => STREAM_ID_CHACHA20; +# has 'headers.public_custom_data' => {}; + +# META +has 'meta.generator' => '', coerce => \&to_string; +has 'meta.header_hash' => '', coerce => \&to_string; +has 'meta.database_name' => '', coerce => \&to_string; +has 'meta.database_name_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.database_description' => '', coerce => \&to_string; +has 'meta.database_description_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.default_username' => '', coerce => \&to_string; +has 'meta.default_username_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.maintenance_history_days' => 0, coerce => \&to_number; +has 'meta.color' => '', coerce => \&to_string; +has 'meta.master_key_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.master_key_change_rec' => -1, coerce => \&to_number; +has 'meta.master_key_change_force' => -1, coerce => \&to_number; +# has 'meta.memory_protection' => {}; +has 'meta.custom_icons' => {}; +has 'meta.recycle_bin_enabled' => true, coerce => \&to_bool; +has 'meta.recycle_bin_uuid' => "\0" x 16, coerce => \&to_uuid; +has 'meta.recycle_bin_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.entry_templates_group' => "\0" x 16, coerce => \&to_uuid; +has 'meta.entry_templates_group_changed' => sub { gmtime }, coerce => \&to_time; +has 'meta.last_selected_group' => "\0" x 16, coerce => \&to_uuid; +has 'meta.last_top_visible_group' => "\0" x 16, coerce => \&to_uuid; +has 'meta.history_max_items' => HISTORY_DEFAULT_MAX_ITEMS, coerce => \&to_number; +has 'meta.history_max_size' => HISTORY_DEFAULT_MAX_SIZE, coerce => \&to_number; +has 'meta.settings_changed' => sub { gmtime }, coerce => \&to_time; +# has 'meta.binaries' => {}; +# has 'meta.custom_data' => {}; + +has 'memory_protection.protect_title' => false, coerce => \&to_bool; +has 'memory_protection.protect_username' => false, coerce => \&to_bool; +has 'memory_protection.protect_password' => true, coerce => \&to_bool; +has 'memory_protection.protect_url' => false, coerce => \&to_bool; +has 'memory_protection.protect_notes' => false, coerce => \&to_bool; +# has 'memory_protection.auto_enable_visual_hiding' => false; + +my @ATTRS = ( HEADER_TRANSFORM_SEED, HEADER_TRANSFORM_ROUNDS, HEADER_INNER_RANDOM_STREAM_KEY, HEADER_INNER_RANDOM_STREAM_ID, HEADER_PUBLIC_CUSTOM_DATA, ); -sub _set_default_attributes { +sub _set_nonlazy_attributes { my $self = shift; - $self->$_ for keys %ATTRS, keys %ATTRS_HEADERS, keys %ATTRS_META, keys %ATTRS_MEMORY_PROTECTION, - @ATTRS_OTHER; + $self->$_ for list_attributes(ref $self), @ATTRS; } =method memory_protection diff --git a/lib/File/KDBX/Constants.pm b/lib/File/KDBX/Constants.pm index fe80624..6eea0ef 100644 --- a/lib/File/KDBX/Constants.pm +++ b/lib/File/KDBX/Constants.pm @@ -274,10 +274,10 @@ BEGIN { } our %EXPORT_TAGS; -push @{$EXPORT_TAGS{header}}, 'kdbx_header'; -push @{$EXPORT_TAGS{compression}}, 'compression'; -push @{$EXPORT_TAGS{inner_header}}, 'kdbx_inner_header'; -push @{$EXPORT_TAGS{icon}}, 'icon'; +push @{$EXPORT_TAGS{header}}, 'to_header_constant'; +push @{$EXPORT_TAGS{compression}}, 'to_compression_constant'; +push @{$EXPORT_TAGS{inner_header}}, 'to_inner_header_constant'; +push @{$EXPORT_TAGS{icon}}, 'to_icon_constant'; $EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; our @EXPORT_OK = sort @{$EXPORT_TAGS{all}}; @@ -291,13 +291,13 @@ for my $header ( ) { $HEADER{$header} = $HEADER{0+$header} = $header; } -sub kdbx_header { $HEADER{$_[0]} } +sub to_header_constant { $HEADER{$_[0]} } my %COMPRESSION; for my $compression (COMPRESSION_NONE, COMPRESSION_GZIP) { $COMPRESSION{$compression} = $COMPRESSION{0+$compression} = $compression; } -sub compression { $COMPRESSION{$_[0]} } +sub to_compression_constant { $COMPRESSION{$_[0]} } my %INNER_HEADER; for my $inner_header ( @@ -306,7 +306,7 @@ for my $inner_header ( ) { $INNER_HEADER{$inner_header} = $INNER_HEADER{0+$inner_header} = $inner_header; } -sub kdbx_inner_header { $INNER_HEADER{$_[0]} } +sub to_inner_header_constant { $INNER_HEADER{$_[0]} } my %ICON; for my $icon ( @@ -324,7 +324,7 @@ for my $icon ( ) { $ICON{$icon} = $ICON{0+$icon} = $icon; } -sub icon { $ICON{$_[0] // ''} // ICON_PASSWORD } +sub to_icon_constant { $ICON{$_[0] // ''} // ICON_PASSWORD } 1; __END__ @@ -406,10 +406,10 @@ Constants related to parsing and generating KDBX file headers: = C = C -=func kdbx_header +=func to_header_constant - $constant = kdbx_header($number); - $constant = kdbx_header($string); + $constant = to_header_constant($number); + $constant = to_header_constant($string); Get a header constant from an integer or string value. @@ -421,10 +421,10 @@ Constants related to identifying the compression state of a file: = C = C -=func compression +=func to_compression_constant - $constant = compression($number); - $constant = compression($string); + $constant = to_compression_constant($number); + $constant = to_compression_constant($string); Get a compression constant from an integer or string value. @@ -504,10 +504,10 @@ Constants related to parsing and generating KDBX4 inner headers: = C = C -=func kdbx_inner_header +=func to_inner_header_constant - $constant = kdbx_inner_header($number); - $constant = kdbx_inner_header($string); + $constant = to_inner_header_constant($number); + $constant = to_inner_header_constant($string); Get an inner header constant from an integer or string value. @@ -604,10 +604,10 @@ Constants for default icons used by KeePass password safe implementations: = C = C -=func icon +=func to_icon_constant - $constant = icon($number); - $constant = icon($string); + $constant = to_icon_constant($number); + $constant = to_icon_constant($string); Get an icon constant from an integer or string value. diff --git a/lib/File/KDBX/Dumper/V3.pm b/lib/File/KDBX/Dumper/V3.pm index b8cf01c..a0d5b4d 100644 --- a/lib/File/KDBX/Dumper/V3.pm +++ b/lib/File/KDBX/Dumper/V3.pm @@ -59,7 +59,7 @@ sub _write_header { my $type = shift; my $val = shift // ''; - $type = kdbx_header($type); + $type = to_header_constant($type); if ($type == HEADER_END) { $val = "\r\n\r\n"; } diff --git a/lib/File/KDBX/Dumper/V4.pm b/lib/File/KDBX/Dumper/V4.pm index f2a8574..c002f0b 100644 --- a/lib/File/KDBX/Dumper/V4.pm +++ b/lib/File/KDBX/Dumper/V4.pm @@ -61,7 +61,7 @@ sub _write_header { my $type = shift; my $val = shift // ''; - $type = kdbx_header($type); + $type = to_header_constant($type); if ($type == HEADER_END) { # nothing } @@ -289,8 +289,7 @@ sub _write_inner_header { my $buf = pack('C', $type); $fh->print($buf) or throw 'Failed to write inner header type'; - $type = kdbx_inner_header($type); - + $type = to_inner_header_constant($type); if ($type == INNER_HEADER_END) { # nothing } diff --git a/lib/File/KDBX/Entry.pm b/lib/File/KDBX/Entry.pm index fc744fd..0ad08a0 100644 --- a/lib/File/KDBX/Entry.pm +++ b/lib/File/KDBX/Entry.pm @@ -175,33 +175,30 @@ sub uuid { $self->{uuid}; } -my @ATTRS = qw(uuid custom_data history icon_id); -my %ATTRS = ( - # uuid => sub { generate_uuid(printable => 1) }, - # icon_id => sub { defined $_[1] ? icon($_[1]) : ICON_PASSWORD }, - custom_icon_uuid => [undef, coerce => \&to_uuid], - foreground_color => ['', coerce => \&to_string], - background_color => ['', coerce => \&to_string], - override_url => ['', coerce => \&to_string], - tags => ['', coerce => \&to_string], - auto_type => [{}], - previous_parent_group => [undef, coerce => \&to_uuid], - quality_check => [true, coerce => \&to_bool], - strings => [{}], - binaries => [{}], - times => [{}], - # custom_data => {}, - # history => [], -); -my %ATTRS_TIMES = ( - last_modification_time => [sub { gmtime }, coerce => \&to_time], - creation_time => [sub { gmtime }, coerce => \&to_time], - last_access_time => [sub { gmtime }, coerce => \&to_time], - expiry_time => [sub { gmtime }, coerce => \&to_time], - expires => [false, coerce => \&to_bool], - usage_count => [0, coerce => \&to_number], - location_changed => [sub { gmtime }, coerce => \&to_time], -); +# has uuid => sub { generate_uuid(printable => 1) }; +has icon_id => ICON_PASSWORD, coerce => \&to_icon_constant; +has custom_icon_uuid => undef, coerce => \&to_uuid; +has foreground_color => '', coerce => \&to_string; +has background_color => '', coerce => \&to_string; +has override_url => '', coerce => \&to_string; +has tags => '', coerce => \&to_string; +has auto_type => {}; +has previous_parent_group => undef, coerce => \&to_uuid; +has quality_check => true, coerce => \&to_bool; +has strings => {}; +has binaries => {}; +has times => {}; +# has custom_data => {}; +# has history => []; + +has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expires => false, store => 'times', coerce => \&to_bool; +has usage_count => 0, store => 'times', coerce => \&to_number; +has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time; + my %ATTRS_STRINGS = ( title => 'Title', username => 'UserName', @@ -209,24 +206,16 @@ my %ATTRS_STRINGS = ( url => 'URL', notes => 'Notes', ); - -has icon_id => ICON_PASSWORD, coerce => sub { icon($_[0]) }; - -while (my ($attr, $default) = each %ATTRS) { - has $attr => @$default; -} -while (my ($attr, $default) = each %ATTRS_TIMES) { - has $attr => @$default, store => 'times'; -} while (my ($attr, $string_key) = each %ATTRS_STRINGS) { no strict 'refs'; ## no critic (ProhibitNoStrict) *{$attr} = sub { shift->string_value($string_key, @_) }; *{"expanded_${attr}"} = sub { shift->expanded_string_value($string_key, @_) }; } -sub _set_default_attributes { +my @ATTRS = qw(uuid custom_data history); +sub _set_nonlazy_attributes { my $self = shift; - $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES, keys %ATTRS_STRINGS; + $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self); } sub init { diff --git a/lib/File/KDBX/Group.pm b/lib/File/KDBX/Group.pm index 0870dd1..87cda2a 100644 --- a/lib/File/KDBX/Group.pm +++ b/lib/File/KDBX/Group.pm @@ -22,48 +22,35 @@ our $VERSION = '999.999'; # VERSION sub _parent_container { 'groups' } -my @ATTRS = qw(uuid custom_data entries groups icon_id); -my %ATTRS = ( - # uuid => sub { generate_uuid(printable => 1) }, - name => ['', coerce => \&to_string], - notes => ['', coerce => \&to_string], - tags => ['', coerce => \&to_string], - # icon_id => sub { defined $_[1] ? icon($_[1]) : ICON_FOLDER }, - custom_icon_uuid => [undef, coerce => \&to_uuid], - is_expanded => [false, coerce => \&to_bool], - default_auto_type_sequence => ['', coerce => \&to_string], - enable_auto_type => [undef, coerce => \&to_tristate], - enable_searching => [undef, coerce => \&to_tristate], - last_top_visible_entry => [undef, coerce => \&to_uuid], - # custom_data => {}, - previous_parent_group => [undef, coerce => \&to_uuid], - # entries => [], - # groups => [], - times => [{}], -); - -my %ATTRS_TIMES = ( - last_modification_time => [sub { gmtime }, coerce => \&to_time], - creation_time => [sub { gmtime }, coerce => \&to_time], - last_access_time => [sub { gmtime }, coerce => \&to_time], - expiry_time => [sub { gmtime }, coerce => \&to_time], - expires => [false, coerce => \&to_bool], - usage_count => [0, coerce => \&to_number], - location_changed => [sub { gmtime }, coerce => \&to_time], -); - -has icon_id => ICON_FOLDER, coerce => sub { icon($_[0]) }; - -while (my ($attr, $default) = each %ATTRS) { - has $attr => @$default; -} -while (my ($attr, $default) = each %ATTRS_TIMES) { - has $attr => @$default, store => 'times'; -} - -sub _set_default_attributes { +# has uuid => sub { generate_uuid(printable => 1) }; +has name => '', coerce => \&to_string; +has notes => '', coerce => \&to_string; +has tags => '', coerce => \&to_string; +has icon_id => ICON_FOLDER, coerce => \&to_icon_constant; +has custom_icon_uuid => undef, coerce => \&to_uuid; +has is_expanded => false, coerce => \&to_bool; +has default_auto_type_sequence => '', coerce => \&to_string; +has enable_auto_type => undef, coerce => \&to_tristate; +has enable_searching => undef, coerce => \&to_tristate; +has last_top_visible_entry => undef, coerce => \&to_uuid; +# has custom_data => {}; +has previous_parent_group => undef, coerce => \&to_uuid; +# has entries => []; +# has groups => []; +has times => {}; + +has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time; +has expires => false, store => 'times', coerce => \&to_bool; +has usage_count => 0, store => 'times', coerce => \&to_number; +has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time; + +my @ATTRS = qw(uuid custom_data entries groups); +sub _set_nonlazy_attributes { my $self = shift; - $self->$_ for @ATTRS, keys %ATTRS, keys %ATTRS_TIMES; + $self->$_ for @ATTRS, list_attributes(ref $self); } sub uuid { diff --git a/lib/File/KDBX/Loader/V3.pm b/lib/File/KDBX/Loader/V3.pm index 4b89fe9..e65a5e7 100644 --- a/lib/File/KDBX/Loader/V3.pm +++ b/lib/File/KDBX/Loader/V3.pm @@ -42,7 +42,7 @@ sub _read_header { $buf .= $val; } - $type = kdbx_header($type); + $type = to_header_constant($type); if ($type == HEADER_END) { # done } diff --git a/lib/File/KDBX/Loader/V4.pm b/lib/File/KDBX/Loader/V4.pm index 87e8826..3480209 100644 --- a/lib/File/KDBX/Loader/V4.pm +++ b/lib/File/KDBX/Loader/V4.pm @@ -45,7 +45,7 @@ sub _read_header { $buf .= $val; } - $type = kdbx_header($type); + $type = to_header_constant($type); if ($type == HEADER_END) { # done } @@ -225,10 +225,7 @@ sub _read_inner_header { my $fh = shift; my $kdbx = $self->kdbx; - read_all $fh, my $buf, 5 or throw 'Expected inner header type and size', - compression_error => $IO::Uncompress::Gunzip::GunzipError, - crypt_error => $File::KDBX::IO::Crypt::ERROR, - hmac_error => $File::KDBX::IO::HmacBLock::ERROR; + read_all $fh, my $buf, 5 or throw 'Expected inner header type and size'; my ($type, $size) = unpack('C L<', $buf); my $val; @@ -236,23 +233,18 @@ sub _read_inner_header { read_all $fh, $val, $size or throw 'Expected inner header value', type => $type, size => $size; } - my $dualtype = kdbx_inner_header($type); - - if (!defined $dualtype) { - alert "Ignoring unknown inner header type ($type)", type => $type, size => $size, value => $val; - return wantarray ? ($type => $val) : $type; - } - elsif ($dualtype == INNER_HEADER_END) { + $type = to_inner_header_constant($type) // $type; + if ($type == INNER_HEADER_END) { # nothing } - elsif ($dualtype == INNER_HEADER_INNER_RANDOM_STREAM_ID) { + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) { $val = unpack('L<', $val); - $kdbx->inner_headers->{$dualtype} = $val; + $kdbx->inner_headers->{$type} = $val; } - elsif ($dualtype == INNER_HEADER_INNER_RANDOM_STREAM_KEY) { - $kdbx->inner_headers->{$dualtype} = $val; + elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) { + $kdbx->inner_headers->{$type} = $val; } - elsif ($dualtype == INNER_HEADER_BINARY) { + elsif ($type == INNER_HEADER_BINARY) { my $msize = $size - 1; my ($flags, $data) = unpack("C a$msize", $val); my $id = scalar keys %{$kdbx->binaries}; @@ -261,8 +253,12 @@ sub _read_inner_header { $flags & INNER_HEADER_BINARY_FLAG_PROTECT ? (protect => true) : (), }; } + else { + alert "Ignoring unknown inner header type ($type)", type => $type, size => $size, value => $val; + return wantarray ? ($type => $val) : $type; + } - return wantarray ? ($dualtype => $val) : $dualtype; + return wantarray ? ($type => $val) : $type; } 1; diff --git a/lib/File/KDBX/Object.pm b/lib/File/KDBX/Object.pm index 0d53dd9..f01944a 100644 --- a/lib/File/KDBX/Object.pm +++ b/lib/File/KDBX/Object.pm @@ -73,11 +73,11 @@ sub new { my $self = bless $data // {}, $class; $self->init(%args); - $self->_set_default_attributes if !$data; + $self->_set_nonlazy_attributes if !$data; return $self; } -sub _set_default_attributes { die 'Not implemented' } +sub _set_nonlazy_attributes { die 'Not implemented' } =method init diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 3141c3f..c3d77ae 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -21,7 +21,7 @@ our $VERSION = '999.999'; # VERSION our %EXPORT_TAGS = ( assert => [qw(assert_64bit)], - class => [qw(extends has)], + class => [qw(extends has list_attributes)], clone => [qw(clone clone_nomagic)], coercion => [qw(to_bool to_number to_string to_time to_tristate to_uuid)], crypt => [qw(pad_pkcs7)], @@ -85,6 +85,7 @@ my %OP_NEG = ( '=~' => '!~', '!~' => '=~', ); +my %ATTRIBUTES; =func load_xs @@ -405,9 +406,14 @@ sub has { my $has_default = is_coderef $default; my $has_coerce = is_coderef $coerce; + my $store = $args{store}; + ($store, $name) = split(/\./, $name, 2) if $name =~ /\./; + my $caller = caller; + push @{$ATTRIBUTES{$caller} //= []}, $name; + no strict 'refs'; ## no critic (ProhibitNoStrict) - if (my $store = $args{store}) { + if ($store) { *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub { $_[0]->$store->{$name} //= scalar $default->($_[0]); } : $is eq 'ro' ? sub { @@ -574,6 +580,19 @@ Check if a thing is a UUID (i.e. scalar string of length 16). sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 } +=func list_attributes + + @attributes = list_attributes($package); + +Get a list of attributes for a class. + +=cut + +sub list_attributes { + my $package = shift; + return @{$ATTRIBUTES{$package} // []}; +} + =func load_optional $package = load_optional($package); diff --git a/t/entry.t b/t/entry.t index 6de8028..3a6267d 100644 --- a/t/entry.t +++ b/t/entry.t @@ -73,6 +73,14 @@ subtest 'Construction' => sub { }), 'Entry data contains UserName string and the rest default attributes'; }; +subtest 'Accessors' => sub { + my $entry = File::KDBX::Entry->new; + + $entry->creation_time('2022-02-02 12:34:56'); + cmp_ok $entry->creation_time, '==', 1643805296, 'Creation time coerced into a Time::Piece (epoch)'; + is $entry->creation_time->datetime, '2022-02-02T12:34:56', 'Creation time coerced into a Time::Piece'; +}; + subtest 'Custom icons' => sub { plan tests => 10; my $gif = pack('H*', '4749463839610100010000ff002c00000000010001000002003b'); -- 2.45.2