1 package File
::KDBX
::Dumper
::XML
;
2 # ABSTRACT: Dump unencrypted XML KeePass files
7 use Crypt
::Digest
qw(digest_data);
8 use Crypt
::Misc
0.029 qw(encode_b64);
10 use File
::KDBX
::Constants
qw(:version :time);
11 use File
::KDBX
::Error
;
12 use File
::KDBX
::Util
qw(:class :int erase_scoped gzip snakify);
14 use Scalar
::Util
qw(blessed isdual looks_like_number);
20 extends
'File::KDBX::Dumper';
22 our $VERSION = '0.906'; # VERSION
25 has allow_protection
=> 1;
26 has binaries
=> sub { $_[0]->kdbx->version < KDBX_VERSION_4_0
};
27 has 'compress_binaries';
28 has 'compress_datetimes';
30 sub header_hash
{ $_[0]->{header_hash
} }
32 sub _binaries_written
{ $_[0]->{_binaries_written
} //= {} }
34 sub _random_stream
{ $_[0]->{random_stream
} //= $_[0]->kdbx->random_stream }
40 $self->_write_inner_body($fh, $self->header_hash);
43 sub _write_inner_body
{
46 my $header_hash = shift;
48 my $dom = XML
::LibXML
::Document-
>new('1.0', 'UTF-8');
49 $dom->setStandalone(1);
51 my $doc = XML
::LibXML
::Element-
>new('KeePassFile');
52 $dom->setDocumentElement($doc);
54 my $meta = XML
::LibXML
::Element-
>new('Meta');
55 $doc->appendChild($meta);
56 $self->_write_xml_meta($meta, $header_hash);
58 my $root = XML
::LibXML
::Element-
>new('Root');
59 $doc->appendChild($root);
60 $self->_write_xml_root($root);
68 my $header_hash = shift;
70 my $meta = $self->kdbx->meta;
71 local $meta->{generator
} = $self->kdbx->user_agent_string // __PACKAGE__
;
72 local $meta->{header_hash
} = $header_hash;
74 $self->_write_xml_from_pairs($node, $meta,
76 $self->kdbx->version < KDBX_VERSION_4_0
&& defined $meta->{header_hash
} ? (
77 HeaderHash
=> 'binary',
79 DatabaseName
=> 'text',
80 DatabaseNameChanged
=> 'datetime',
81 DatabaseDescription
=> 'text',
82 DatabaseDescriptionChanged
=> 'datetime',
83 DefaultUserName
=> 'text',
84 DefaultUserNameChanged
=> 'datetime',
85 MaintenanceHistoryDays
=> 'number',
87 MasterKeyChanged
=> 'datetime',
88 MasterKeyChangeRec
=> 'number',
89 MasterKeyChangeForce
=> 'number',
90 MemoryProtection
=> \
&_write_xml_memory_protection
,
91 CustomIcons
=> \
&_write_xml_custom_icons
,
92 RecycleBinEnabled
=> 'bool',
93 RecycleBinUUID
=> 'uuid',
94 RecycleBinChanged
=> 'datetime',
95 EntryTemplatesGroup
=> 'uuid',
96 EntryTemplatesGroupChanged
=> 'datetime',
97 LastSelectedGroup
=> 'uuid',
98 LastTopVisibleGroup
=> 'uuid',
99 HistoryMaxItems
=> 'number',
100 HistoryMaxSize
=> 'number',
101 $self->kdbx->version >= KDBX_VERSION_4_0
? (
102 SettingsChanged
=> 'datetime',
104 $self->kdbx->version < KDBX_VERSION_4_0
|| $self->binaries ? (
105 Binaries
=> \
&_write_xml_binaries
,
107 CustomData
=> \
&_write_xml_custom_data
,
111 sub _write_xml_memory_protection
{
115 my $memory_protection = $self->kdbx->meta->{memory_protection
};
117 $self->_write_xml_from_pairs($node, $memory_protection,
118 ProtectTitle
=> 'bool',
119 ProtectUserName
=> 'bool',
120 ProtectPassword
=> 'bool',
121 ProtectURL
=> 'bool',
122 ProtectNotes
=> 'bool',
123 # AutoEnableVisualHiding => 'bool',
127 sub _write_xml_binaries
{
131 my $kdbx = $self->kdbx;
133 my $new_ref = keys %{$self->_binaries_written};
134 my $written = $self->_binaries_written;
136 my $entries = $kdbx->entries(history
=> 1);
137 while (my $entry = $entries->next) {
138 for my $key (keys %{$entry->binaries}) {
139 my $binary = $entry->binaries->{$key};
140 if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
141 $binary = $kdbx->binaries->{$binary->{ref}};
144 if (!defined $binary->{value
}) {
145 alert
"Skipping binary which has no value: $key", key
=> $key;
149 my $hash = digest_data
('SHA256', $binary->{value
});
150 if (defined $written->{$hash}) {
154 my $binary_node = $node->addNewChild(undef, 'Binary');
155 $binary_node->setAttribute('ID', _encode_text
($new_ref));
156 $binary_node->setAttribute('Protected', _encode_bool
(true
)) if $binary->{protect
};
157 $self->_write_xml_compressed_content($binary_node, \
$binary->{value
}, $binary->{protect
});
158 $written->{$hash} = $new_ref++;
164 sub _write_xml_compressed_content
{
173 if (utf8
::is_utf8
($$value)) {
174 $encoded = encode
('UTF-8', $$value);
175 push @cleanup, erase_scoped
$encoded;
179 my $should_compress = $self->compress_binaries;
180 my $try_compress = $should_compress || !defined $should_compress;
184 $compressed = gzip
($$value);
185 push @cleanup, erase_scoped
$compressed;
187 if ($should_compress || length($compressed) < length($$value)) {
188 $value = \
$compressed;
189 $node->setAttribute('Compressed', _encode_bool
(true
));
195 $encrypted = $self->_random_stream->crypt($$value);
196 push @cleanup, erase_scoped
$encrypted;
197 $value = \
$encrypted;
200 $node->appendText(_encode_binary
($$value));
203 sub _write_xml_custom_icons
{
207 my $custom_icons = $self->kdbx->custom_icons;
209 for my $icon (@$custom_icons) {
210 $icon->{uuid
} && $icon->{data
} or next;
211 my $icon_node = $node->addNewChild(undef, 'Icon');
213 $self->_write_xml_from_pairs($icon_node, $icon,
216 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
218 LastModificationTime
=> 'datetime',
224 sub _write_xml_custom_data
{
227 my $custom_data = shift || {};
229 for my $key (sort keys %$custom_data) {
230 my $item = $custom_data->{$key};
231 my $item_node = $node->addNewChild(undef, 'Item');
233 local $item->{key
} = $key if !defined $item->{key
};
235 $self->_write_xml_from_pairs($item_node, $item,
238 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
239 LastModificationTime
=> 'datetime',
245 sub _write_xml_root
{
248 my $kdbx = $self->kdbx;
250 my $guard = $kdbx->unlock_scoped;
252 if (my $group = $kdbx->root) {
253 my $group_node = $node->addNewChild(undef, 'Group');
254 $self->_write_xml_group($group_node, $group->_committed);
257 undef $guard; # re-lock if needed, as early as possible
259 my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects');
260 $self->_write_xml_deleted_objects($deleted_objects_node);
263 sub _write_xml_group
{
268 $self->_write_xml_from_pairs($node, $group,
272 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
276 defined $group->{custom_icon_uuid
} ? (
277 CustomIconUUID
=> 'uuid',
279 Times
=> \
&_write_xml_times
,
280 IsExpanded
=> 'bool',
281 DefaultAutoTypeSequence
=> 'text',
282 EnableAutoType
=> 'tristate',
283 EnableSearching
=> 'tristate',
284 LastTopVisibleEntry
=> 'uuid',
285 KDBX_VERSION_4_0
<= $self->kdbx->version ? (
286 CustomData
=> \
&_write_xml_custom_data
,
288 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
289 PreviousParentGroup
=> 'uuid',
293 for my $entry (@{$group->entries}) {
294 my $entry_node = $node->addNewChild(undef, 'Entry');
295 $self->_write_xml_entry($entry_node, $entry->_committed);
298 for my $group (@{$group->groups}) {
299 my $group_node = $node->addNewChild(undef, 'Group');
300 $self->_write_xml_group($group_node, $group->_committed);
304 sub _write_xml_entry
{
308 my $in_history = shift;
310 $self->_write_xml_from_pairs($node, $entry,
313 defined $entry->{custom_icon_uuid
} ? (
314 CustomIconUUID
=> 'uuid',
316 ForegroundColor
=> 'text',
317 BackgroundColor
=> 'text',
318 OverrideURL
=> 'text',
320 Times
=> \
&_write_xml_times
,
321 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
322 QualityCheck
=> 'bool',
323 PreviousParentGroup
=> 'uuid',
327 for my $key (sort keys %{$entry->{strings
} || {}}) {
328 my $string = $entry->{strings
}{$key};
329 my $string_node = $node->addNewChild(undef, 'String');
330 local $string->{key
} = $string->{key
} // $key;
331 $self->_write_xml_entry_string($string_node, $string);
334 my $kdbx = $self->kdbx;
335 my $new_ref = keys %{$self->_binaries_written};
336 my $written = $self->_binaries_written;
338 for my $key (sort keys %{$entry->{binaries
} || {}}) {
339 my $binary = $entry->binaries->{$key};
340 if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
341 $binary = $kdbx->binaries->{$binary->{ref}};
344 if (!defined $binary->{value
}) {
345 alert
"Skipping binary which has no value: $key", key
=> $key;
349 my $binary_node = $node->addNewChild(undef, 'Binary');
350 $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text
($key));
351 my $value_node = $binary_node->addNewChild(undef, 'Value');
353 my $hash = digest_data
('SHA256', $binary->{value
});
354 if (defined $written->{$hash}) {
356 $value_node->setAttribute('Ref', _encode_text
($written->{$hash}));
359 # write actual binary
360 $value_node->setAttribute('Protected', _encode_bool
(true
)) if $binary->{protect
};
361 $self->_write_xml_compressed_content($value_node, \
$binary->{value
}, $binary->{protect
});
362 $written->{$hash} = $new_ref++;
366 $self->_write_xml_from_pairs($node, $entry,
367 AutoType
=> \
&_write_xml_entry_auto_type
,
370 $self->_write_xml_from_pairs($node, $entry,
371 KDBX_VERSION_4_0
<= $self->kdbx->version ? (
372 CustomData
=> \
&_write_xml_custom_data
,
377 if (my @history = @{$entry->history}) {
378 my $history_node = $node->addNewChild(undef, 'History');
379 for my $historical (@history) {
380 my $historical_node = $history_node->addNewChild(undef, 'Entry');
381 $self->_write_xml_entry($historical_node, $historical->_committed, 1);
387 sub _write_xml_entry_auto_type
{
390 my $autotype = shift;
392 $self->_write_xml_from_pairs($node, $autotype,
394 DataTransferObfuscation
=> 'number',
395 DefaultSequence
=> 'text',
398 for my $association (@{$autotype->{associations
} || []}) {
399 my $association_node = $node->addNewChild(undef, 'Association');
400 $self->_write_xml_from_pairs($association_node, $association,
402 KeystrokeSequence
=> 'text',
407 sub _write_xml_times
{
412 $self->_write_xml_from_pairs($node, $times,
413 LastModificationTime
=> 'datetime',
414 CreationTime
=> 'datetime',
415 LastAccessTime
=> 'datetime',
416 ExpiryTime
=> 'datetime',
418 UsageCount
=> 'number',
419 LocationChanged
=> 'datetime',
423 sub _write_xml_entry_string
{
430 my $kdbx = $self->kdbx;
431 my $key = $string->{key
};
433 $node->addNewChild(undef, 'Key')->appendText(_encode_text
($key));
434 my $value_node = $node->addNewChild(undef, 'Value');
436 my $value = $string->{value
} || '';
438 my $memory_protection = $kdbx->meta->{memory_protection
};
439 my $memprot_key = 'protect_' . snakify
($key);
440 my $protect = $string->{protect
} || $memory_protection->{$memprot_key};
443 if ($self->allow_protection) {
445 if (utf8
::is_utf8
($value)) {
446 $encoded = encode
('UTF-8', $value);
447 push @cleanup, erase_scoped
$encoded;
451 $value_node->setAttribute('Protected', _encode_bool
(true
));
452 $value = _encode_binary
($self->_random_stream->crypt(\
$value));
455 $value_node->setAttribute('ProtectInMemory', _encode_bool
(true
));
456 $value = _encode_text
($value);
460 $value = _encode_text
($value);
463 $value_node->appendText($value) if defined $value;
466 sub _write_xml_deleted_objects
{
470 my $objects = $self->kdbx->deleted_objects;
472 for my $uuid (sort keys %{$objects || {}}) {
473 my $object = $objects->{$uuid};
474 local $object->{uuid
} = $uuid;
475 my $object_node = $node->addNewChild(undef, 'DeletedObject');
476 $self->_write_xml_from_pairs($object_node, $object,
478 DeletionTime
=> 'datetime',
483 ##############################################################################
485 sub _write_xml_from_pairs
{
492 my ($name, $type) = splice @spec, 0, 2;
493 my $key = snakify
($name);
495 if (ref $type eq 'CODE') {
496 my $child_node = $node->addNewChild(undef, $name);
497 $self->$type($child_node, $hash->{$key});
500 next if !exists $hash->{$key};
501 my $child_node = $node->addNewChild(undef, $name);
502 $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes;
503 $child_node->appendText(_encode_primitive
($hash->{$key}, $type));
508 ##############################################################################
510 sub _encode_primitive
{ goto &{__PACKAGE__
."::_encode_$_[1]"} }
513 return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]);
514 return encode_b64
(ref $_[0] ? $$_[0] : $_[0]);
519 return $_ ? 'True' : 'False';
522 sub _encode_datetime
{
524 return $_->strftime('%Y-%m-%dT%H:%M:%SZ');
527 sub _encode_datetime_binary
{
529 my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH
;
530 my $buf = pack_Ql
($seconds_since_ad1->epoch);
531 return eval { encode_b64
($buf) };
534 sub _encode_tristate
{
535 local $_ = shift // return 'null';
536 return $_ ? 'True' : 'False';
540 local $_ = shift // return;
541 looks_like_number
($_) || isdual
($_) or throw
'Expected number', text
=> $_;
542 return _encode_text
($_+0);
546 return '' if !defined $_[0];
550 sub _encode_uuid
{ _encode_binary
(@_) }
562 File::KDBX::Dumper::XML - Dump unencrypted XML KeePass files
570 =head2 allow_protection
572 $bool = $dumper->allow_protection;
574 Get whether or not protected strings and binaries should be written in an encrypted stream. Default: C<TRUE>
578 $bool = $dumper->binaries;
580 Get whether or not binaries within the database should be written. Default: C<TRUE>
582 =head2 compress_binaries
584 $tristate = $dumper->compress_binaries;
586 Get whether or not to compress binaries. Possible values:
592 C<TRUE> - Always compress binaries
596 C<FALSE> - Never compress binaries
600 C<undef> - Compress binaries if it results in smaller database sizes (default)
604 =head2 compress_datetimes
606 $bool = $dumper->compress_datetimes;
608 Get whether or not to write compressed datetimes. Datetimes are traditionally written in the human-readable
609 string format of C<1970-01-01T00:00:00Z>, but they can also be written in a compressed form to save some
610 bytes. The default is to write compressed datetimes if the KDBX file version is 4+, otherwise use the
611 human-readable format.
615 $octets = $dumper->header_hash;
617 Get the value to be written as the B<HeaderHash> in the B<Meta> section. This is the way KDBX3 files validate
618 the authenticity of header data. This is unnecessary and should not be used with KDBX4 files because that
619 format uses HMAC-SHA256 to detect tampering.
621 L<File::KDBX::Dumper::V3> automatically calculates the header hash an provides it to this module, and plain
622 XML files which don't have a KDBX wrapper don't have headers and so should not have a header hash. Therefore
623 there is probably never any reason to set this manually.
627 Please report any bugs or feature requests on the bugtracker website
628 L<https://github.com/chazmcgarvey/File-KDBX/issues>
630 When submitting a bug or request, please include a test-file or a
631 patch to an existing test-file that illustrates the bug or desired
636 Charles McGarvey <ccm@cpan.org>
638 =head1 COPYRIGHT AND LICENSE
640 This software is copyright (c) 2022 by Charles McGarvey.
642 This is free software; you can redistribute it and/or modify it under
643 the same terms as the Perl 5 programming language system itself.