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);
10 use File
::KDBX
::Util
qw(:class);
14 use Ref
::Util
qw(is_ref is_scalarref);
15 use Scalar
::Util
qw(looks_like_number openhandle);
18 our $VERSION = '999.999'; # VERSION
22 $dumper = File
::KDBX
::Dumper-
>new(%attributes);
24 Construct a new L
<File
::KDBX
::Dumper
>.
30 my $self = bless {}, $class;
36 $dumper = $dumper->init(%attributes);
38 Initialize a L
<File
::KDBX
::Dumper
> with a new set of attributes
.
40 This
is called by L
</new
>.
48 @$self{keys %args} = values %args;
55 my $format = shift // $self->format;
57 my $version = $self->kdbx->version;
61 if (defined $format) {
64 elsif (!defined $version) {
67 elsif ($self->kdbx->sig2 == KDBX_SIG2_1
) {
70 elsif (looks_like_number
($version)) {
71 my $major = $version & KDBX_VERSION_MAJOR_MASK
;
73 KDBX_VERSION_2_0
() => 'V3',
74 KDBX_VERSION_3_0
() => 'V3',
75 KDBX_VERSION_4_0
() => 'V4',
77 if ($major == KDBX_VERSION_2_0
) {
78 alert
sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1
);
79 $self->kdbx->version(KDBX_VERSION_3_1
);
81 $subclass = $subclasses{$major}
82 or throw
sprintf('Unsupported KDBX file version: %x', $version), version
=> $version;
85 throw
sprintf('Unknown file version: %s', $version), version
=> $version;
88 load
"File::KDBX::Dumper::$subclass";
89 bless $self, "File::KDBX::Dumper::$subclass";
94 $dumper = $dumper->reset;
96 Set a L
<File
::KDBX
::Dumper
> to a blank
state, ready to
dump another KDBX file
.
108 $dumper->dump(\
$string, %options);
109 $dumper->dump(\
$string, $key, %options);
110 $dumper->dump(*IO
, %options);
111 $dumper->dump(*IO
, $key, %options);
112 $dumper->dump($filepath, %options);
113 $dumper->dump($filepath, $key, %options);
117 The C
<$key> is either a L
<File
::KDBX
::Key
> or a primitive castable to a Key object
. Available options
:
120 * C<kdbx> - Database to dump (default: value of L</kdbx>)
121 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
123 Other options are supported depending on the first argument. See L</dump_string>, L</dump_file> and
131 return $self->dump_handle($dst, @_) if openhandle
($dst);
132 return $self->dump_string($dst, @_) if is_scalarref
($dst);
133 return $self->dump_file($dst, @_) if defined $dst && !is_ref
($dst);
134 throw
'Programmer error: Must pass a stringref, filepath or IO handle to dump';
139 $dumper->dump_string(\
$string, %options);
140 $dumper->dump_string(\
$string, $key, %options);
141 \
$string = $dumper->dump_string(%options);
142 \
$string = $dumper->dump_string($key, %options);
144 Dump a KDBX file to a string
/ memory buffer
. Available options
:
147 * C<kdbx> - Database to dump (default: value of L</kdbx>)
148 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
154 my $ref = is_scalarref
($_[0]) ? shift : undef;
155 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
157 my $key = delete $args{key
};
158 $args{kdbx
} //= $self->kdbx;
165 open(my $fh, '>', $ref) or throw
"Failed to open string buffer: $!";
167 $self = $self->new if !ref $self;
168 $self->init(%args, fh
=> $fh)->_dump($fh, $key);
175 $dumper->dump_file($filepath, %options);
176 $dumper->dump_file($filepath, $key, %options);
178 Dump a KDBX file to a filesystem
. Available options
:
181 * C<kdbx> - Database to dump (default: value of L</kdbx>)
182 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
183 * C<mode> - File mode / permissions (see L<perlfunc/"chmod LIST">
184 * C<uid> - User ID (see L<perlfunc/"chown LIST">)
185 * C<gid> - Group ID (see L<perlfunc/"chown LIST">)
186 * C<atomic> - Write to the filepath atomically (default: true)
192 my $filepath = shift;
193 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
195 my $key = delete $args{key
};
196 my $mode = delete $args{mode
};
197 my $uid = delete $args{uid
};
198 my $gid = delete $args{gid
};
199 my $atomic = delete $args{atomic
} // 1;
201 $args{kdbx
} //= $self->kdbx;
203 my ($fh, $filepath_temp);
206 ($fh, $filepath_temp) = eval { File
::Temp
::tempfile
("${filepath}-XXXXXX", UNLINK
=> 1) };
207 if (!$fh or my $err = $@) {
208 $err //= 'Unknown error';
209 throw
sprintf('Open file failed (%s): %s', $filepath_temp, $err),
211 filepath
=> $filepath_temp;
215 open($fh, '>:raw', $filepath) or throw
"Open file failed ($filepath): $!", filepath
=> $filepath;
219 $self = $self->new if !ref $self;
220 $self->init(%args, fh
=> $fh, filepath
=> $filepath);
221 $self->_dump($fh, $key);
224 my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
226 if ($filepath_temp) {
227 $mode //= $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
228 $uid //= $file_uid // -1;
229 $gid //= $file_gid // -1;
230 chmod($mode, $filepath_temp) if defined $mode;
231 chown($uid, $gid, $filepath_temp);
232 rename($filepath_temp, $filepath) or throw
"Failed to write file ($filepath): $!",
233 filepath
=> $filepath;
241 $dumper->dump_handle($fh, %options);
242 $dumper->dump_handle(*IO
, $key, %options);
243 $dumper->dump_handle($fh, %options);
244 $dumper->dump_handle(*IO
, $key, %options);
246 Dump a KDBX file to an output stream
/ file handle
. Available options
:
249 * C<kdbx> - Database to dump (default: value of L</kdbx>)
250 * C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
257 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
259 $fh = *STDOUT
if $fh eq '-';
261 my $key = delete $args{key
};
262 $args{kdbx
} //= $self->kdbx;
264 $self = $self->new if !ref $self;
265 $self->init(%args, fh
=> $fh)->_dump($fh, $key);
270 $kdbx = $dumper->kdbx;
271 $dumper->kdbx($kdbx);
273 Get
or set the L
<File
::KDBX
> instance with the data to be dumped
.
279 return File
::KDBX-
>new if !ref $self;
280 $self->{kdbx
} = shift if @_;
281 $self->{kdbx
} //= File
::KDBX-
>new;
286 Get the file format used
for writing the database
. Normally the format
is auto-detected from the database
,
287 which
is the safest choice
. Possible formats
:
293 * C<XML> (only used if explicitly set)
294 * C<Raw> (only used if explicitly set)
296 B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
297 features used by the KDBX database being written.
299 The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
301 $kdbx->dump_file('database.xml', format => 'XML');
305 Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
309 * C<XML> - Write the database groups and entries as XML (default)
310 * C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
314 $bool = $dumper->allow_upgrade;
316 Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid
317 potential data loss, the database can be upgraded as-needed in cases where the database file format version is
318 too low to support new features being used.
320 The default is to allow upgrading.
322 =attr randomize_seeds
324 $bool = $dumper->randomize_seeds;
326 Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's
327 not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
332 has 'format', is => 'ro';
333 has 'inner_format', is => 'ro', default => 'XML';
334 has 'allow_upgrade', is => 'ro', default => 1;
335 has 'randomize_seeds', is => 'ro', default => 1;
337 sub _fh
{ $_[0]->{fh
} or throw
'IO handle not set' }
344 my $kdbx = $self->kdbx;
346 my $min_version = $kdbx->minimum_version;
347 if ($kdbx->version < $min_version && $self->allow_upgrade) {
348 alert
sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
349 version
=> $kdbx->version, min_version
=> $min_version;
350 $kdbx->version($min_version);
354 if (ref($self) =~ /::(?:KDB|V[34])$/) {
355 $key //= $kdbx->key ? $kdbx->key->reload : undef;
356 defined $key or throw
'Must provide a master key', type
=> 'key.missing';
361 my $magic = $self->_write_magic_numbers($fh);
362 my $headers = $self->_write_headers($fh);
366 $self->_write_body($fh, $key, "$magic$headers");
373 my $kdbx = $self->kdbx;
375 if ($kdbx->version < KDBX_VERSION_4_0
) {
376 # force Salsa20 inner random stream
377 $kdbx->inner_random_stream_id(STREAM_ID_SALSA20
);
378 my $key = $kdbx->inner_random_stream_key;
379 substr($key, 32) = '';
380 $kdbx->inner_random_stream_key($key);
383 $kdbx->randomize_seeds if $self->randomize_seeds;
386 sub _write_magic_numbers
{
390 my $kdbx = $self->kdbx;
392 $kdbx->sig1 == KDBX_SIG1
or throw
'Invalid file signature', sig1
=> $kdbx->sig1;
393 $kdbx->version < KDBX_VERSION_OLDEST
|| KDBX_VERSION_LATEST
< $kdbx->version
394 and throw
'Unsupported file version', version
=> $kdbx->version;
396 my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
398 my $buf = pack('L<3', @magic);
399 $fh->print($buf) or throw
'Failed to write file signature';
404 sub _write_headers
{ die "Not implemented" }
406 sub _write_body
{ die "Not implemented" }
408 sub _write_inner_body
{
411 my $current_pkg = ref $self;
412 require Scope
::Guard
;
413 my $guard = Scope
::Guard-
>new(sub { bless $self, $current_pkg });
415 $self->_rebless($self->inner_format);
416 $self->_write_inner_body(@_);