]> Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Dumper/KDB.pm
Prereq CryptX 0.049 for encode_b32*
[chaz/p5-File-KDBX] / lib / File / KDBX / Dumper / KDB.pm
1 package File::KDBX::Dumper::KDB;
2 # ABSTRACT: Write KDB files
3
4 use warnings;
5 use strict;
6
7 use Crypt::PRNG qw(irand);
8 use Encode qw(encode);
9 use File::KDBX::Constants qw(:magic);
10 use File::KDBX::Error;
11 use File::KDBX::Loader::KDB;
12 use File::KDBX::Util qw(:class :uuid load_optional);
13 use namespace::clean;
14
15 extends 'File::KDBX::Dumper';
16
17 our $VERSION = '999.999'; # VERSION
18
19 sub _write_magic_numbers { '' }
20 sub _write_headers { '' }
21
22 sub _write_body {
23 my $self = shift;
24 my $fh = shift;
25 my $key = shift;
26
27 load_optional(qw{File::KeePass File::KeePass::KDBX});
28
29 my $k = File::KeePass::KDBX->new($self->kdbx)->to_fkp;
30 $self->_write_custom_icons($self->kdbx, $k);
31
32 substr($k->header->{seed_rand}, 16) = '';
33
34 $key = $self->kdbx->composite_key($key, keep_primitive => 1);
35
36 my $dump = eval { $k->gen_db(File::KDBX::Loader::KDB::_convert_kdbx_to_keepass_master_key($key)) };
37 if (my $err = $@) {
38 throw 'Failed to generate KDB file', error => $err;
39 }
40
41 $self->kdbx->key($key);
42
43 print $fh $dump;
44 }
45
46 sub _write_custom_icons {
47 my $self = shift;
48 my $kdbx = shift;
49 my $k = shift;
50
51 return if $kdbx->sig2 != KDBX_SIG2_1;
52 return if $k->find_entries({
53 title => 'Meta-Info',
54 username => 'SYSTEM',
55 url => '$',
56 comment => 'KPX_CUSTOM_ICONS_4',
57 });
58
59 my @icons; # icon data
60 my %icons; # icon uuid -> index
61 my %entries; # id -> index
62 my %groups; # id -> index
63 my %gid;
64
65 for my $icon (@{$kdbx->custom_icons}) {
66 my $uuid = $icon->{uuid};
67 my $data = $icon->{data} or next;
68 push @icons, $data;
69 $icons{$uuid} = $#icons;
70 }
71 for my $entry ($k->find_entries({})) {
72 my $icon_uuid = $entry->{custom_icon_uuid} // next;
73 my $icon_index = $icons{$icon_uuid} // next;
74
75 $entry->{id} //= generate_uuid;
76 next if $entries{$entry->{id}};
77
78 $entries{$entry->{id}} = $icon_index;
79 }
80 for my $group ($k->find_groups({})) {
81 $gid{$group->{id} || ''}++;
82 my $icon_uuid = $group->{custom_icon_uuid} // next;
83 my $icon_index = $icons{$icon_uuid} // next;
84
85 if ($group->{id} =~ /^[A-Fa-f0-9]{16}$/) {
86 $group->{id} = hex($group->{id});
87 }
88 elsif ($group->{id} !~ /^\d+$/) {
89 do {
90 $group->{id} = irand;
91 } while $gid{$group->{id}};
92 }
93 $gid{$group->{id}}++;
94 next if $groups{$group->{id}};
95
96 $groups{$group->{id}} = $icon_index;
97 }
98
99 return if !@icons;
100
101 my $stream = '';
102 $stream .= pack('L<3', scalar @icons, scalar keys %entries, scalar keys %groups);
103 for (my $i = 0; $i < @icons; ++$i) {
104 $stream .= pack('L<', length($icons[$i]));
105 $stream .= $icons[$i];
106 }
107 while (my ($id, $icon_index) = each %entries) {
108 $stream .= pack('a16 L<', $id, $icon_index);
109 }
110 while (my ($id, $icon_index) = each %groups) {
111 $stream .= pack('L<2', $id, $icon_index);
112 }
113
114 $k->add_entry({
115 comment => 'KPX_CUSTOM_ICONS_4',
116 title => 'Meta-Info',
117 username => 'SYSTEM',
118 url => '$',
119 id => '0' x 16,
120 icon => 0,
121 binary => {'bin-stream' => $stream},
122 });
123 }
124
125 1;
126 __END__
127
128 =head1 DESCRIPTION
129
130 Dump older KDB (KeePass 1) files. This feature requires additional modules to be installed:
131
132 =for :list
133 * L<File::KeePass>
134 * L<File::KeePass::KDBX>
135
136 =cut
This page took 0.04214 seconds and 4 git commands to generate.