File Coverage

blib/lib/File/KDBX/IO/HashBlock.pm

Criterion	Covered	Total	%
statement	120	123	97.5
branch	45	72	62.5
condition	3	3	100.0
subroutine	20	20	100.0
pod	1	1	100.0
total	189	219	86.3

package File::KDBX::IO::HashBlock;
# ABSTRACT: Hash block stream IO handle

use warnings;
use strict;

use Crypt::Digest qw(digest_data);
use Errno;
use File::KDBX::Error;
use File::KDBX::Util qw(:class :io);
use IO::Handle;
use namespace::clean;

extends 'File::KDBX::IO';

our $VERSION = '0.906'; # VERSION
our $ALGORITHM = 'SHA256';
our $BLOCK_SIZE = 1048576;  # 1MiB
our $ERROR;


my %ATTRS = (
    _block_index    => 0,
    _buffer         => sub { \(my $buf = '') },
    _finished       => 0,
    algorithm       => sub { $ALGORITHM },
    block_size      => sub { $BLOCK_SIZE },
);
while (my ($attr, $default) = each %ATTRS) {
    no strict 'refs'; ## no critic (ProhibitNoStrict)
    *$attr = sub {
        my $self = shift;
        *$self->{$attr} = shift if @_;
        *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
    };
}


sub new {
    my $class = shift;
    my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
    my $self = $class->SUPER::new;
    $self->_fh($args{fh}) or throw 'IO handle required';
    $self->algorithm($args{algorithm});
    $self->block_size($args{block_size});
    $self->_buffer;
    return $self;
}

sub _FILL {
    my ($self, $fh) = @_;

    $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
    return if $self->_finished;

    my $block = eval { $self->_read_hash_block($fh) };
    if (my $err = $@) {
        $self->_set_error($err);
        return;
    }
    return $$block if defined $block;
}

sub _WRITE {
    my ($self, $buf, $fh) = @_;

    $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
    return 0 if $self->_finished;

    ${$self->_buffer} .= $buf;

    $self->_FLUSH($fh);

    return length($buf);
}

sub _POPPED {
    my ($self, $fh) = @_;

    $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
    return if $self->_mode ne 'w';

    $self->_FLUSH($fh);
    eval {
        $self->_write_next_hash_block($fh);     # partial block with remaining content
        $self->_write_final_hash_block($fh);    # terminating block
    };
    $self->_set_error($@) if $@;
}

sub _FLUSH {
    my ($self, $fh) = @_;

    $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
    return if $self->_mode ne 'w';

    eval {
        while ($self->block_size <= length(${*$self->{_buffer}})) {
            $self->_write_next_hash_block($fh);
        }
    };
    if (my $err = $@) {
        $self->_set_error($err);
        return -1;
    }

    return 0;
}

##############################################################################

sub _read_hash_block {
    my $self = shift;
    my $fh = shift;

    read_all $fh, my $buf, 4 or throw 'Failed to read hash block index';
    my ($index) = unpack('L<', $buf);

    $index == $self->_block_index or throw 'Invalid block index', index => $index;

    read_all $fh, my $hash, 32 or throw 'Failed to read hash';

    read_all $fh, $buf, 4 or throw 'Failed to read hash block size';
    my ($size) = unpack('L<', $buf);

    if ($size == 0) {
        $hash eq ("\0" x 32) or throw 'Invalid final block hash', hash => $hash;
        $self->_finished(1);
        return undef;
    }

    read_all $fh, my $block, $size or throw 'Failed to read hash block', index => $index, size => $size;

    my $got_hash = digest_data($self->algorithm, $block);
    $hash eq $got_hash
        or throw 'Hash mismatch', index => $index, size => $size, got => $got_hash, expected => $hash;

    *$self->{_block_index}++;
    return \$block;
}

sub _write_next_hash_block {
    my $self = shift;
    my $fh = shift;

    my $size = length(${$self->_buffer});
    $size = $self->block_size if $self->block_size < $size;
    return 0 if $size == 0;

    my $block = substr(${$self->_buffer}, 0, $size, '');

    my $buf = pack('L<', $self->_block_index);
    print $fh $buf or throw 'Failed to write hash block index';

    my $hash = digest_data($self->algorithm, $block);
    print $fh $hash or throw 'Failed to write hash';

    $buf = pack('L<', length($block));
    print $fh $buf or throw 'Failed to write hash block size';

    # $fh->write($block, $size) or throw 'Failed to hash write block';
    print $fh $block or throw 'Failed to hash write block';

    *$self->{_block_index}++;
    return 0;
}

sub _write_final_hash_block {
    my $self = shift;
    my $fh = shift;

    my $buf = pack('L<', $self->_block_index);
    print $fh $buf or throw 'Failed to write hash block index';

    my $hash = "\0" x 32;
    print $fh $hash or throw 'Failed to write hash';

    $buf = pack('L<', 0);
    print $fh $buf or throw 'Failed to write hash block size';

    $self->_finished(1);
    return 0;
}

sub _set_error {
    my $self = shift;
    $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
    if (exists &Errno::EPROTO) {
        $! = &Errno::EPROTO;
    }
    elsif (exists &Errno::EIO) {
        $! = &Errno::EIO;
    }
    $self->_error($ERROR = error(@_));
}

1;

__END__