Dogcows Code - chaz/p5-File-KDBX/blob - 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(:uuid load_optional);
  13 use namespace::clean;
  14
  15 use parent '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     # TODO create a KPX_CUSTOM_ICONS_4 meta stream. FKP itself handles KPX_GROUP_TREE_STATE
  33
  34     substr($k->header->{seed_rand}, 16) = '';
  35
  36     $key = $self->kdbx->composite_key($key, keep_primitive => 1);
  37
  38     my $dump = eval { $k->gen_db(File::KDBX::Loader::KDB::_convert_kdbx_to_keepass_master_key($key)) };
  39     if (my $err = $@) {
  40         throw 'Failed to generate KDB file', error => $err;
  41     }
  42
  43     $self->kdbx->key($key);
  44
  45     print $fh $dump;
  46 }
  47
  48 sub _write_custom_icons {
  49     my $self = shift;
  50     my $kdbx = shift;
  51     my $k    = shift;
  52
  53     return if $kdbx->sig2 != KDBX_SIG2_1;
  54     return if $k->find_entries({
  55         title       => 'Meta-Info',
  56         username    => 'SYSTEM',
  57         url         => '$',
  58         comment     => 'KPX_CUSTOM_ICONS_4',
  59     });
  60
  61     my @icons;      # icon data
  62     my %icons;      # icon uuid -> index
  63     my %entries;    # id -> index
  64     my %groups;     # id -> index
  65     my %gid;
  66
  67     for my $uuid (sort keys %{$kdbx->custom_icons}) {
  68         my $icon = $kdbx->custom_icons->{$uuid};
  69         my $data = $icon->{data} or next;
  70         push @icons, $data;
  71         $icons{$uuid} = $#icons;
  72     }
  73     for my $entry ($k->find_entries({})) {
  74         my $icon_uuid = $entry->{custom_icon_uuid} // next;
  75         my $icon_index = $icons{$icon_uuid} // next;
  76
  77         $entry->{id} //= generate_uuid;
  78         next if $entries{$entry->{id}};
  79
  80         $entries{$entry->{id}} = $icon_index;
  81     }
  82     for my $group ($k->find_groups({})) {
  83         $gid{$group->{id} || ''}++;
  84         my $icon_uuid = $group->{custom_icon_uuid} // next;
  85         my $icon_index = $icons{$icon_uuid} // next;
  86
  87         if ($group->{id} =~ /^[A-Fa-f0-9]{16}$/) {
  88             $group->{id} = hex($group->{id});
  89         }
  90         elsif ($group->{id} !~ /^\d+$/) {
  91             do {
  92                 $group->{id} = irand;
  93             } while $gid{$group->{id}};
  94         }
  95         $gid{$group->{id}}++;
  96         next if $groups{$group->{id}};
  97
  98         $groups{$group->{id}} = $icon_index;
  99     }
 100
 101     return if !@icons;
 102
 103     my $stream = '';
 104     $stream .= pack('L<3', scalar @icons, scalar keys %entries, scalar keys %groups);
 105     for (my $i = 0; $i < @icons; ++$i) {
 106         $stream .= pack('L<', length($icons[$i]));
 107         $stream .= $icons[$i];
 108     }
 109     while (my ($id, $icon_index) = each %entries) {
 110         $stream .= pack('a16 L<', $id, $icon_index);
 111     }
 112     while (my ($id, $icon_index) = each %groups) {
 113         $stream .= pack('L<2', $id, $icon_index);
 114     }
 115
 116     $k->add_entry({
 117         comment     => 'KPX_CUSTOM_ICONS_4',
 118         title       => 'Meta-Info',
 119         username    => 'SYSTEM',
 120         url         => '$',
 121         id          => '0' x 16,
 122         icon        => 0,
 123         binary      => {'bin-stream' => $stream},
 124     });
 125 }
 126
 127 1;
 128 __END__
 129
 130 =head1 DESCRIPTION
 131
 132 Dump older KDB (KeePass 1) files. This feature requires additional modules to be installed:
 133
 134 =for :list
 135 * L<File::KeePass>
 136 * L<File::KeePass::KDBX>
 137
 138 =cut