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;
172 # require File::Temp;
173 # # my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
174 # my $fh = eval { File::Temp->new(TEMPLATE => "${filepath}-XXXXXX", CLEANUP => 1) };
175 # my $filepath_temp = $fh->filename;
176 # if (!$fh or my $err = $@) {
177 # $err //= 'Unknown error';
178 # throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
180 # filepath => $filepath_temp;
182 open(my $fh, '>:raw', $filepath) or die "open failed ($filepath): $!";
186 $self = $self->new if !ref $self;
187 $self->init(%args, fh
=> $fh, filepath
=> $filepath);
189 $self->_dump($fh, $key);
191 # binmode($fh, ':raw');
194 # my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
196 # my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
197 # my $uid = $args{uid} // $file_uid // -1;
198 # my $gid = $args{gid} // $file_gid // -1;
199 # chmod($mode, $filepath_temp) if defined $mode;
200 # chown($uid, $gid, $filepath_temp);
201 # rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
208 $dumper->dump_handle($fh, $key);
209 $dumper->dump_handle(*IO
, $key);
211 Dump a KDBX file to an input stream
/ file handle
.
218 my %args = @_ % 2 == 0 ? @_ : (key
=> shift, @_);
220 $fh = *STDOUT
if $fh eq '-';
222 my $key = delete $args{key
};
223 $args{kdbx
} //= $self->kdbx;
225 $self = $self->new if !ref $self;
226 $self->init(%args, fh
=> $fh)->_dump($fh, $key);
231 $kdbx = $dumper->kdbx;
232 $dumper->kdbx($kdbx);
234 Get
or set the L
<File
::KDBX
> instance with the data to be dumped
.
240 return File
::KDBX-
>new if !ref $self;
241 $self->{kdbx
} = shift if @_;
242 $self->{kdbx
} //= File
::KDBX-
>new;
249 sub format
{ $_[0]->{format
} }
250 sub inner_format
{ $_[0]->{inner_format
} // 'XML' }
254 $min_version = File
::KDBX
::Dumper-
>min_version;
256 Get the minimum KDBX file version supported
, which
is 3.0 or C
<0x00030000> as
259 To generate older KDBX files unsupported by this module
, try L
<File
::KeePass
>.
263 sub min_version
{ KDBX_VERSION_OLDEST
}
265 sub upgrade
{ $_[0]->{upgrade
} // 1 }
267 sub randomize_seeds
{ $_[0]->{randomize_seeds
} // 1 }
269 sub _fh
{ $_[0]->{fh
} or throw
'IO handle not set' }
276 my $kdbx = $self->kdbx;
278 my $min_version = $kdbx->minimum_version;
279 if ($kdbx->version < $min_version && $self->upgrade) {
280 alert
sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
281 version
=> $kdbx->version, min_version
=> $min_version;
282 $kdbx->version($min_version);
286 if (ref($self) =~ /::(?:KDB|V[34])$/) {
287 $key //= $kdbx->key ? $kdbx->key->reload : undef;
288 defined $key or throw
'Must provide a master key', type
=> 'key.missing';
293 my $magic = $self->_write_magic_numbers($fh);
294 my $headers = $self->_write_headers($fh);
298 $self->_write_body($fh, $key, "$magic$headers");
305 my $kdbx = $self->kdbx;
307 if ($kdbx->version < KDBX_VERSION_4_0
) {
308 # force Salsa20 inner random stream
309 $kdbx->inner_random_stream_id(STREAM_ID_SALSA20
);
310 my $key = $kdbx->inner_random_stream_key;
311 substr($key, 32) = '';
312 $kdbx->inner_random_stream_key($key);
315 $kdbx->randomize_seeds if $self->randomize_seeds;
318 sub _write_magic_numbers
{
322 my $kdbx = $self->kdbx;
324 $kdbx->sig1 == KDBX_SIG1
or throw
'Invalid file signature', sig1
=> $kdbx->sig1;
325 $kdbx->version < $self->min_version || KDBX_VERSION_LATEST
< $kdbx->version
326 and throw
'Unsupported file version', version
=> $kdbx->version;
328 my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
330 my $buf = pack('L<3', @magic);
331 $fh->print($buf) or throw
'Failed to write file signature';
336 sub _write_headers
{ die "Not implemented" }
338 sub _write_body
{ die "Not implemented" }
340 sub _write_inner_body
{
343 my $current_pkg = ref $self;
344 require Scope
::Guard
;
345 my $guard = Scope
::Guard-
>new(sub { bless $self, $current_pkg });
347 $self->_rebless($self->inner_format);
348 $self->_write_inner_body(@_);