1 package File
::KDBX
::Dumper
;
2 # ABSTRACT: Write KDBX files
7 use Crypt
::Digest
qw(digest_data);
8 use File
::KDBX
::Constants
qw(:magic :header :version :random_stream);
13 use Ref
::Util
qw(is_ref is_scalarref);
14 use Scalar
::Util
qw(looks_like_number openhandle);
17 our $VERSION = '999.999'; # VERSION
21 $dumper = File
::KDBX
::Dumper-
>new(%attributes);
23 Construct a new L
<File
::KDBX
::Dumper
>.
29 my $self = bless {}, $class;
35 $dumper = $dumper->init(%attributes);
37 Initialize a L
<File
::KDBX
::Dumper
> with a new set of attributes
.
39 This
is called by L
</new
>.
47 @$self{keys %args} = values %args;
54 my $format = shift // $self->format;
56 my $version = $self->kdbx->version;
60 if (defined $format) {
63 elsif (!defined $version) {
66 elsif ($self->kdbx->sig2 == KDBX_SIG2_1
) {
69 elsif (looks_like_number
($version)) {
70 my $major = $version & KDBX_VERSION_MAJOR_MASK
;
72 KDBX_VERSION_2_0
() => 'V3',
73 KDBX_VERSION_3_0
() => 'V3',
74 KDBX_VERSION_4_0
() => 'V4',
76 if ($major == KDBX_VERSION_2_0
) {
77 alert
sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1
);
78 $self->kdbx->version(KDBX_VERSION_3_1
);
80 $subclass = $subclasses{$major}
81 or throw
sprintf('Unsupported KDBX file version: %x', $version), version
=> $version;
84 throw
sprintf('Unknown file version: %s', $version), version
=> $version;
87 load
"File::KDBX::Dumper::$subclass";
88 bless $self, "File::KDBX::Dumper::$subclass";
93 $dumper = $dumper->reset;
95 Set a L
<File
::KDBX
::Dumper
> to a blank
state, ready to dumper another KDBX file
.
107 $dumper->dump(\
$string, $key);
108 $dumper->dump(*IO
, $key);
109 $dumper->dump($filepath, $key);
113 The C
<$key> is either a L
<File
::KDBX
::Key
> or a primitive that can be converted to a Key object
.
120 return $self->dump_handle($dst, @_) if openhandle
($dst);
121 return $self->dump_string($dst, @_) if is_scalarref
($dst);
122 return $self->dump_file($dst, @_) if defined $dst && !is_ref
($dst);
123 throw
'Programmer error: Must pass a stringref, filepath or IO handle to dump';
128 $dumper->dump_string(\
$string, $key);
129 \
$string = $dumper->dump_string($key);
131 Dump a KDBX file to a string
/ memory buffer
.
137 my $ref = is_scalarref
($_[0]) ? shift : undef;
138 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
140 my $key = delete $args{key
};
141 $args{kdbx
} //= $self->kdbx;
148 open(my $fh, '>', $ref) or throw
"Failed to open string buffer: $!";
150 $self = $self->new if !ref $self;
151 $self->init(%args, fh
=> $fh)->_dump($fh, $key);
158 $dumper->dump_file($filepath, $key);
160 Dump a KDBX file to a filesystem
.
166 my $filepath = shift;
167 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
169 my $key = delete $args{key
};
170 $args{kdbx
} //= $self->kdbx;
173 my ($fh, $filepath_temp) = eval { File
::Temp
::tempfile
("${filepath}-XXXXXX", CLEANUP
=> 1) };
174 if (!$fh or my $err = $@) {
175 $err //= 'Unknown error';
176 throw
sprintf('Open file failed (%s): %s', $filepath_temp, $err),
178 filepath
=> $filepath_temp;
182 $self = $self->new if !ref $self;
183 $self->init(%args, fh
=> $fh, filepath
=> $filepath);
184 $self->_dump($fh, $key);
187 my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
189 my $mode = $args{mode
} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
190 my $uid = $args{uid
} // $file_uid // -1;
191 my $gid = $args{gid
} // $file_gid // -1;
192 chmod($mode, $filepath_temp) if defined $mode;
193 chown($uid, $gid, $filepath_temp);
194 rename($filepath_temp, $filepath) or throw
"Failed to write file ($filepath): $!", filepath
=> $filepath;
201 $dumper->dump_handle($fh, $key);
202 $dumper->dump_handle(*IO
, $key);
204 Dump a KDBX file to an input stream
/ file handle
.
211 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
213 $fh = *STDOUT
if $fh eq '-';
215 my $key = delete $args{key
};
216 $args{kdbx
} //= $self->kdbx;
218 $self = $self->new if !ref $self;
219 $self->init(%args, fh
=> $fh)->_dump($fh, $key);
224 $kdbx = $dumper->kdbx;
225 $dumper->kdbx($kdbx);
227 Get
or set the L
<File
::KDBX
> instance with the data to be dumped
.
233 return File
::KDBX-
>new if !ref $self;
234 $self->{kdbx
} = shift if @_;
235 $self->{kdbx
} //= File
::KDBX-
>new;
240 Get the file format used
for writing the database
. Normally the format
is auto-detected from the database
,
241 which
is the safest choice
. Possible formats
:
247 * C<XML> (only used if explicitly set)
248 * C<Raw> (only used if explicitly set)
250 B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
251 features used by the KDBX database being written.
253 The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
255 $kdbx->dump_file('database.xml', format => 'XML');
259 sub format
{ $_[0]->{format
} }
263 Get the format of the data inside the KDBX envelope
. This only applies to C
<V3
> and C
<V4
> formats
. Possible
267 * C<XML> - Write the database groups and entries as XML (default)
268 * C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
272 sub inner_format
{ $_[0]->{inner_format
} // 'XML' }
276 $min_version = File
::KDBX
::Dumper-
>min_version;
278 Get the minimum KDBX file version supported
, which
is 3.0 or C
<0x00030000> as
281 To generate older KDBX files unsupported by this module
, try L
<File
::KeePass
>.
285 sub min_version
{ KDBX_VERSION_OLDEST
}
289 $bool = $dumper->allow_upgrade;
291 Whether
or not to allow implicitly upgrading a database to a newer version
. When enabled
, in order to avoid
292 potential data loss
, the database can be upgraded as-needed
in cases where the database file format version
is
293 too low to support new features being used
.
295 The
default is to allow upgrading
.
299 sub allow_upgrade
{ $_[0]->{allow_upgrade
} // 1 }
301 =attr randomize_seeds
303 $bool = $dumper->randomize_seeds;
305 Whether
or not to randomize seeds
in a database before writing
. The
default is to randomize seeds
, and there
's
306 not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
311 sub randomize_seeds { $_[0]->{randomize_seeds} // 1 }
313 sub _fh { $_[0]->{fh} or throw 'IO handle
not set
' }
320 my $kdbx = $self->kdbx;
322 my $min_version = $kdbx->minimum_version;
323 if ($kdbx->version < $min_version && $self->allow_upgrade) {
324 alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
325 version => $kdbx->version, min_version => $min_version;
326 $kdbx->version($min_version);
330 if (ref($self) =~ /::(?:KDB|V[34])$/) {
331 $key //= $kdbx->key ? $kdbx->key->reload : undef;
332 defined $key or throw 'Must provide a master key
', type => 'key
.missing
';
337 my $magic = $self->_write_magic_numbers($fh);
338 my $headers = $self->_write_headers($fh);
342 $self->_write_body($fh, $key, "$magic$headers");
349 my $kdbx = $self->kdbx;
351 if ($kdbx->version < KDBX_VERSION_4_0) {
352 # force Salsa20 inner random stream
353 $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
354 my $key = $kdbx->inner_random_stream_key;
355 substr($key, 32) = '';
356 $kdbx->inner_random_stream_key($key);
359 $kdbx->randomize_seeds if $self->randomize_seeds;
362 sub _write_magic_numbers {
366 my $kdbx = $self->kdbx;
368 $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature
', sig1 => $kdbx->sig1;
369 $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version
370 and throw 'Unsupported file version
', version => $kdbx->version;
372 my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
374 my $buf = pack('L
<3', @magic);
375 $fh->print($buf) or throw 'Failed to
write file signature
';
380 sub _write_headers { die "Not implemented" }
382 sub _write_body { die "Not implemented" }
384 sub _write_inner_body {
387 my $current_pkg = ref $self;
388 require Scope::Guard;
389 my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
391 $self->_rebless($self->inner_format);
392 $self->_write_inner_body(@_);