X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FDumper.pm;h=39d4782b0b842ca8b0744730105d775d266cd96b;hb=796fdad82448b51f9c990ca461df647341a84b7e;hp=6d02063bdacce13c7f8369a72403ad7cf1400ca4;hpb=50f1a929d9224b9072b5fae39162a5d943323c5d;p=chaz%2Fp5-File-KDBX

diff --git a/lib/File/KDBX/Dumper.pm b/lib/File/KDBX/Dumper.pm
index 6d02063..39d4782 100644
--- a/lib/File/KDBX/Dumper.pm
+++ b/lib/File/KDBX/Dumper.pm
@@ -7,6 +7,7 @@ use strict;
 use Crypt::Digest qw(digest_data);
 use File::KDBX::Constants qw(:magic :header :version :random_stream);
 use File::KDBX::Error;
+use File::KDBX::Util qw(:class);
 use File::KDBX;
 use IO::Handle;
 use Module::Load;
@@ -92,7 +93,7 @@ sub _rebless {
 
     $dumper = $dumper->reset;
 
-Set a L<File::KDBX::Dumper> to a blank state, ready to dumper another KDBX file.
+Set a L<File::KDBX::Dumper> to a blank state, ready to dump another KDBX file.
 
 =cut
 
@@ -104,13 +105,23 @@ sub reset {
 
 =method dump
 
-    $dumper->dump(\$string, $key);
-    $dumper->dump(*IO, $key);
-    $dumper->dump($filepath, $key);
+    $dumper->dump(\$string, %options);
+    $dumper->dump(\$string, $key, %options);
+    $dumper->dump(*IO, %options);
+    $dumper->dump(*IO, $key, %options);
+    $dumper->dump($filepath, %options);
+    $dumper->dump($filepath, $key, %options);
 
 Dump a KDBX file.
 
-The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object.
+The C<$key> is either a L<File::KDBX::Key> or a primitive castable to a Key object. Available options:
+
+=for :list
+* C<kdbx> - Database to dump (default: value of L</kdbx>)
+* C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
+
+Other options are supported depending on the first argument. See L</dump_string>, L</dump_file> and
+L</dump_handle>.
 
 =cut
 
@@ -125,10 +136,16 @@ sub dump {
 
 =method dump_string
 
-    $dumper->dump_string(\$string, $key);
-    \$string = $dumper->dump_string($key);
+    $dumper->dump_string(\$string, %options);
+    $dumper->dump_string(\$string, $key, %options);
+    \$string = $dumper->dump_string(%options);
+    \$string = $dumper->dump_string($key, %options);
+
+Dump a KDBX file to a string / memory buffer. Available options:
 
-Dump a KDBX file to a string / memory buffer.
+=for :list
+* C<kdbx> - Database to dump (default: value of L</kdbx>)
+* C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 
 =cut
 
@@ -155,9 +172,18 @@ sub dump_string {
 
 =method dump_file
 
-    $dumper->dump_file($filepath, $key);
+    $dumper->dump_file($filepath, %options);
+    $dumper->dump_file($filepath, $key, %options);
 
-Dump a KDBX file to a filesystem.
+Dump a KDBX file to a filesystem. Available options:
+
+=for :list
+* C<kdbx> - Database to dump (default: value of L</kdbx>)
+* C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
+* C<mode> - File mode / permissions (see L<perlfunc/"chmod LIST">
+* C<uid> - User ID (see L<perlfunc/"chown LIST">)
+* C<gid> - Group ID (see L<perlfunc/"chown LIST">)
+* C<atomic> - Write to the filepath atomically (default: true)
 
 =cut
 
@@ -166,16 +192,27 @@ sub dump_file {
     my $filepath = shift;
     my %args     = @_ % 2 == 0 ? @_ : (key => shift, @_);
 
-    my $key = delete $args{key};
+    my $key     = delete $args{key};
+    my $mode    = delete $args{mode};
+    my $uid     = delete $args{uid};
+    my $gid     = delete $args{gid};
+    my $atomic  = delete $args{atomic} // 1;
+
     $args{kdbx} //= $self->kdbx;
 
-    require File::Temp;
-    my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
-    if (!$fh or my $err = $@) {
-        $err //= 'Unknown error';
-        throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
-            error       => $err,
-            filepath    => $filepath_temp;
+    my ($fh, $filepath_temp);
+    if ($atomic) {
+        require File::Temp;
+        ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", UNLINK => 1) };
+        if (!$fh or my $err = $@) {
+            $err //= 'Unknown error';
+            throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
+                error       => $err,
+                filepath    => $filepath_temp;
+        }
+    }
+    else {
+        open($fh, '>:raw', $filepath) or throw "Open file failed ($filepath): $!", filepath => $filepath;
     }
     $fh->autoflush(1);
 
@@ -186,22 +223,31 @@ sub dump_file {
 
     my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
 
-    my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
-    my $uid  = $args{uid}  // $file_uid  // -1;
-    my $gid  = $args{gid}  // $file_gid  // -1;
-    chmod($mode, $filepath_temp) if defined $mode;
-    chown($uid, $gid, $filepath_temp);
-    rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
+    if ($filepath_temp) {
+        $mode //= $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
+        $uid  //= $file_uid  // -1;
+        $gid  //= $file_gid  // -1;
+        chmod($mode, $filepath_temp) if defined $mode;
+        chown($uid, $gid, $filepath_temp);
+        rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!",
+            filepath => $filepath;
+    }
 
     return $self;
 }
 
 =method dump_handle
 
-    $dumper->dump_handle($fh, $key);
-    $dumper->dump_handle(*IO, $key);
+    $dumper->dump_handle($fh, %options);
+    $dumper->dump_handle(*IO, $key, %options);
+    $dumper->dump_handle($fh, %options);
+    $dumper->dump_handle(*IO, $key, %options);
+
+Dump a KDBX file to an output stream / file handle. Available options:
 
-Dump a KDBX file to an input stream / file handle.
+=for :list
+* C<kdbx> - Database to dump (default: value of L</kdbx>)
+* C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)
 
 =cut
 
@@ -237,27 +283,56 @@ sub kdbx {
 
 =attr format
 
-=cut
+Get the file format used for writing the database. Normally the format is auto-detected from the database,
+which is the safest choice. Possible formats:
 
-sub format { $_[0]->{format} }
-sub inner_format { $_[0]->{inner_format} // 'XML' }
+=for :list
+* C<V3>
+* C<V4>
+* C<KDB>
+* C<XML> (only used if explicitly set)
+* C<Raw> (only used if explicitly set)
 
-=attr min_version
+B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
+features used by the KDBX database being written.
 
-    $min_version = File::KDBX::Dumper->min_version;
+The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
 
-Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
-it is encoded.
+    $kdbx->dump_file('database.xml', format => 'XML');
 
-To generate older KDBX files unsupported by this module, try L<File::KeePass>.
+=attr inner_format
 
-=cut
+Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
+formats:
+
+=for :list
+* C<XML> - Write the database groups and entries as XML (default)
+* C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
+
+=attr allow_upgrade
+
+    $bool = $dumper->allow_upgrade;
 
-sub min_version { KDBX_VERSION_OLDEST }
+Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid
+potential data loss, the database can be upgraded as-needed in cases where the database file format version is
+too low to support new features being used.
 
-sub upgrade { $_[0]->{upgrade} // 1 }
+The default is to allow upgrading.
+
+=attr randomize_seeds
+
+    $bool = $dumper->randomize_seeds;
+
+Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's
+not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
+they are.
+
+=cut
 
-sub randomize_seeds { $_[0]->{randomize_seeds} // 1 }
+has 'format',           is => 'ro';
+has 'inner_format',     is => 'ro', default => 'XML';
+has 'allow_upgrade',    is => 'ro', default => 1;
+has 'randomize_seeds',  is => 'ro', default => 1;
 
 sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
 
@@ -269,7 +344,7 @@ sub _dump {
     my $kdbx = $self->kdbx;
 
     my $min_version = $kdbx->minimum_version;
-    if ($kdbx->version < $min_version && $self->upgrade) {
+    if ($kdbx->version < $min_version && $self->allow_upgrade) {
         alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
             version => $kdbx->version, min_version => $min_version;
         $kdbx->version($min_version);
@@ -315,7 +390,7 @@ sub _write_magic_numbers {
     my $kdbx = $self->kdbx;
 
     $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
-    $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version
+    $kdbx->version < KDBX_VERSION_OLDEST || KDBX_VERSION_LATEST < $kdbx->version
         and throw 'Unsupported file version', version => $kdbx->version;
 
     my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);