view release on metacpan or  search on metacpan

lib/File/KDBX/Dumper.pm  view on Meta::CPAN

    my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);

    my $key = delete $args{key};
    $args{kdbx} //= $self->kdbx;

    $ref //= do {
        my $buf = '';
        \$buf;
    };

    open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";

    $self = $self->new if !ref $self;
    $self->init(%args, fh => $fh)->_dump($fh, $key);

    return $ref;
}


sub dump_file {
    my $self     = shift;
    my $filepath = shift;
    my %args     = @_ % 2 == 0 ? @_ : (key => shift, @_);

    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;

    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);

    $self = $self->new if !ref $self;
    $self->init(%args, fh => $fh, filepath => $filepath);
    $self->_dump($fh, $key);
    close($fh);

    my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];

    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;
}


sub dump_handle {
    my $self = shift;
    my $fh   = shift;
    my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);

    $fh = *STDOUT if $fh eq '-';

    my $key = delete $args{key};
    $args{kdbx} //= $self->kdbx;

    $self = $self->new if !ref $self;
    $self->init(%args, fh => $fh)->_dump($fh, $key);
}


sub kdbx {
    my $self = shift;
    return File::KDBX->new if !ref $self;
    $self->{kdbx} = shift if @_;
    $self->{kdbx} //= File::KDBX->new;
}


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' }

sub _dump {
    my $self = shift;
    my $fh = shift;
    my $key = shift;

    my $kdbx = $self->kdbx;

    my $min_version = $kdbx->minimum_version;
    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);
    }
    $self->_rebless;

    if (ref($self) =~ /::(?:KDB|V[34])$/) {
        $key //= $kdbx->key ? $kdbx->key->reload : undef;
        defined $key or throw 'Must provide a master key', type => 'key.missing';
    }

    $self->_prepare;

lib/File/KDBX/Dumper.pm  view on Meta::CPAN

=over 4

=item *

C<kdbx> - Database to dump (default: value of L</kdbx>)

=item *

C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)

=back

Other options are supported depending on the first argument. See L</dump_string>, L</dump_file> and
L</dump_handle>.

=head2 dump_string

    $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:

=over 4

=item *

C<kdbx> - Database to dump (default: value of L</kdbx>)

=item *

C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)

=back

=head2 dump_file

    $dumper->dump_file($filepath, %options);
    $dumper->dump_file($filepath, $key, %options);

Dump a KDBX file to a filesystem. Available options:

=over 4

=item *

C<kdbx> - Database to dump (default: value of L</kdbx>)

=item *

C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)

=item *

C<mode> - File mode / permissions (see L<perlfunc/"chmod LIST">

=item *

C<uid> - User ID (see L<perlfunc/"chown LIST">)

=item *

C<gid> - Group ID (see L<perlfunc/"chown LIST">)

=item *

C<atomic> - Write to the filepath atomically (default: true)

=back

=head2 dump_handle

    $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:

=over 4

=item *

C<kdbx> - Database to dump (default: value of L</kdbx>)

=item *

C<key> - Alternative way to specify C<$key> (default: value of L</File::KDBX/key>)

=back

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website
L<https://github.com/chazmcgarvey/File-KDBX/issues>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 AUTHOR

Charles McGarvey <ccm@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022 by Charles McGarvey.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut