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(assert_64bit erase_scoped gzip snakify);
14 use Scalar
::Util
qw(isdual looks_like_number);
21 use parent
'File::KDBX::Dumper';
23 our $VERSION = '999.999'; # VERSION
27 $self->{protect
} = shift if @_;
28 $self->{protect
} //= 1;
33 $self->{binaries
} = shift if @_;
34 $self->{binaries
} //= $self->kdbx->version < KDBX_VERSION_4_0
;
37 sub compress_binaries
{
39 $self->{compress_binaries
} = shift if @_;
40 $self->{compress_binaries
};
43 sub compress_datetimes
{
45 $self->{compress_datetimes
} = shift if @_;
46 $self->{compress_datetimes
};
49 sub header_hash
{ $_[0]->{header_hash
} }
51 sub _binaries_written
{ $_[0]->{_binaries_written
} //= {} }
53 sub _random_stream
{ $_[0]->{random_stream
} //= $_[0]->kdbx->random_stream }
59 $self->_write_inner_body($fh, $self->header_hash);
62 sub _write_inner_body
{
65 my $header_hash = shift;
67 my $dom = XML
::LibXML
::Document-
>new('1.0', 'UTF-8');
68 $dom->setStandalone(1);
70 my $doc = XML
::LibXML
::Element-
>new('KeePassFile');
71 $dom->setDocumentElement($doc);
73 my $meta = XML
::LibXML
::Element-
>new('Meta');
74 $doc->appendChild($meta);
75 $self->_write_xml_meta($meta, $header_hash);
77 my $root = XML
::LibXML
::Element-
>new('Root');
78 $doc->appendChild($root);
79 $self->_write_xml_root($root);
87 my $header_hash = shift;
89 my $meta = $self->kdbx->meta;
90 local $meta->{generator
} = $self->kdbx->user_agent_string // __PACKAGE__
;
91 local $meta->{header_hash
} = $header_hash;
93 $self->_write_xml_from_pairs($node, $meta,
95 $self->kdbx->version < KDBX_VERSION_4_0
&& defined $meta->{header_hash
} ? (
96 HeaderHash
=> 'binary',
98 DatabaseName
=> 'text',
99 DatabaseNameChanged
=> 'datetime',
100 DatabaseDescription
=> 'text',
101 DatabaseDescriptionChanged
=> 'datetime',
102 DefaultUserName
=> 'text',
103 DefaultUserNameChanged
=> 'datetime',
104 MaintenanceHistoryDays
=> 'number',
106 MasterKeyChanged
=> 'datetime',
107 MasterKeyChangeRec
=> 'number',
108 MasterKeyChangeForce
=> 'number',
109 MemoryProtection
=> \
&_write_xml_memory_protection
,
110 CustomIcons
=> \
&_write_xml_custom_icons
,
111 RecycleBinEnabled
=> 'bool',
112 RecycleBinUUID
=> 'uuid',
113 RecycleBinChanged
=> 'datetime',
114 EntryTemplatesGroup
=> 'uuid',
115 EntryTemplatesGroupChanged
=> 'datetime',
116 LastSelectedGroup
=> 'uuid',
117 LastTopVisibleGroup
=> 'uuid',
118 HistoryMaxItems
=> 'number',
119 HistoryMaxSize
=> 'number',
120 $self->kdbx->version >= KDBX_VERSION_4_0
? (
121 SettingsChanged
=> 'datetime',
123 $self->kdbx->version < KDBX_VERSION_4_0
|| $self->binaries ? (
124 Binaries
=> \
&_write_xml_binaries
,
126 CustomData
=> \
&_write_xml_custom_data
,
130 sub _write_xml_memory_protection
{
134 my $memory_protection = $self->kdbx->meta->{memory_protection
};
136 $self->_write_xml_from_pairs($node, $memory_protection,
137 ProtectTitle
=> 'bool',
138 ProtectUserName
=> 'bool',
139 ProtectPassword
=> 'bool',
140 ProtectURL
=> 'bool',
141 ProtectNotes
=> 'bool',
142 # AutoEnableVisualHiding => 'bool',
146 sub _write_xml_binaries
{
150 my $kdbx = $self->kdbx;
152 my $new_ref = keys %{$self->_binaries_written};
153 my $written = $self->_binaries_written;
155 my $entries = $kdbx->all_entries(history
=> true
);
156 for my $entry (@$entries) {
157 for my $key (keys %{$entry->binaries}) {
158 my $binary = $entry->binaries->{$key};
159 if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
160 $binary = $kdbx->binaries->{$binary->{ref}};
163 if (!defined $binary->{value
}) {
164 alert
"Skipping binary which has no value: $key", key
=> $key;
168 my $hash = digest_data
('SHA256', $binary->{value
});
169 if (defined $written->{$hash}) {
173 my $binary_node = $node->addNewChild(undef, 'Binary');
174 $binary_node->setAttribute('ID', _encode_text
($new_ref));
175 $binary_node->setAttribute('Protected', _encode_bool
(true
)) if $binary->{protect
};
176 $self->_write_xml_compressed_content($binary_node, \
$binary->{value
}, $binary->{protect
});
177 $written->{$hash} = $new_ref++;
183 sub _write_xml_compressed_content
{
192 if (utf8
::is_utf8
($$value)) {
193 $encoded = encode
('UTF-8', $$value);
194 push @cleanup, erase_scoped
$encoded;
198 my $always_compress = $self->compress_binaries;
199 my $try_compress = $always_compress || !defined $always_compress;
203 $compressed = gzip
($$value);
204 push @cleanup, erase_scoped
$compressed;
206 if ($always_compress || length($compressed) < length($$value)) {
207 $value = \
$compressed;
208 $node->setAttribute('Compressed', _encode_bool
(true
));
214 $encrypted = $self->_random_stream->crypt($$value);
215 push @cleanup, erase_scoped
$encrypted;
216 $value = \
$encrypted;
219 $node->appendText(_encode_binary
($$value));
222 sub _write_xml_custom_icons
{
226 my $custom_icons = $self->kdbx->meta->{custom_icons
} || {};
228 for my $uuid (sort keys %$custom_icons) {
229 my $icon = $custom_icons->{$uuid};
230 my $icon_node = $node->addNewChild(undef, 'Icon');
232 $self->_write_xml_from_pairs($icon_node, $icon,
235 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
237 LastModificationTime
=> 'datetime',
243 sub _write_xml_custom_data
{
246 my $custom_data = shift || {};
248 for my $key (sort keys %$custom_data) {
249 my $item = $custom_data->{$key};
250 my $item_node = $node->addNewChild(undef, 'Item');
252 local $item->{key
} = $key if !defined $item->{key
};
254 $self->_write_xml_from_pairs($item_node, $item,
257 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
258 LastModificationTime
=> 'datetime',
264 sub _write_xml_root
{
267 my $kdbx = $self->kdbx;
269 my $is_locked = $kdbx->is_locked;
270 my $guard = Scope
::Guard-
>new(sub { $kdbx->lock if $is_locked });
273 if (my $group = $kdbx->{root
}) {
274 my $group_node = $node->addNewChild(undef, 'Group');
275 $self->_write_xml_group($group_node, $group);
278 undef $guard; # re-lock if needed, as early as possible
280 my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects');
281 $self->_write_xml_deleted_objects($deleted_objects_node);
284 sub _write_xml_group
{
289 $self->_write_xml_from_pairs($node, $group,
293 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
297 defined $group->{custom_icon_uuid
} ? (
298 CustomIconUUID
=> 'uuid',
300 Times
=> \
&_write_xml_times
,
301 IsExpanded
=> 'bool',
302 DefaultAutoTypeSequence
=> 'text',
303 EnableAutoType
=> 'tristate',
304 EnableSearching
=> 'tristate',
305 LastTopVisibleEntry
=> 'uuid',
306 KDBX_VERSION_4_0
<= $self->kdbx->version ? (
307 CustomData
=> \
&_write_xml_custom_data
,
309 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
310 PreviousParentGroup
=> 'uuid',
314 for my $entry (@{$group->{entries
} || []}) {
315 my $entry_node = $node->addNewChild(undef, 'Entry');
316 $self->_write_xml_entry($entry_node, $entry);
319 for my $group (@{$group->{groups
} || []}) {
320 my $group_node = $node->addNewChild(undef, 'Group');
321 $self->_write_xml_group($group_node, $group);
325 sub _write_xml_entry
{
329 my $in_history = shift;
331 $self->_write_xml_from_pairs($node, $entry,
334 defined $entry->{custom_icon_uuid
} ? (
335 CustomIconUUID
=> 'uuid',
337 ForegroundColor
=> 'text',
338 BackgroundColor
=> 'text',
339 OverrideURL
=> 'text',
341 Times
=> \
&_write_xml_times
,
342 KDBX_VERSION_4_1
<= $self->kdbx->version ? (
343 QualityCheck
=> 'bool',
344 PreviousParentGroup
=> 'uuid',
348 for my $key (sort keys %{$entry->{strings
} || {}}) {
349 my $string = $entry->{strings
}{$key};
350 my $string_node = $node->addNewChild(undef, 'String');
351 local $string->{key
} = $string->{key
} // $key;
352 $self->_write_xml_entry_string($string_node, $string);
355 my $kdbx = $self->kdbx;
356 my $new_ref = keys %{$self->_binaries_written};
357 my $written = $self->_binaries_written;
359 for my $key (sort keys %{$entry->{binaries
} || {}}) {
360 my $binary = $entry->binaries->{$key};
361 if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
362 $binary = $kdbx->binaries->{$binary->{ref}};
365 if (!defined $binary->{value
}) {
366 alert
"Skipping binary which has no value: $key", key
=> $key;
370 my $binary_node = $node->addNewChild(undef, 'Binary');
371 $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text
($key));
372 my $value_node = $binary_node->addNewChild(undef, 'Value');
374 my $hash = digest_data
('SHA256', $binary->{value
});
375 if (defined $written->{$hash}) {
377 $value_node->setAttribute('Ref', _encode_text
($written->{$hash}));
380 # write actual binary
381 $value_node->setAttribute('Protected', _encode_bool
(true
)) if $binary->{protect
};
382 $self->_write_xml_compressed_content($value_node, \
$binary->{value
}, $binary->{protect
});
383 $written->{$hash} = $new_ref++;
387 $self->_write_xml_from_pairs($node, $entry,
388 AutoType
=> \
&_write_xml_entry_auto_type
,
391 $self->_write_xml_from_pairs($node, $entry,
392 KDBX_VERSION_4_0
<= $self->kdbx->version ? (
393 CustomData
=> \
&_write_xml_custom_data
,
398 if (my @history = @{$entry->{history
} || []}) {
399 my $history_node = $node->addNewChild(undef, 'History');
400 for my $historical (@history) {
401 my $historical_node = $history_node->addNewChild(undef, 'Entry');
402 $self->_write_xml_entry($historical_node, $historical, 1);
408 sub _write_xml_entry_auto_type
{
411 my $autotype = shift;
413 $self->_write_xml_from_pairs($node, $autotype,
415 DataTransferObfuscation
=> 'number',
416 DefaultSequence
=> 'text',
419 for my $association (@{$autotype->{associations
} || []}) {
420 my $association_node = $node->addNewChild(undef, 'Association');
421 $self->_write_xml_from_pairs($association_node, $association,
423 KeystrokeSequence
=> 'text',
428 sub _write_xml_times
{
433 $self->_write_xml_from_pairs($node, $times,
434 LastModificationTime
=> 'datetime',
435 CreationTime
=> 'datetime',
436 LastAccessTime
=> 'datetime',
437 ExpiryTime
=> 'datetime',
439 UsageCount
=> 'number',
440 LocationChanged
=> 'datetime',
444 sub _write_xml_entry_string
{
451 my $kdbx = $self->kdbx;
452 my $key = $string->{key
};
454 $node->addNewChild(undef, 'Key')->appendText(_encode_text
($key));
455 my $value_node = $node->addNewChild(undef, 'Value');
457 my $value = $string->{value
} || '';
459 my $memory_protection = $kdbx->meta->{memory_protection
};
460 my $memprot_key = 'protect_' . snakify
($key);
461 my $protect = $string->{protect
} || $memory_protection->{$memprot_key};
464 if ($self->protect) {
466 if (utf8
::is_utf8
($value)) {
467 $encoded = encode
('UTF-8', $value);
468 push @cleanup, erase_scoped
$encoded;
472 $value_node->setAttribute('Protected', _encode_bool
(true
));
473 $value = _encode_binary
($self->_random_stream->crypt(\
$value));
476 $value_node->setAttribute('ProtectInMemory', _encode_bool
(true
));
477 $value = _encode_text
($value);
481 $value = _encode_text
($value);
484 $value_node->appendText($value) if defined $value;
487 sub _write_xml_deleted_objects
{
491 my $objects = $self->kdbx->deleted_objects;
493 for my $uuid (sort keys %{$objects || {}}) {
494 my $object = $objects->{$uuid};
495 local $object->{uuid
} = $uuid;
496 my $object_node = $node->addNewChild(undef, 'DeletedObject');
497 $self->_write_xml_from_pairs($object_node, $object,
499 DeletionTime
=> 'datetime',
504 ##############################################################################
506 sub _write_xml_from_pairs
{
513 my ($name, $type) = splice @spec, 0, 2;
514 my $key = snakify
($name);
516 if (ref $type eq 'CODE') {
517 my $child_node = $node->addNewChild(undef, $name);
518 $self->$type($child_node, $hash->{$key});
521 next if !exists $hash->{$key};
522 my $child_node = $node->addNewChild(undef, $name);
523 $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes;
524 $child_node->appendText(_encode_primitive
($hash->{$key}, $type));
529 ##############################################################################
531 sub _encode_primitive
{ goto &{__PACKAGE__
."::_encode_$_[1]"} }
534 return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]);
535 return encode_b64
(ref $_[0] ? $$_[0] : $_[0]);
540 return $_ ? 'True' : 'False';
543 sub _encode_datetime
{
544 goto &_encode_datetime_binary
if defined $_[2] && KDBX_VERSION_4_0
<= $_[2];
546 return $_->strftime('%Y-%m-%dT%H:%M:%SZ');
549 sub _encode_datetime_binary
{
552 my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH
;
553 my $buf = pack('Q<', $seconds_since_ad1->epoch);
554 return eval { encode_b64
($buf) };
557 sub _encode_tristate
{
558 local $_ = shift // return 'null';
559 return $_ ? 'True' : 'False';
563 local $_ = shift // return;
564 looks_like_number
($_) || isdual
($_) or throw
'Expected number', text
=> $_;
565 return _encode_text
($_+0);
569 return '' if !defined $_[0];
573 sub _encode_uuid
{ _encode_binary
(@_) }