license = Perl_5
[@Author::CCM]
-:version = 0.011
-; the PerlIO layers are an implementation detail that might change
-no_index = lib/PerlIO/via/File/KDBX t xt
[Prereqs / RuntimeRecommends]
; B::COW might speed up the memory erase feature, maybe
File::KDBX::XS = 0
[OptionalFeature / compression]
--description = ability to read and write compressed KDBX files
--prompt = 0
--always_recommend = 1
-Compress::Raw::Zlib = 0
+-description = ability to read and write compressed KDBX files
+-prompt = 0
+-always_recommend = 1
+Compress::Raw::Zlib = 0
+IO::Compress::Gzip = 0
+IO::Uncompress::Gunzip = 0
[OptionalFeature / otp]
-description = ability to generate one-time passwords from configured database entries
sub iv { $_[0]->{iv} }
-=attr default_iv_size
+=attr iv_size
- $size = $cipher->default_iv_size;
+ $size = $cipher->iv_size;
-Get the default size of the initialization vector, in bytes.
+Get the expected size of the initialization vector, in bytes.
=cut
-sub key_size { -1 }
+sub iv_size { 0 }
=attr key_size
$size = $cipher->key_size;
-Get the size the mode expects the key to be, in bytes.
+Get the size the mode or stream expects the key to be, in bytes.
=cut
-sub iv_size { 0 }
+sub key_size { -1 }
=attr block_size
my $key = delete $args{key};
$args{kdbx} //= $self->kdbx;
- # require File::Temp;
- # # my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
- # my $fh = eval { File::Temp->new(TEMPLATE => "${filepath}-XXXXXX", CLEANUP => 1) };
- # my $filepath_temp = $fh->filename;
- # if (!$fh or my $err = $@) {
- # $err //= 'Unknown error';
- # throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
- # error => $err,
- # filepath => $filepath_temp;
- # }
- open(my $fh, '>:raw', $filepath) or die "open failed ($filepath): $!";
- binmode($fh);
- # $fh->autoflush(1);
+ 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;
+ }
+ $fh->autoflush(1);
$self = $self->new if !ref $self;
$self->init(%args, fh => $fh, filepath => $filepath);
- # binmode($fh);
$self->_dump($fh, $key);
+ close($fh);
- # binmode($fh, ':raw');
- # close($fh);
-
- # my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
+ 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;
+ 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;
return $self;
}
use Encode qw(encode);
use File::KDBX::Constants qw(:header :compression);
use File::KDBX::Error;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HashBlock;
use File::KDBX::Util qw(:empty assert_64bit erase_scoped);
use IO::Handle;
-use PerlIO::via::File::KDBX::Crypt;
-use PerlIO::via::File::KDBX::HashBlock;
use namespace::clean;
use parent 'File::KDBX::Dumper';
push @cleanup, erase_scoped $final_key;
my $cipher = $kdbx->cipher(key => $final_key);
- PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
$fh->print($kdbx->headers->{+HEADER_STREAM_START_BYTES})
or throw 'Failed to write start bytes';
$kdbx->key($key);
- PerlIO::via::File::KDBX::HashBlock->push($fh);
+ $fh = File::KDBX::IO::HashBlock->new($fh);
my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
if ($compress == COMPRESSION_GZIP) {
- require PerlIO::via::File::KDBX::Compression;
- PerlIO::via::File::KDBX::Compression->push($fh);
+ require IO::Compress::Gzip;
+ $fh = IO::Compress::Gzip->new($fh,
+ -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
+ -TextFlag => 1,
+ ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
+ error => $IO::Compress::Gzip::GzipError;
}
elsif ($compress != COMPRESSION_NONE) {
throw "Unsupported compression ($compress)\n", compression_flags => $compress;
my $header_hash = digest_data('SHA256', $header_data);
$self->_write_inner_body($fh, $header_hash);
-
- binmode($fh, ':pop') if $compress;
- binmode($fh, ':pop:pop');
}
1;
use Encode qw(encode is_utf8);
use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_map);
use File::KDBX::Error;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HmacBlock;
use File::KDBX::Util qw(:empty assert_64bit erase_scoped);
use IO::Handle;
-use PerlIO::via::File::KDBX::Crypt;
-use PerlIO::via::File::KDBX::HmacBlock;
use Scalar::Util qw(looks_like_number);
use boolean qw(:all);
use namespace::clean;
$kdbx->key($key);
# HMAC-block the rest of the stream
- PerlIO::via::File::KDBX::HmacBlock->push($fh, $hmac_key);
+ $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key);
my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
push @cleanup, erase_scoped $final_key;
my $cipher = $kdbx->cipher(key => $final_key);
- PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
if ($compress == COMPRESSION_GZIP) {
- require PerlIO::via::File::KDBX::Compression;
- PerlIO::via::File::KDBX::Compression->push($fh);
+ require IO::Compress::Gzip;
+ $fh = IO::Compress::Gzip->new($fh,
+ -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
+ -TextFlag => 1,
+ ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
+ error => $IO::Compress::Gzip::GzipError;
}
elsif ($compress != COMPRESSION_NONE) {
throw "Unsupported compression ($compress)\n", compression_flags => $compress;
local $self->{compress_datetimes} = 1;
$self->_write_inner_body($fh, $header_hash);
-
- binmode($fh, ':pop') if $compress;
- binmode($fh, ':pop:pop');
}
sub _write_inner_headers {
--- /dev/null
+package File::KDBX::IO;
+# ABSTRACT: Base IO class for KDBX-related streams
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Util qw(:empty :bool);
+use List::Util qw(sum0);
+use Ref::Util qw(is_blessed_ref is_ref is_scalarref);
+use Symbol qw(gensym);
+use namespace::clean;
+
+use parent 'IO::Handle';
+
+our $VERSION = '999.999'; # VERSION
+
+sub _croak { require Carp; goto &Carp::croak }
+
+my %ATTRS = (
+ _append_output => 0,
+ _buffer_in => sub { [] },
+ _buffer_out => sub { [] },
+ _error => undef,
+ _fh => undef,
+ _mode => '',
+);
+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 || (caller)[0];
+ my $self = bless gensym, ref($class) || $class;
+ tie *$self, $self if 5.005 <= $];
+ return $self;
+}
+
+sub DESTROY {
+ return if in_global_destruction;
+ my $self = shift;
+ $self->close;
+}
+
+sub close {
+ my $self = shift;
+ my $fh = $self->_fh // return TRUE;
+ $self->_POPPED($fh);
+ $self->_fh(undef);
+ return $fh->close;
+}
+sub eof {
+ my $self = shift;
+ return FALSE if @{$self->_buffer_in};
+ my $fh = $self->_fh // return TRUE;
+ local *$self->{_error} = *$self->{_error};
+ my $char = $self->getc || return TRUE;
+ $self->ungetc($char);
+}
+sub read { shift->sysread(@_) }
+sub print {
+ my $self = shift;
+ for my $buf (@_) {
+ return FALSE if !$self->write($buf, length($buf));
+ }
+ return TRUE;
+}
+sub printf { shift->print(sprintf(@_)) }
+sub say { shift->print(@_, "\n") }
+sub getc { my $c; (shift->read($c, 1) // 0) == 1 ? $c : undef }
+sub sysread {
+ my $self = shift;
+ my ($out, $len, $offset) = @_;
+ $out = \$_[0] if !is_scalarref($out);
+ $offset //= 0;
+
+ $self->_mode('r') if !$self->_mode;
+
+ my $fh = $self->_fh or return 0;
+ return 0 if defined $len && $len == 0;
+
+ my $append = $self->_append_output;
+ if (!$append) {
+ if (!$offset) {
+ $$out = '';
+ }
+ else {
+ if (length($$out) < $offset) {
+ $$out .= "\0" x ($offset - length($$out));
+ }
+ else {
+ substr($$out, $offset) = '';
+ }
+ }
+ }
+ elsif (!defined $$out) {
+ $$out = '';
+ }
+
+ $len ||= 0;
+
+ my $buffer = $self->_buffer_in;
+ my $buffer_len = $self->_buffer_in_length;
+
+ if (!$len && !$offset) {
+ if (@$buffer) {
+ my $blen = length($buffer->[0]);
+ if ($append) {
+ $$out .= shift @$buffer;
+ }
+ else {
+ $$out = shift @$buffer;
+ }
+ return $blen;
+ }
+ else {
+ my $fill = $self->_FILL($fh) or return 0;
+ if ($append) {
+ $$out .= $fill;
+ }
+ else {
+ $$out = $fill;
+ }
+ return length($fill);
+ }
+ }
+
+ while ($buffer_len < $len) {
+ my $fill = $self->_FILL($fh);
+ last if empty $fill;
+ $self->_buffer_in_add($fill);
+ $buffer_len += length($fill);
+ }
+
+ my $read_len = 0;
+ while ($read_len < $len && @$buffer) {
+ my $wanted = $len - $read_len;
+ my $read = shift @$buffer;
+ if ($wanted < length($read)) {
+ $$out .= substr($read, 0, $wanted, '');
+ unshift @$buffer, $read;
+ $read_len += $wanted;
+ }
+ else {
+ $$out .= $read;
+ $read_len += length($read);
+ }
+ }
+
+ return $read_len;
+}
+sub syswrite {
+ my ($self, $buf, $len, $offset) = @_;
+ $len //= length($buf);
+ $offset //= 0;
+
+ $self->_mode('w') if !$self->_mode;
+
+ return $self->_WRITE(substr($buf, $offset, $len), $self->_fh);
+}
+
+sub autoflush {
+ my $self = shift;
+ my $fh = $self->_fh // return FALSE;
+ return $fh->autoflush(@_);
+}
+
+sub opened {
+ my $self = shift;
+ my $fh = $self->_fh // return FALSE;
+ return TRUE;
+}
+sub getline {
+ my $self = shift;
+
+ if (!defined $/) { # SLURP
+ local *$self->{_append_output} = 1;
+ my $data;
+ 1 while 0 < $self->read($data);
+ return $data;
+ }
+ elsif (is_scalarref($/) && ${$/} =~ /^\d+$/ && 0 < ${$/}) {
+ # RECORD MODE
+ goto &_not_implemented;
+ }
+ elsif (length $/ == 0) {
+ # PARAGRAPH MODE
+ goto &_not_implemented;
+ }
+ else {
+ # LINE MODE
+ goto &_not_implemented;
+ }
+}
+sub getlines {
+ my $self = shift;
+ wantarray or _croak 'Must call getlines in list context';
+ my @lines;
+ while (defined (my $line = $self->getline)) {
+ push @lines, $line;
+ }
+ return @lines;
+}
+sub ungetc {
+ my ($self, $ord) = @_;
+ unshift @{$self->_buffer_in}, chr($ord);
+ return;
+}
+sub write {
+ my ($self, $buf, $len, $offset) = @_;
+ return $self->syswrite($buf, $len, $offset) == $len;
+}
+sub error {
+ my $self = shift;
+ return !!$self->_error;
+}
+sub clearerr {
+ my $self = shift;
+ my $fh = $self->_fh // return -1;
+ $self->_error(undef);
+ return;
+}
+sub sync {
+ my $self = shift;
+ my $fh = $self->_fh // return undef;
+ return $fh->sync;
+}
+sub flush {
+ my $self = shift;
+ my $fh = $self->_fh // return undef;
+ $self->_FLUSH($fh);
+ return $fh->flush;
+}
+sub printflush {
+ my $self = shift;
+ my $orig = $self->autoflush;
+ my $r = $self->print(@_);
+ $self->autoflush($orig);
+ return $r;
+}
+sub blocking {
+ my $self = shift;
+ my $fh = $self->_fh // return TRUE;
+ return $fh->blocking(@_);
+}
+
+sub format_write { goto &_not_implemented }
+sub new_from_fd { goto &_not_implemented }
+sub fcntl { goto &_not_implemented }
+sub fileno { goto &_not_implemented }
+sub ioctl { goto &_not_implemented }
+sub stat { goto &_not_implemented }
+sub truncate { goto &_not_implemented }
+sub format_page_number { goto &_not_implemented }
+sub format_lines_per_page { goto &_not_implemented }
+sub format_lines_left { goto &_not_implemented }
+sub format_name { goto &_not_implemented }
+sub format_top_name { goto &_not_implemented }
+sub input_line_number { goto &_not_implemented }
+sub fdopen { goto &_not_implemented }
+sub untaint { goto &_not_implemented }
+
+##############################################################################
+
+sub _buffer_in_add { push @{shift->_buffer_in}, @_ }
+sub _buffer_in_length { sum0 map { length($_) } @{shift->_buffer_in} }
+
+sub _buffer_out_add { push @{shift->_buffer_out}, @_ }
+sub _buffer_out_length { sum0 map { length($_) } @{shift->_buffer_out} }
+
+sub _not_implemented { _croak 'Operation not supported' }
+
+##############################################################################
+
+sub TIEHANDLE {
+ return $_[0] if is_blessed_ref($_[0]);
+ die 'wat';
+}
+
+sub UNTIE {
+ my $self = shift;
+}
+
+sub READLINE {
+ goto &getlines if wantarray;
+ goto &getline;
+}
+
+sub binmode { 1 }
+
+{
+ no warnings 'once';
+
+ *READ = \&read;
+ # *READLINE = \&getline;
+ *GETC = \&getc;
+ *FILENO = \&fileno;
+ *PRINT = \&print;
+ *PRINTF = \&printf;
+ *WRITE = \&syswrite;
+ # *SEEK = \&seek;
+ # *TELL = \&tell;
+ *EOF = \&eof;
+ *CLOSE = \&close;
+ *BINMODE = \&binmode;
+}
+
+sub _FILL { die 'Not implemented' }
+
+##############################################################################
+
+if ($ENV{DEBUG_IO}) {
+ my %debug = (level => 0);
+ for my $method (qw{
+ new
+ new_from_fd
+ close
+ eof
+ fcntl
+ fileno
+ format_write
+ getc
+ ioctl
+ read
+ print
+ printf
+ say
+ stat
+ sysread
+ syswrite
+ truncate
+
+ autoflush
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ input_line_number
+
+ fdopen
+ opened
+ getline
+ getlines
+ ungetc
+ write
+ error
+ clearerr
+ sync
+ flush
+ printflush
+ blocking
+
+ untaint
+ }) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ no warnings 'redefine';
+ my $orig = *$method{CODE};
+ *$method = sub {
+ local $debug{level} = $debug{level} + 2;
+ my $indented_method = (' ' x $debug{level}) . $method;
+ my $self = shift;
+ print STDERR sprintf('%-20s -> %s (%s)', $indented_method, $self,
+ join(', ', map { defined ? substr($_, 0, 16) : 'undef' } @_)), "\n";
+ my $r = $orig->($self, @_) // 'undef';
+ print STDERR sprintf('%-20s <- %s [%s]', $indented_method, $self, $r), "\n";
+ return $r;
+ };
+ }
+}
+
+1;
+__END__
+
+=begin Pod::Coverage
+
+autoflush
+binmode
+close
+eof
+fcntl
+fileno
+format_lines_left
+format_lines_per_page
+format_name
+format_page_number
+format_top_name
+format_write
+getc
+input_line_number
+ioctl
+print
+printf
+read
+say
+stat
+sysread
+syswrite
+truncate
+
+=end Pod::Coverage
+
+=head1 DESCRIPTION
+
+This is a L<IO::Handle> subclass which provides self-tying and buffering. It currently provides an interface
+for subclasses that is similar to L<PerlIO::via>, but this is subject to change. Don't depend on this outside
+of the L<File::KDBX> distribution. Currently-available subclasses:
+
+=for :list
+* L<File::KDBX::IO::Crypt>
+* L<File::KDBX::IO::HashBlock>
+* L<File::KDBX::IO::HmacBlock>
+
+=cut
--- /dev/null
+package File::KDBX::IO::Crypt;
+# ABSTRACT: Encrypter/decrypter IO handle
+
+use warnings;
+use strict;
+
+use Errno;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:empty);
+use namespace::clean;
+
+use parent 'File::KDBX::IO';
+
+our $VERSION = '999.999'; # VERSION
+our $BUFFER_SIZE = 16384;
+our $ERROR;
+
+=method new
+
+ $fh = File::KDBX::IO::Crypt->new(%attributes);
+ $fh = File::KDBX::IO::Crypt->new($fh, %attributes);
+
+Construct a new crypto IO handle.
+
+=cut
+
+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->cipher($args{cipher}) or throw 'Cipher required';
+ return $self;
+}
+
+=attr cipher
+
+A L<File::KDBX::Cipher> instance to do the actual encryption or decryption.
+
+=cut
+
+my %ATTRS = (
+ cipher => undef,
+);
+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 _FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ my $cipher = $self->cipher or return;
+
+ $fh->read(my $buf = '', $BUFFER_SIZE);
+ if (0 < length($buf)) {
+ my $plaintext = eval { $cipher->decrypt($buf) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ return $plaintext if 0 < length($plaintext);
+ }
+
+ # finish
+ my $plaintext = eval { $cipher->finish };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ $self->cipher(undef);
+ return $plaintext;
+}
+
+sub _WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ my $cipher = $self->cipher or return 0;
+
+ my $new_data = eval { $cipher->encrypt($buf) } || '';
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return 0;
+ }
+ $self->_buffer_out_add($new_data) if nonempty $new_data;
+ return length($buf);
+}
+
+sub _POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->_mode ne 'w';
+ my $cipher = $self->cipher or return;
+
+ my $new_data = eval { $cipher->finish } || '';
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ $self->_buffer_out_add($new_data) if nonempty $new_data;
+
+ $self->cipher(undef);
+ $self->_FLUSH($fh);
+}
+
+sub _FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return if $self->_mode ne 'w';
+
+ my $buffer = $self->_buffer_out;
+ while (@$buffer) {
+ my $read = shift @$buffer;
+ next if empty $read;
+ $fh->print($read) or return -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->cipher(undef);
+ $self->_error($ERROR = File::KDBX::Error->new(@_));
+}
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+ use File::KDBX::IO::Crypt;
+ use File::KDBX::Cipher;
+
+ my $cipher = File::KDBX::Cipher->new(...);
+
+ open(my $out_fh, '>:raw', 'ciphertext.bin');
+ $out_fh = File::KDBX::IO::Crypt->new($out_fh, cipher => $cipher);
+
+ print $out_fh $plaintext;
+
+ close($out_fh);
+
+ open(my $in_fh, '<:raw', 'ciphertext.bin');
+ $in_fh = File::KDBX::IO::Crypt->new($in_fh, cipher => $cipher);
+
+ my $plaintext = do { local $/; <$in_fh> );
+
+ close($in_fh);
+
+=cut
-package PerlIO::via::File::KDBX::HashBlock;
-# ABSTRACT: Hash block stream PerlIO layer
+package File::KDBX::IO::HashBlock;
+# ABSTRACT: Hash block stream IO handle
use warnings;
use strict;
use IO::Handle;
use namespace::clean;
+use parent 'File::KDBX::IO';
+
our $VERSION = '999.999'; # VERSION
our $ALGORITHM = 'SHA256';
-our $BLOCK_SIZE = 1048576;
+our $BLOCK_SIZE = 1048576; # 1MiB
our $ERROR;
-=method push
+=method new
- PerlIO::via::File::KDBX::HashBlock->push($fh, %attributes);
+ $fh = File::KDBX::IO::HashBlock->new(%attributes);
+ $fh = File::KDBX::IO::HashBlock->new($fh, %attributes);
-Push a new HashBlock layer, optionally with attributes.
+Construct a new hash-block stream IO handle.
-This is identical to:
+=cut
- binmode($fh, ':via(File::KDBX::HashBlock)');
+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;
+}
-except this allows you to customize the process with attributes.
+=attr algorithm
-B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
-C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
-before the filehandle closes so it can write the final block (which will likely be shorter than the other
-blocks), and the way to indicate that is by popping the layer.
+Digest algorithm in hash-blocking the stream (default: C<SHA-256>)
-=cut
+=attr block_size
-my %PUSHED_ARGS;
-sub push {
- %PUSHED_ARGS and throw 'Pushing Hash layer would stomp existing arguments';
- my $class = shift;
- my $fh = shift;
- %PUSHED_ARGS = @_;
- binmode($fh, ':via(' . __PACKAGE__ . ')');
-}
+Desired block size when writing (default: C<$File::KDBX::IO::HashBlock::BLOCK_SIZE> or 1,048,576 bytes)
-sub PUSHED {
- my ($class, $mode) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
- my $self = bless {
- algorithm => $PUSHED_ARGS{algorithm} || $ALGORITHM,
- block_index => 0,
- block_size => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
- buffer => \(my $buf = ''),
- eof => 0,
- mode => $mode,
- }, $class;
- %PUSHED_ARGS = ();
- return $self;
+=cut
+
+my %ATTRS = (
+ _block_index => 0,
+ _buffer => \(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 FILL {
+sub _FILL {
my ($self, $fh) = @_;
$ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
- return if $self->EOF($fh);
+ return if $self->_finished;
my $block = eval { $self->_read_hash_block($fh) };
if (my $err = $@) {
return $$block if defined $block;
}
-sub WRITE {
+sub _WRITE {
my ($self, $buf, $fh) = @_;
$ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
- return 0 if $self->EOF($fh);
+ return 0 if $self->_finished;
- ${$self->{buffer}} .= $buf;
+ ${$self->_buffer} .= $buf;
- $self->FLUSH($fh);
+ $self->_FLUSH($fh);
return length($buf);
}
-sub POPPED {
+sub _POPPED {
my ($self, $fh) = @_;
$ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
- return if $self->EOF($fh) || $self->mode !~ /^w/;
+ return if $self->_mode ne 'w';
- $self->FLUSH($fh);
+ $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 {
+sub _FLUSH {
my ($self, $fh) = @_;
$ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
- return 0 if !ref $self;
+ return if $self->_mode ne 'w';
eval {
- while ($self->block_size <= length(${$self->{buffer}})) {
+ while ($self->block_size <= length(${*$self->{_buffer}})) {
$self->_write_next_hash_block($fh);
}
};
return 0;
}
-sub EOF {
- $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
- $_[0]->{eof} || $_[0]->ERROR($_[1]);
-}
-sub ERROR {
- $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
- $ERROR = $_[0]->{error} if $_[0]->{error};
- $_[0]->{error} ? 1 : 0;
-}
-sub CLEARERR {
- $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
- # delete $_[0]->{error};
-}
-
-=attr algorithm
-
- $algo = $hash_block->algorithm;
-
-Get the hash algorithm. Default is C<SHA256>.
-
-=cut
-
-sub algorithm { $_[0]->{algorithm} //= $ALGORITHM }
-
-=attr block_size
-
- $size = $hash_block->block_size;
-
-Get the block size. Default is C<$PerlIO::via::File::KDBX::HashBlock::BLOCK_SIZE>.
-
-This only matters in write mode. When reading, block size is detected from the stream.
-
-=cut
-
-sub block_size { $_[0]->{block_size} //= $BLOCK_SIZE }
-
-=attr block_index
-
-=attr buffer
-
-=attr mode
-
-Internal attributes.
-
-=cut
-
-sub block_index { $_[0]->{block_index} ||= 0 }
-sub buffer { $_[0]->{buffer} }
-sub mode { $_[0]->{mode} }
+##############################################################################
sub _read_hash_block {
my $self = 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;
+ $index == $self->_block_index or throw 'Invalid block index', index => $index;
read_all $fh, my $hash, 32 or throw 'Failed to read hash';
my ($size) = unpack('L<', $buf);
if ($size == 0) {
- $hash eq ("\0" x 32)
- or throw 'Invalid final block hash', hash => $hash;
- $self->{eof} = 1;
+ $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('SHA256', $block);
+ 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}++;
+ *$self->{_block_index}++;
return \$block;
}
my $self = shift;
my $fh = shift;
- my $size = length(${$self->buffer});
+ 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 $block = substr(${$self->_buffer}, 0, $size, '');
- my $buf = pack('L<', $self->block_index);
+ my $buf = pack('L<', $self->_block_index);
print $fh $buf or throw 'Failed to write hash block index';
- my $hash = digest_data('SHA256', $block);
+ my $hash = digest_data($self->algorithm, $block);
print $fh $hash or throw 'Failed to write hash';
$buf = pack('L<', length($block));
# $fh->write($block, $size) or throw 'Failed to hash write block';
print $fh $block or throw 'Failed to hash write block';
- $self->{block_index}++;
+ *$self->{_block_index}++;
return 0;
}
my $self = shift;
my $fh = shift;
- my $buf = pack('L<', $self->block_index);
+ my $buf = pack('L<', $self->_block_index);
print $fh $buf or throw 'Failed to write hash block index';
my $hash = "\0" x 32;
$buf = pack('L<', 0);
print $fh $buf or throw 'Failed to write hash block size';
- $self->{eof} = 1;
+ $self->_finished(1);
return 0;
}
elsif (exists &Errno::EIO) {
$! = &Errno::EIO;
}
- $self->{error} = $ERROR = File::KDBX::Error->new(@_);
+ $self->_error($ERROR = error(@_));
}
1;
=head1 DESCRIPTION
-Writing to a handle with this layer will transform the data in a series of blocks. Each block is hashed, and
-the hash is included with the block in the stream.
+Writing to a hash-block handle will transform the data into a series of blocks. Each block is hashed, and the
+hash is included with the block in the stream.
Reading from a handle, each hash block will be verified as the blocks are disassembled back into a data
stream.
+This format helps ensure data integrity of KDBX3 files.
+
Each block is encoded thusly:
=for :list
--- /dev/null
+package File::KDBX::IO::HmacBlock;
+# ABSTRACT: HMAC block stream IO handle
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use Errno;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:io assert_64bit);
+use namespace::clean;
+
+use parent 'File::KDBX::IO';
+
+our $VERSION = '999.999'; # VERSION
+our $BLOCK_SIZE = 1048576; # 1MiB
+our $ERROR;
+
+=method new
+
+ $fh = File::KDBX::IO::HmacBlock->new(%attributes);
+ $fh = File::KDBX::IO::HmacBlock->new($fh, %attributes);
+
+Construct a new HMAC-block stream IO handle.
+
+=cut
+
+sub new {
+ assert_64bit;
+
+ my $class = shift;
+ my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
+ my $self = $class->SUPER::new;
+ $self->_fh($args{fh}) or throw 'IO handle required';
+ $self->key($args{key}) or throw 'Key required';
+ $self->block_size($args{block_size});
+ $self->_buffer;
+ return $self;
+}
+
+=attr block_size
+
+Desired block size when writing (default: C<$File::KDBX::IO::HmacBlock::BLOCK_SIZE> or 1,048,576 bytes)
+
+=attr key
+
+HMAC-SHA256 key for authenticating the data stream (required)
+
+=cut
+
+my %ATTRS = (
+ _block_index => 0,
+ _buffer => \(my $buf = ''),
+ _finished => 0,
+ block_size => sub { $BLOCK_SIZE },
+ key => undef,
+);
+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 _FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->_finished;
+
+ my $block = eval { $self->_read_hashed_block($fh) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ if (length($block) == 0) {
+ $self->_finished(1);
+ return;
+ }
+ return $block;
+}
+
+sub _WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self ($fh)\n";
+ return 0 if $self->_finished;
+
+ ${*$self->{_buffer}} .= $buf;
+
+ $self->_FLUSH($fh); # TODO only if autoflush?
+
+ return length($buf);
+}
+
+sub _POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self ($fh)\n";
+ return if $self->_mode ne 'w';
+
+ $self->_FLUSH($fh);
+ eval {
+ $self->_write_next_hmac_block($fh); # partial block with remaining content
+ $self->_write_final_hmac_block($fh); # terminating block
+ };
+ $self->_set_error($@) if $@;
+}
+
+sub _FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self ($fh)\n";
+ return if $self->_mode ne 'w';
+
+ eval {
+ while ($self->block_size <= length(${*$self->{_buffer}})) {
+ $self->_write_next_hmac_block($fh);
+ }
+ };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return -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(@_));
+}
+
+##############################################################################
+
+sub _read_hashed_block {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC';
+
+ read_all $fh, my $packed_size, 4 or throw 'Failed to read HMAC block size';
+ my ($size) = unpack('L<', $packed_size);
+
+ my $block = '';
+ if (0 < $size) {
+ read_all $fh, $block, $size
+ or throw 'Failed to read HMAC block', index => $self->_block_index, size => $size;
+ }
+
+ my $packed_index = pack('Q<', $self->_block_index);
+ my $got_hmac = hmac('SHA256', $self->_hmac_key,
+ $packed_index,
+ $packed_size,
+ $block,
+ );
+
+ $hmac eq $got_hmac
+ or throw 'Block authentication failed', index => $self->_block_index, got => $got_hmac, expected => $hmac;
+
+ *$self->{_block_index}++;
+ return $block;
+}
+
+sub _write_next_hmac_block {
+ my $self = shift;
+ my $fh = shift;
+ my $buffer = shift // $self->_buffer;
+ my $allow_empty = shift;
+
+ my $size = length($$buffer);
+ $size = $self->block_size if $self->block_size < $size;
+ return 0 if $size == 0 && !$allow_empty;
+
+ my $block = '';
+ $block = substr($$buffer, 0, $size, '') if 0 < $size;
+
+ my $packed_index = pack('Q<', $self->_block_index);
+ my $packed_size = pack('L<', $size);
+ my $hmac = hmac('SHA256', $self->_hmac_key,
+ $packed_index,
+ $packed_size,
+ $block,
+ );
+
+ $fh->print($hmac, $packed_size, $block)
+ or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size;
+
+ *$self->{_block_index}++;
+ return 0;
+}
+
+sub _write_final_hmac_block {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_next_hmac_block($fh, \'', 1);
+}
+
+sub _hmac_key {
+ my $self = shift;
+ my $key = shift // $self->key;
+ my $index = shift // $self->_block_index;
+
+ my $packed_index = pack('Q<', $index);
+ my $hmac_key = digest_data('SHA512', $packed_index, $key);
+ return $hmac_key;
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+Writing to a HMAC-block stream handle will transform the data into a series of blocks. An HMAC is calculated
+for each block and is included in the output.
+
+Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into
+a data stream.
+
+This format helps ensure data integrity and authenticity of KDBX4 files.
+
+Each block is encoded thusly:
+
+=for :list
+* HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data]
+* Block size - Little-endian unsigned 32-bit (counting only the data)
+* Data - String of bytes
+
+The terminating block is an empty block encoded as usual but block size is 0 and there is no data.
+
+=cut
use Encode qw(decode);
use File::KDBX::Constants qw(:header :compression :kdf);
use File::KDBX::Error;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HashBlock;
use File::KDBX::Util qw(:io assert_64bit erase_scoped);
-use PerlIO::via::File::KDBX::Crypt;
-use PerlIO::via::File::KDBX::HashBlock;
use namespace::clean;
use parent 'File::KDBX::Loader';
push @cleanup, erase_scoped $final_key;
my $cipher = $kdbx->cipher(key => $final_key);
- PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
read_all $fh, my $start_bytes, 32 or throw 'Failed to read starting bytes';
$kdbx->key($key);
- PerlIO::via::File::KDBX::HashBlock->push($fh);
+ $fh = File::KDBX::IO::HashBlock->new($fh);
my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
if ($compress == COMPRESSION_GZIP) {
- require PerlIO::via::File::KDBX::Compression;
- PerlIO::via::File::KDBX::Compression->push($fh);
+ require IO::Uncompress::Gunzip;
+ $fh = IO::Uncompress::Gunzip->new($fh)
+ or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError",
+ error => $IO::Uncompress::Gunzip::GunzipError;
}
elsif ($compress != COMPRESSION_NONE) {
throw "Unsupported compression ($compress)\n", compression_flags => $compress;
$self->_read_inner_body($fh);
- binmode($fh, ':pop') if $compress;
- binmode($fh, ':pop:pop');
-
if (my $header_hash = $kdbx->meta->{header_hash}) {
my $got_header_hash = digest_data('SHA256', $header_data);
$header_hash eq $got_header_hash
use File::KDBX::Constants qw(:header :inner_header :variant_map :compression);
use File::KDBX::Error;
use File::KDBX::Util qw(:io assert_64bit erase_scoped);
-use PerlIO::via::File::KDBX::Crypt;
-use PerlIO::via::File::KDBX::HmacBlock;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HmacBlock;
use boolean;
use namespace::clean;
$kdbx->key($key);
- PerlIO::via::File::KDBX::HmacBlock->push($fh, $hmac_key);
+ $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key);
my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
push @cleanup, erase_scoped $final_key;
my $cipher = $kdbx->cipher(key => $final_key);
- PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
if ($compress == COMPRESSION_GZIP) {
- require PerlIO::via::File::KDBX::Compression;
- PerlIO::via::File::KDBX::Compression->push($fh);
+ require IO::Uncompress::Gunzip;
+ $fh = IO::Uncompress::Gunzip->new($fh)
+ or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError",
+ error => $IO::Uncompress::Gunzip::GunzipError;
}
elsif ($compress != COMPRESSION_NONE) {
throw "Unsupported compression ($compress)\n", compression_flags => $compress;
$self->_read_inner_headers($fh);
$self->_read_inner_body($fh);
-
- binmode($fh, ':pop') if $compress;
- binmode($fh, ':pop:pop');
}
sub _read_inner_headers {
my $fh = shift;
my $kdbx = $self->kdbx;
- read_all $fh, my $buf, 1 or throw 'Expected inner header type';
- my ($type) = unpack('C', $buf);
-
- read_all $fh, $buf, 4 or throw 'Expected inner header size', type => $type;
- my ($size) = unpack('L<', $buf);
+ read_all $fh, my $buf, 5 or throw 'Expected inner header type and size',
+ compression_error => $IO::Uncompress::Gunzip::GunzipError,
+ crypt_error => $File::KDBX::IO::Crypt::ERROR,
+ hmac_error => $File::KDBX::IO::HmacBLock::ERROR;
+ my ($type, $size) = unpack('C L<', $buf);
my $val;
if (0 < $size) {
read_all $fh, $val, $size or throw 'Expected inner header value', type => $type, size => $size;
}
- $type = KDBX_INNER_HEADER($type);
+ my $dualtype = KDBX_INNER_HEADER($type);
- if ($type == INNER_HEADER_END) {
+ if (!defined $dualtype) {
+ alert "Ignoring unknown inner header type ($type)", type => $type, size => $size, value => $val;
+ return wantarray ? ($type => $val) : $type;
+ }
+ elsif ($dualtype == INNER_HEADER_END) {
# nothing
}
- elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
+ elsif ($dualtype == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
$val = unpack('L<', $val);
- $kdbx->inner_headers->{$type} = $val;
+ $kdbx->inner_headers->{$dualtype} = $val;
}
- elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
- $kdbx->inner_headers->{$type} = $val;
+ elsif ($dualtype == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
+ $kdbx->inner_headers->{$dualtype} = $val;
}
- elsif ($type == INNER_HEADER_BINARY) {
+ elsif ($dualtype == INNER_HEADER_BINARY) {
my $msize = $size - 1;
my ($flags, $data) = unpack("C a$msize", $val);
my $id = scalar keys %{$kdbx->binaries};
};
}
- return wantarray ? ($type => $val) : $type;
+ return wantarray ? ($dualtype => $val) : $dualtype;
}
1;
our %EXPORT_TAGS = (
assert => [qw(assert_64bit)],
+ bool => [qw(FALSE TRUE)],
clone => [qw(clone clone_nomagic)],
crypt => [qw(pad_pkcs7)],
debug => [qw(dumper)],
}
+=func FALSE
+
+=func TRUE
+
+Constants appropriate for use as return values in functions claiming to return true or false.
+
+=cut
+
+sub FALSE() { !1 }
+sub TRUE() { 1 }
+
BEGIN {
my $use_cowrefcnt = eval { require B::COW; 1 };
*_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
+++ /dev/null
-package PerlIO::via::File::KDBX::Compression;
-# ABSTRACT: [De]compressor PerlIO layer
-
-use warnings;
-use strict;
-
-use Errno;
-use File::KDBX::Error;
-use File::KDBX::Util qw(:io load_optional);
-use IO::Handle;
-use namespace::clean;
-
-our $VERSION = '999.999'; # VERSION
-our $BUFFER_SIZE = 8192;
-our $ERROR;
-
-=method push
-
- PerlIO::via::File::KDBX::Compression->push($fh);
- PerlIO::via::File::KDBX::Compression->push($fh, %options);
-
-Push a compression or decompression layer onto a filehandle. Data read from the handle is decompressed, and
-data written to a handle is compressed.
-
-Any arguments are passed along to the Inflate or Deflate constructors of C<Compress::Raw::Zlib>.
-
-This is identical to:
-
- binmode($fh, ':via(File::KDBX::Compression)');
-
-except this allows you to specify compression options.
-
-B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
-C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
-before the filehandle closes so it can finish the compression correctly, and the way to indicate that is by
-popping the layer.
-
-=cut
-
-my @PUSHED_ARGS;
-sub push {
- @PUSHED_ARGS and throw 'Pushing Compression layer would stomp existing arguments';
- my $class = shift;
- my $fh = shift;
- @PUSHED_ARGS = @_;
- binmode($fh, ':via(' . __PACKAGE__ . ')');
-}
-
-sub PUSHED {
- my ($class, $mode) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
-
- my $self = bless {
- buffer => \(my $buf = ''),
- mode => $mode,
- is_readable($mode) ? (inflator => _inflator(@PUSHED_ARGS)) : (),
- is_writable($mode) ? (deflator => _deflator(@PUSHED_ARGS)) : (),
- }, $class;
- @PUSHED_ARGS = ();
- return $self;
-}
-
-sub FILL {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
- return if $self->EOF($fh);
-
- $fh->read(my $buf, $BUFFER_SIZE);
- if (0 < length($buf)) {
- my $status = $self->inflator->inflate($buf, my $out);
- $status == Compress::Raw::Zlib::Z_OK() || $status == Compress::Raw::Zlib::Z_STREAM_END() or do {
- $self->_set_error("Failed to uncompress: $status", status => $status);
- return;
- };
- return $out;
- }
-
- delete $self->{inflator};
- delete $self->{deflator};
- return undef;
-}
-
-sub WRITE {
- my ($self, $buf, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
- return 0 if $self->EOF($fh) || !$self->deflator;
-
- my $status = $self->deflator->deflate($buf, my $out);
- $status == Compress::Raw::Zlib::Z_OK() or do {
- $self->_set_error("Failed to compress: $status", status => $status);
- return 0;
- };
-
- ${$self->buffer} .= $out;
- return length($buf);
-}
-
-sub POPPED {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
- return if $self->EOF($fh) || !is_writable($self->mode);
-
- # finish
- my $status = $self->deflator->flush(my $out, Compress::Raw::Zlib::Z_FINISH());
- delete $self->{inflator};
- delete $self->{deflator};
- $status == Compress::Raw::Zlib::Z_OK() or do {
- $self->_set_error("Failed to compress: $status", status => $status);
- return;
- };
-
- ${$self->buffer} .= $out;
- $self->FLUSH($fh);
-}
-
-sub FLUSH {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
- return 0 if !ref $self;
-
- my $buf = $self->buffer;
- print $fh $$buf or return -1 if 0 < length($$buf);
- $$buf = '';
- return 0;
-}
-
-sub EOF {
- $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
- !($_[0]->{inflator} || $_[0]->{deflator}) || $_[0]->ERROR($_[1]);
-}
-sub ERROR {
- $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
- $ERROR = $_[0]->{error} if $_[0]->{error};
- $_[0]->{error} ? 1 : 0;
-}
-sub CLEARERR {
- $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
- # delete $_[0]->{error};
-}
-
-sub inflator { $_[0]->{inflator} }
-sub deflator { $_[0]->{deflator} }
-sub mode { $_[0]->{mode} }
-sub buffer { $_[0]->{buffer} }
-
-sub _inflator {
- load_optional('Compress::Raw::Zlib');
- my ($inflator, $status)
- = Compress::Raw::Zlib::Inflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
- $status == Compress::Raw::Zlib::Z_OK()
- or throw 'Failed to initialize inflator', status => $status;
- return $inflator;
-}
-
-sub _deflator {
- load_optional('Compress::Raw::Zlib');
- my ($deflator, $status)
- = Compress::Raw::Zlib::Deflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
- $status == Compress::Raw::Zlib::Z_OK()
- or throw 'Failed to initialize deflator', status => $status;
- return $deflator;
-}
-
-sub _set_error {
- my $self = shift;
- $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
- delete $self->{inflator};
- delete $self->{deflator};
- if (exists &Errno::EPROTO) {
- $! = &Errno::EPROTO;
- }
- elsif (exists &Errno::EIO) {
- $! = &Errno::EIO;
- }
- $self->{error} = $ERROR = File::KDBX::Error->new(@_);
-}
-
-1;
+++ /dev/null
-package PerlIO::via::File::KDBX::Crypt;
-# ABSTRACT: Encrypter/decrypter PerlIO layer
-
-use warnings;
-use strict;
-
-use Errno;
-use File::KDBX::Error;
-use File::KDBX::Util qw(:io);
-use IO::Handle;
-use namespace::clean;
-
-our $VERSION = '999.999'; # VERSION
-our $BUFFER_SIZE = 8192;
-our $ERROR;
-
-=method push
-
- PerlIO::via::File::KDBX::Crypt->push($fh, cipher => $cipher);
-
-Push an encryption or decryption layer onto a filehandle. C<$cipher> must be compatible with
-L<File::KDBX::Cipher>.
-
-You mustn't push this layer using C<binmode> directly because the layer needs to be initialized with the
-required cipher object.
-
-B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
-C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
-before the filehandle closes so it can finish the encryption correctly, and the way to indicate that is by
-popping the layer.
-
-=cut
-
-my %PUSHED_ARGS;
-sub push {
- %PUSHED_ARGS and throw 'Pushing Crypt layer would stomp existing arguments';
- my $class = shift;
- my $fh = shift;
- my %args = @_ % 2 == 0 ? @_ : (cipher => @_);
- $args{cipher} or throw 'Must pass a cipher';
- $args{cipher}->finish if defined $args{finish} && !$args{finish};
-
- %PUSHED_ARGS = %args;
- binmode($fh, ':via(' . __PACKAGE__ . ')');
-}
-
-sub PUSHED {
- my ($class, $mode) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
- %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::Crypt->push instead of binmode';
-
- my $self = bless {
- buffer => \(my $buf = ''),
- cipher => $PUSHED_ARGS{cipher},
- mode => $mode,
- }, $class;
- %PUSHED_ARGS = ();
- return $self;
-}
-
-sub FILL {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
- return if $self->EOF($fh);
-
- $fh->read(my $buf, $BUFFER_SIZE);
- if (0 < length($buf)) {
- my $plaintext = eval { $self->cipher->decrypt($buf) };
- if (my $err = $@) {
- $self->_set_error($err);
- return;
- }
- return $plaintext;
- }
-
- # finish
- my $plaintext = eval { $self->cipher->finish };
- if (my $err = $@) {
- $self->_set_error($err);
- return;
- }
- delete $self->{cipher};
- return $plaintext;
-}
-
-sub WRITE {
- my ($self, $buf, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
- return 0 if $self->EOF($fh);
-
- ${$self->buffer} .= eval { $self->cipher->encrypt($buf) } || '';
- if (my $err = $@) {
- $self->_set_error($err);
- return 0;
- }
- return length($buf);
-}
-
-sub POPPED {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
- return if $self->EOF($fh) || !is_writable($self->mode);
-
- ${$self->buffer} .= eval { $self->cipher->finish } || '';
- if (my $err = $@) {
- $self->_set_error($err);
- return;
- }
-
- delete $self->{cipher};
- $self->FLUSH($fh);
-}
-
-sub FLUSH {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
- return 0 if !ref $self;
-
- my $buf = $self->buffer;
- print $fh $$buf or return -1 if 0 < length($$buf);
- $$buf = '';
- return 0;
-}
-
-sub EOF {
- $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
- !$_[0]->{cipher} || $_[0]->ERROR($_[1]);
-}
-sub ERROR {
- $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
- $_[0]->{error} ? 1 : 0;
-}
-sub CLEARERR {
- $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
- # delete $_[0]->{error};
-}
-
-sub cipher { $_[0]->{cipher} }
-sub mode { $_[0]->{mode} }
-sub buffer { $_[0]->{buffer} }
-
-sub _set_error {
- my $self = shift;
- $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
- delete $self->{cipher};
- if (exists &Errno::EPROTO) {
- $! = &Errno::EPROTO;
- }
- elsif (exists &Errno::EIO) {
- $! = &Errno::EIO;
- }
- $self->{error} = $ERROR = File::KDBX::Error->new(@_);
-}
-
-1;
-__END__
-
-=head1 SYNOPSIS
-
- use PerlIO::via::File::KDBX::Crypt;
- use File::KDBX::Cipher;
-
- my $cipher = File::KDBX::Cipher->new(...);
-
- open(my $out_fh, '>:raw', 'ciphertext.bin');
- PerlIO::via::File::KDBX::Crypt->push($out_fh, cipher => $cipher);
-
- print $out_fh $plaintext;
-
- binmode($out_fh, ':pop'); # <-- This is required.
- close($out_fh);
-
- open(my $in_fh, '<:raw', 'ciphertext.bin');
- PerlIO::via::File::KDBX::Crypt->push($in_fh, cipher => $cipher);
-
- my $plaintext = do { local $/; <$in_fh> );
-
- close($in_fh);
-
-=cut
+++ /dev/null
-package PerlIO::via::File::KDBX::HmacBlock;
-# ABSTRACT: HMAC block-stream PerlIO layer
-
-use warnings;
-use strict;
-
-use Crypt::Digest qw(digest_data);
-use Crypt::Mac::HMAC qw(hmac);
-use Errno;
-use File::KDBX::Error;
-use File::KDBX::Util qw(:io assert_64bit);
-use namespace::clean;
-
-our $VERSION = '999.999'; # VERSION
-our $BLOCK_SIZE = 1048576;
-our $ERROR;
-
-=method push
-
- PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key);
- PerlIO::via::File::KDBX::HmacBlock->push($fh, key => $key, block_size => $size);
-
-Push a new HMAC-block layer with arguments. A key is required.
-
-B<WARNING:> You mustn't push this layer using C<binmode> directly because the layer needs to be initialized
-with the key and any other desired attributes.
-
-B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
-C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
-before the filehandle closes so it can write the final block (which will likely be shorter than the other
-blocks), and the way to indicate that is by popping the layer.
-
-=cut
-
-my %PUSHED_ARGS;
-sub push {
- assert_64bit;
-
- %PUSHED_ARGS and throw 'Pushing HmacBlock layer would stomp existing arguments';
-
- my $class = shift;
- my $fh = shift;
- my %args = @_ % 2 == 0 ? @_ : (key => @_);
- $args{key} or throw 'Must pass a key';
-
- my $key_size = length($args{key});
- $key_size == 64 or throw 'Key must be 64 bytes in length', size => $key_size;
-
- %PUSHED_ARGS = %args;
- binmode($fh, ':via(' . __PACKAGE__ . ')');
-}
-
-sub PUSHED {
- my ($class, $mode) = @_;
-
- %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::HmacBlock->push instead of binmode';
-
- $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
- my $self = bless {
- block_index => 0,
- block_size => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
- buffer => \(my $buf = ''),
- key => $PUSHED_ARGS{key},
- mode => $mode,
- }, $class;
- %PUSHED_ARGS = ();
- return $self;
-}
-
-sub FILL {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
- return if $self->EOF($fh);
-
- my $block = eval { $self->_read_hashed_block($fh) };
- if (my $err = $@) {
- $self->_set_error($err);
- return;
- }
- if (length($block) == 0) {
- $self->{eof} = 1;
- return;
- }
- return $block;
-}
-
-sub WRITE {
- my ($self, $buf, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
- return 0 if $self->EOF($fh);
-
- ${$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 !~ /^w/;
-
- $self->FLUSH($fh);
- eval {
- $self->_write_next_hmac_block($fh); # partial block with remaining content
- $self->_write_final_hmac_block($fh); # terminating block
- };
- $self->_set_error($@) if $@;
-}
-
-sub FLUSH {
- my ($self, $fh) = @_;
-
- $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
- return 0 if !ref $self;
-
- eval {
- while ($self->block_size <= length(${$self->{buffer}})) {
- $self->_write_next_hmac_block($fh);
- }
- };
- if (my $err = $@) {
- $self->_set_error($err);
- return -1;
- }
-
- return 0;
-}
-
-sub EOF {
- $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
- $_[0]->{eof} || $_[0]->ERROR($_[1]);
-}
-sub ERROR {
- $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
- $ERROR = $_[0]->{error} if $_[0]->{error};
- $_[0]->{error} ? 1 : 0;
-}
-sub CLEARERR {
- $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
- # delete $_[0]->{error};
-}
-
-=attr key
-
- $key = $hmac_block->key;
-
-Get the key used for authentication. The key must be exactly 64 bytes in size.
-
-=cut
-
-sub key { $_[0]->{key} or throw 'Key is not set' }
-
-=attr block_size
-
- $size = $hmac_block->block_size;
-
-Get the block size. Default is C<$PerlIO::via::File::KDBX::HmacBlock::BLOCK_SIZE>.
-
-This only matters in write mode. When reading, block size is detected from the stream.
-
-=cut
-
-sub block_size { $_[0]->{block_size} ||= $BLOCK_SIZE }
-
-=attr block_index
-
-=attr buffer
-
-=attr mode
-
-Internal attributes.
-
-=cut
-
-sub block_index { $_[0]->{block_index} ||= 0 }
-sub buffer { $_[0]->{buffer} }
-sub mode { $_[0]->{mode} }
-
-sub _read_hashed_block {
- my $self = shift;
- my $fh = shift;
-
- read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC';
-
- read_all $fh, my $size_buf, 4 or throw 'Failed to read HMAC block size';
- my ($size) = unpack('L<', $size_buf);
-
- my $block = '';
- if (0 < $size) {
- read_all $fh, $block, $size
- or throw 'Failed to read HMAC block', index => $self->block_index, size => $size;
- }
-
- my $index_buf = pack('Q<', $self->block_index);
- my $got_hmac = hmac('SHA256', $self->_hmac_key,
- $index_buf,
- $size_buf,
- $block,
- );
-
- $hmac eq $got_hmac
- or throw 'Block authentication failed', index => $self->block_index, got => $got_hmac, expected => $hmac;
-
- $self->{block_index}++;
-
- return $block;
-}
-
-sub _write_next_hmac_block {
- my $self = shift;
- my $fh = shift;
- my $buffer = shift // $self->buffer;
- my $allow_empty = shift;
-
- my $size = length($$buffer);
- $size = $self->block_size if $self->block_size < $size;
- return 0 if $size == 0 && !$allow_empty;
-
- my $block = '';
- $block = substr($$buffer, 0, $size, '') if 0 < $size;
-
- my $index_buf = pack('Q<', $self->block_index);
- my $size_buf = pack('L<', $size);
- my $hmac = hmac('SHA256', $self->_hmac_key,
- $index_buf,
- $size_buf,
- $block,
- );
-
- print $fh $hmac, $size_buf, $block
- or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size, err => $fh->error;
-
- $self->{block_index}++;
- return 0;
-}
-
-sub _write_final_hmac_block {
- my $self = shift;
- my $fh = shift;
-
- $self->_write_next_hmac_block($fh, \'', 1);
-}
-
-sub _hmac_key {
- my $self = shift;
- my $key = shift // $self->key;
- my $index = shift // $self->block_index;
-
- my $index_buf = pack('Q<', $index);
- my $hmac_key = digest_data('SHA512', $index_buf, $key);
- return $hmac_key;
-}
-
-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 = File::KDBX::Error->new(@_);
-}
-
-1;
-__END__
-
-=head1 DESCRIPTION
-
-Writing to a handle with this layer will transform the data in a series of blocks. An HMAC is calculated for
-each block and is included in the output.
-
-Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into
-a data stream.
-
-Each block is encoded thusly:
-
-=for :list
-* HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data]
-* Block size - Little-endian unsigned 32-bit (counting only the data)
-* Data - String of bytes
-
-The terminating block is an empty block encoded as usual but block size is 0 and there is no data.
-
-=cut
+++ /dev/null
-#!/usr/bin/env perl
-
-use warnings;
-use strict;
-
-use lib 't/lib';
-use TestCommon;
-
-use IO::Handle;
-use PerlIO::via::File::KDBX::Compression;
-use Test::More;
-
-eval { require Compress::Raw::Zlib }
- or plan skip_all => 'Compress::Zlib::Raw required to test compression';
-
-my $expected_plaintext = 'Tiny food from Spain!';
-
-pipe(my $read, my $write) or die "pipe failed: $!";
-PerlIO::via::File::KDBX::Compression->push($read);
-PerlIO::via::File::KDBX::Compression->push($write);
-
-print $write $expected_plaintext or die "print failed: $!";
-binmode($write, ':pop'); # finish stream
-close($write) or die "close failed: $!";
-
-my $plaintext = do { local $/; <$read> };
-close($read);
-is $plaintext, $expected_plaintext, 'Deflate and inflate a string';
-
-{
- pipe(my $read, my $write) or die "pipe failed: $!";
- PerlIO::via::File::KDBX::Compression->push($read);
-
- print $write 'blah blah blah' or die "print failed: $!";
- close($write) or die "close failed: $!";
-
- is $read->error, 0, 'Read handle starts out fine';
- my $plaintext = do { local $/; <$read> };
- is $read->error, 1, 'Read handle can enter and error state';
-
- like $PerlIO::via::File::KDBX::Compression::ERROR, qr/failed to uncompress/i,
- 'Error object is available';
-}
-
-done_testing;
use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
use File::KDBX::Cipher;
use File::KDBX::Constants qw(CIPHER_UUID_AES256);
+use File::KDBX::IO::Crypt;
use IO::Handle;
-use PerlIO::via::File::KDBX::Crypt;
use Test::More;
subtest 'Round-trip block stream' => sub {
};
subtest 'Error handling' => sub {
- plan tests => 3;
+ plan tests => 4;
my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16);
pipe(my $read, my $write) or die "pipe failed: $!";
- PerlIO::via::File::KDBX::Crypt->push($read, $block_cipher);
+ $read = File::KDBX::IO::Crypt->new($read, cipher => $block_cipher);
- print $write 'blah blah blah!!';
+ print $write "blah blah blah!\1";
close($write) or die "close failed: $!";
- is $read->error, 0, 'Read handle starts out fine';
+ is $read->error, '', 'Read handle starts out fine';
my $plaintext = do { local $/; <$read> };
- is $read->error, 1, 'Read handle can enter and error state';
+ is $plaintext, '', 'Read can fail';
+ is $read->error, 1, 'Read handle can enter an error state';
- like $PerlIO::via::File::KDBX::Crypt::ERROR, qr/fatal/i,
+ like $File::KDBX::IO::Crypt::ERROR, qr/fatal/i,
'Error object is available';
};
my $expected_ciphertext = shift;
pipe(my $read, my $write) or die "pipe failed: $!";
- PerlIO::via::File::KDBX::Crypt->push($write, $cipher);
+ $write = File::KDBX::IO::Crypt->new($write, cipher => $cipher);
print $write $expected_plaintext;
- binmode($write, ':pop'); # finish stream
close($write) or die "close failed: $!";
my $ciphertext = do { local $/; <$read> };
is $ciphertext, $ciphertext2, 'Same result';
open(my $fh, '<', \$ciphertext) or die "open failed: $!\n";
- PerlIO::via::File::KDBX::Crypt->push($fh, $cipher);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
my $plaintext = do { local $/; <$fh> };
close($fh);
use File::KDBX::Util qw(can_fork);
use IO::Handle;
-use PerlIO::via::File::KDBX::HashBlock;
+use File::KDBX::IO::HashBlock;
use Test::More;
{
pipe(my $read, my $write) or die "pipe failed: $!\n";
- PerlIO::via::File::KDBX::HashBlock->push($write, block_size => 3);
+ $write = File::KDBX::IO::HashBlock->new($write, block_size => 3);
print $write $expected_plaintext;
- binmode($write, ':pop'); # finish stream
close($write) or die "close failed: $!";
- PerlIO::via::File::KDBX::HashBlock->push($read);
+ $read = File::KDBX::IO::HashBlock->new($read);
my $plaintext = do { local $/; <$read> };
close($read);
my $expected_plaintext = "\x64" x (1024*1024*12 - 57);
+ local $SIG{CHLD} = 'IGNORE';
pipe(my $read, my $write) or die "pipe failed: $!\n";
defined(my $pid = fork) or die "fork failed: $!\n";
if ($pid == 0) {
- PerlIO::via::File::KDBX::HashBlock->push($write);
+ $write = File::KDBX::IO::HashBlock->new($write);
print $write $expected_plaintext;
- binmode($write, ':pop'); # finish stream
close($write) or die "close failed: $!";
- exit;
+ # exit;
+ require POSIX;
+ POSIX::_exit(0);
}
- PerlIO::via::File::KDBX::HashBlock->push($read);
+ $read = File::KDBX::IO::HashBlock->new($read);
my $plaintext = do { local $/; <$read> };
close($read);
is $plaintext, $expected_plaintext, 'Hash-block a lot';
-
- waitpid($pid, 0) or die "wait failed: $!\n";
}
subtest 'Error handling' => sub {
pipe(my $read, my $write) or die "pipe failed: $!\n";
- PerlIO::via::File::KDBX::HashBlock->push($read);
+ $read = File::KDBX::IO::HashBlock->new($read);
print $write 'blah blah blah';
close($write) or die "close failed: $!";
- is $read->error, 0, 'Read handle starts out fine';
+ is $read->error, '', 'Read handle starts out fine';
my $data = do { local $/; <$read> };
- is $read->error, 1, 'Read handle can enter and error state';
+ is $read->error, 1, 'Read handle can enter an error state';
- like $PerlIO::via::File::KDBX::HashBlock::ERROR, qr/invalid block index/i,
- 'Error object is available';
+ like $File::KDBX::IO::HashBlock::ERROR, qr/invalid block index/i, 'Error object is available';
};
done_testing;
use lib 't/lib';
use TestCommon qw(:no_warnings_test);
+use File::KDBX::IO::HmacBlock;
use File::KDBX::Util qw(can_fork);
use IO::Handle;
-use PerlIO::via::File::KDBX::HmacBlock;
use Test::More;
my $KEY = "\x01" x 64;
pipe(my $read, my $write) or die "pipe failed: $!\n";
- PerlIO::via::File::KDBX::HmacBlock->push($write, block_size => 3, key => $KEY);
+ $write = File::KDBX::IO::HmacBlock->new($write, block_size => 3, key => $KEY);
print $write $expected_plaintext;
- binmode($write, ':pop'); # finish stream
close($write) or die "close failed: $!";
- PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
+ $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY);
my $plaintext = do { local $/; <$read> };
close($read);
is $plaintext, $expected_plaintext, 'HMAC-block just a little bit';
+
+ is $File::KDBX::IO::HmacBlock::ERROR, undef, 'No error when successful';
}
SKIP: {
my $expected_plaintext = "\x64" x (1024*1024*12 - 57);
+ local $SIG{CHLD} = 'IGNORE';
pipe(my $read, my $write) or die "pipe failed: $!\n";
defined(my $pid = fork) or die "fork failed: $!\n";
if ($pid == 0) {
- PerlIO::via::File::KDBX::HmacBlock->push($write, key => $KEY);
+ $write = File::KDBX::IO::HmacBlock->new($write, key => $KEY);
print $write $expected_plaintext;
- binmode($write, ':pop'); # finish stream
close($write) or die "close failed: $!";
- exit;
+ # exit;
+ require POSIX;
+ POSIX::_exit(0);
}
- PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
+ $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY);
my $plaintext = do { local $/; <$read> };
close($read);
is $plaintext, $expected_plaintext, 'HMAC-block a lot';
-
- waitpid($pid, 0) or die "wait failed: $!\n";
}
subtest 'Error handling' => sub {
pipe(my $read, my $write) or die "pipe failed: $!\n";
- PerlIO::via::File::KDBX::HmacBlock->push($read, key => $KEY);
+ $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY);
print $write 'blah blah blah';
close($write) or die "close failed: $!";
- is $read->error, 0, 'Read handle starts out fine';
+ is $read->error, '', 'Read handle starts out fine';
my $data = do { local $/; <$read> };
- is $read->error, 1, 'Read handle can enter and error state';
+ is $read->error, 1, 'Read handle can enter an error state';
- like $PerlIO::via::File::KDBX::HmacBlock::ERROR, qr/failed to read HMAC/i,
- 'Error object is available';
+ like $File::KDBX::IO::HmacBlock::ERROR, qr/failed to read HMAC/i, 'Error object is available';
};
done_testing;
projects / chaz / p5-File-KDBX / commitdiff
