Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/Dumper.pm

   1 package File::KDBX::Dumper;
   2 # ABSTRACT: Write KDBX files
   3
   4 use warnings;
   5 use strict;
   6
   7 use Crypt::Digest qw(digest_data);
   8 use File::KDBX::Constants qw(:magic :header :version :random_stream);
   9 use File::KDBX::Error;
  10 use File::KDBX::Util qw(:class);
  11 use File::KDBX;
  12 use IO::Handle;
  13 use Module::Load;
  14 use Ref::Util qw(is_ref is_scalarref);
  15 use Scalar::Util qw(looks_like_number openhandle);
  16 use namespace::clean;
  17
  18 our $VERSION = '0.903'; # VERSION
  19
  20
  21 sub new {
  22     my $class = shift;
  23     my $self = bless {}, $class;
  24     $self->init(@_);
  25 }
  26
  27
  28 sub init {
  29     my $self = shift;
  30     my %args = @_;
  31
  32     @$self{keys %args} = values %args;
  33
  34     return $self;
  35 }
  36
  37 sub _rebless {
  38     my $self    = shift;
  39     my $format  = shift // $self->format;
  40
  41     my $version = $self->kdbx->version;
  42
  43     my $subclass;
  44
  45     if (defined $format) {
  46         $subclass = $format;
  47     }
  48     elsif (!defined $version) {
  49         $subclass = 'XML';
  50     }
  51     elsif ($self->kdbx->sig2 == KDBX_SIG2_1) {
  52         $subclass = 'KDB';
  53     }
  54     elsif (looks_like_number($version)) {
  55         my $major = $version & KDBX_VERSION_MAJOR_MASK;
  56         my %subclasses = (
  57             KDBX_VERSION_2_0()  => 'V3',
  58             KDBX_VERSION_3_0()  => 'V3',
  59             KDBX_VERSION_4_0()  => 'V4',
  60         );
  61         if ($major == KDBX_VERSION_2_0) {
  62             alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1);
  63             $self->kdbx->version(KDBX_VERSION_3_1);
  64         }
  65         $subclass = $subclasses{$major}
  66             or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
  67     }
  68     else {
  69         throw sprintf('Unknown file version: %s', $version), version => $version;
  70     }
  71
  72     load "File::KDBX::Dumper::$subclass";
  73     bless $self, "File::KDBX::Dumper::$subclass";
  74 }
  75
  76
  77 sub reset {
  78     my $self = shift;
  79     %$self = ();
  80     return $self;
  81 }
  82
  83
  84 sub dump {
  85     my $self = shift;
  86     my $dst  = shift;
  87     return $self->dump_handle($dst, @_) if openhandle($dst);
  88     return $self->dump_string($dst, @_) if is_scalarref($dst);
  89     return $self->dump_file($dst, @_)   if defined $dst && !is_ref($dst);
  90     throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump';
  91 }
  92
  93
  94 sub dump_string {
  95     my $self = shift;
  96     my $ref  = is_scalarref($_[0]) ? shift : undef;
  97     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
  98
  99     my $key = delete $args{key};
 100     $args{kdbx} //= $self->kdbx;
 101
 102     $ref //= do {
 103         my $buf = '';
 104         \$buf;
 105     };
 106
 107     open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";
 108
 109     $self = $self->new if !ref $self;
 110     $self->init(%args, fh => $fh)->_dump($fh, $key);
 111
 112     return $ref;
 113 }
 114
 115
 116 sub dump_file {
 117     my $self     = shift;
 118     my $filepath = shift;
 119     my %args     = @_ % 2 == 0 ? @_ : (key => shift, @_);
 120
 121     my $key     = delete $args{key};
 122     my $mode    = delete $args{mode};
 123     my $uid     = delete $args{uid};
 124     my $gid     = delete $args{gid};
 125     my $atomic  = delete $args{atomic} // 1;
 126
 127     $args{kdbx} //= $self->kdbx;
 128
 129     my ($fh, $filepath_temp);
 130     if ($atomic) {
 131         require File::Temp;
 132         ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", UNLINK => 1) };
 133         if (!$fh or my $err = $@) {
 134             $err //= 'Unknown error';
 135             throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
 136                 error       => $err,
 137                 filepath    => $filepath_temp;
 138         }
 139     }
 140     else {
 141         open($fh, '>:raw', $filepath) or throw "Open file failed ($filepath): $!", filepath => $filepath;
 142     }
 143     $fh->autoflush(1);
 144
 145     $self = $self->new if !ref $self;
 146     $self->init(%args, fh => $fh, filepath => $filepath);
 147     $self->_dump($fh, $key);
 148     close($fh);
 149
 150     my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
 151
 152     if ($filepath_temp) {
 153         $mode //= $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
 154         $uid  //= $file_uid  // -1;
 155         $gid  //= $file_gid  // -1;
 156         chmod($mode, $filepath_temp) if defined $mode;
 157         chown($uid, $gid, $filepath_temp);
 158         rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!",
 159             filepath => $filepath;
 160     }
 161
 162     return $self;
 163 }
 164
 165
 166 sub dump_handle {
 167     my $self = shift;
 168     my $fh   = shift;
 169     my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
 170
 171     $fh = *STDOUT if $fh eq '-';
 172
 173     my $key = delete $args{key};
 174     $args{kdbx} //= $self->kdbx;
 175
 176     $self = $self->new if !ref $self;
 177     $self->init(%args, fh => $fh)->_dump($fh, $key);
 178 }
 179
 180
 181 sub kdbx {
 182     my $self = shift;
 183     return File::KDBX->new if !ref $self;
 184     $self->{kdbx} = shift if @_;
 185     $self->{kdbx} //= File::KDBX->new;
 186 }
 187
 188
 189 has 'format',           is => 'ro';
 190 has 'inner_format',     is => 'ro', default => 'XML';
 191 has 'allow_upgrade',    is => 'ro', default => 1;
 192 has 'randomize_seeds',  is => 'ro', default => 1;
 193
 194 sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
 195
 196 sub _dump {
 197     my $self = shift;
 198     my $fh = shift;
 199     my $key = shift;
 200
 201     my $kdbx = $self->kdbx;
 202
 203     my $min_version = $kdbx->minimum_version;
 204     if ($kdbx->version < $min_version && $self->allow_upgrade) {
 205         alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
 206             version => $kdbx->version, min_version => $min_version;
 207         $kdbx->version($min_version);
 208     }
 209     $self->_rebless;
 210
 211     if (ref($self) =~ /::(?:KDB|V[34])$/) {
 212         $key //= $kdbx->key ? $kdbx->key->reload : undef;
 213         defined $key or throw 'Must provide a master key', type => 'key.missing';
 214     }
 215
 216     $self->_prepare;
 217
 218     my $magic = $self->_write_magic_numbers($fh);
 219     my $headers = $self->_write_headers($fh);
 220
 221     $kdbx->unlock;
 222
 223     $self->_write_body($fh, $key, "$magic$headers");
 224
 225     return $kdbx;
 226 }
 227
 228 sub _prepare {
 229     my $self = shift;
 230     my $kdbx = $self->kdbx;
 231
 232     if ($kdbx->version < KDBX_VERSION_4_0) {
 233         # force Salsa20 inner random stream
 234         $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
 235         my $key = $kdbx->inner_random_stream_key;
 236         substr($key, 32) = '';
 237         $kdbx->inner_random_stream_key($key);
 238     }
 239
 240     $kdbx->randomize_seeds if $self->randomize_seeds;
 241 }
 242
 243 sub _write_magic_numbers {
 244     my $self = shift;
 245     my $fh = shift;
 246
 247     my $kdbx = $self->kdbx;
 248
 249     $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
 250     $kdbx->version < KDBX_VERSION_OLDEST || KDBX_VERSION_LATEST < $kdbx->version
 251         and throw 'Unsupported file version', version => $kdbx->version;
 252
 253     my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
 254
 255     my $buf = pack('L<3', @magic);
 256     $fh->print($buf) or throw 'Failed to write file signature';
 257
 258     return $buf;
 259 }
 260
 261 sub _write_headers { die "Not implemented" }
 262
 263 sub _write_body { die "Not implemented" }
 264
 265 sub _write_inner_body {
 266     my $self = shift;
 267
 268     my $current_pkg = ref $self;
 269     require Scope::Guard;
 270     my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
 271
 272     $self->_rebless($self->inner_format);
 273     $self->_write_inner_body(@_);
 274 }
 275
 276 1;
 277
 278 __END__
 279
 280 =pod
 281
 282 =encoding UTF-8
 283
 284 =head1 NAME
 285
 286 File::KDBX::Dumper - Write KDBX files
 287
 288 =head1 VERSION
 289
 290 version 0.903
 291
 292 =head1 ATTRIBUTES
 293
 294 =head2 kdbx
 295
 296     $kdbx = $dumper->kdbx;
 297     $dumper->kdbx($kdbx);
 298
 299 Get or set the L<File::KDBX> instance with the data to be dumped.
 300
 301 =head2 format
 302
 303 Get the file format used for writing the database. Normally the format is auto-detected from the database,
 304 which is the safest choice. Possible formats:
 305
 306 =over 4
 307
 308 =item *
 309
 310 C<V3>
 311
 312 =item *
 313
 314 C<V4>
 315
 316 =item *
 317
 318 C<KDB>
 319
 320 =item *
 321
 322 C<XML> (only used if explicitly set)
 323
 324 =item *
 325
 326 C<Raw> (only used if explicitly set)
 327
 328 =back
 329
 330 B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
 331 features used by the KDBX database being written.
 332
 333 The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
 334
 335     $kdbx->dump_file('database.xml', format => 'XML');
 336
 337 =head2 inner_format
 338
 339 Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
 340 formats:
 341
 342 =over 4
 343
 344 =item *
 345
 346 C<XML> - Write the database groups and entries as XML (default)
 347
 348 =item *
 349
 350 C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
 351
 352 =back
 353
 354 =head2 allow_upgrade
 355
 356     $bool = $dumper->allow_upgrade;
 357
 358 Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid
 359 potential data loss, the database can be upgraded as-needed in cases where the database file format version is
 360 too low to support new features being used.
 361
 362 The default is to allow upgrading.
 363
 364 =head2 randomize_seeds
 365
 366     $bool = $dumper->randomize_seeds;
 367
 368 Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's
 369 not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
 370 they are.
 371
 372 =head1 METHODS
 373
 374 =head2 new
 375
 376     $dumper = File::KDBX::Dumper->new(%attributes);
 377
 378 Construct a new L<File::KDBX::Dumper>.
 379
 380 =head2 init
 381
 382     $dumper = $dumper->init(%attributes);
 383
 384 Initialize a L<File::KDBX::Dumper> with a new set of attributes.
 385
 386 This is called by L</new>.
 387
 388 =head2 reset
 389
 390     $dumper = $dumper->reset;
 391
 392 Set a L<File::KDBX::Dumper> to a blank state, ready to dump another KDBX file.
 393
 394 =head2 dump
 395
 396     $dumper->dump(\$string, %options);
 397     $dumper->dump(\$string, $key, %options);
 398     $dumper->dump(*IO, %options);
 399     $dumper->dump(*IO, $key, %options);
 400     $dumper->dump($filepath, %options);
 401     $dumper->dump($filepath, $key, %options);
 402
 403 Dump a KDBX file.
 404
 405 The C<$key> is either a L<File::KDBX::Key> or a primitive castable to a Key object. Available options:
 406
 407 =over 4
 408
 409 =item *
 410
 411 C<kdbx> - Database to dump (default: value of L</kdbx>)
 412
 413 =item *
 414
 415 C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 416
 417 =back
 418
 419 Other options are supported depending on the first argument. See L</dump_string>, L</dump_file> and
 420 L</dump_handle>.
 421
 422 =head2 dump_string
 423
 424     $dumper->dump_string(\$string, %options);
 425     $dumper->dump_string(\$string, $key, %options);
 426     \$string = $dumper->dump_string(%options);
 427     \$string = $dumper->dump_string($key, %options);
 428
 429 Dump a KDBX file to a string / memory buffer. Available options:
 430
 431 =over 4
 432
 433 =item *
 434
 435 C<kdbx> - Database to dump (default: value of L</kdbx>)
 436
 437 =item *
 438
 439 C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 440
 441 =back
 442
 443 =head2 dump_file
 444
 445     $dumper->dump_file($filepath, %options);
 446     $dumper->dump_file($filepath, $key, %options);
 447
 448 Dump a KDBX file to a filesystem. Available options:
 449
 450 =over 4
 451
 452 =item *
 453
 454 C<kdbx> - Database to dump (default: value of L</kdbx>)
 455
 456 =item *
 457
 458 C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 459
 460 =item *
 461
 462 C<mode> - File mode / permissions (see L<perlfunc/"chmod LIST">
 463
 464 =item *
 465
 466 C<uid> - User ID (see L<perlfunc/"chown LIST">)
 467
 468 =item *
 469
 470 C<gid> - Group ID (see L<perlfunc/"chown LIST">)
 471
 472 =item *
 473
 474 C<atomic> - Write to the filepath atomically (default: true)
 475
 476 =back
 477
 478 =head2 dump_handle
 479
 480     $dumper->dump_handle($fh, %options);
 481     $dumper->dump_handle(*IO, $key, %options);
 482     $dumper->dump_handle($fh, %options);
 483     $dumper->dump_handle(*IO, $key, %options);
 484
 485 Dump a KDBX file to an output stream / file handle. Available options:
 486
 487 =over 4
 488
 489 =item *
 490
 491 C<kdbx> - Database to dump (default: value of L</kdbx>)
 492
 493 =item *
 494
 495 C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 496
 497 =back
 498
 499 =head1 BUGS
 500
 501 Please report any bugs or feature requests on the bugtracker website
 502 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 503
 504 When submitting a bug or request, please include a test-file or a
 505 patch to an existing test-file that illustrates the bug or desired
 506 feature.
 507
 508 =head1 AUTHOR
 509
 510 Charles McGarvey <ccm@cpan.org>
 511
 512 =head1 COPYRIGHT AND LICENSE
 513
 514 This software is copyright (c) 2022 by Charles McGarvey.
 515
 516 This is free software; you can redistribute it and/or modify it under
 517 the same terms as the Perl 5 programming language system itself.
 518
 519 =cut