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(: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