From: Charles McGarvey Date: Tue, 19 Apr 2022 06:04:51 +0000 (-0600) Subject: convert PerlIO layers to IO handles X-Git-Tag: v0.800~27 X-Git-Url: https://git.brokenzipper.com/gitweb?a=commitdiff_plain;h=50f1a929d9224b9072b5fae39162a5d943323c5d;p=chaz%2Fp5-File-KDBX convert PerlIO layers to IO handles --- diff --git a/dist.ini b/dist.ini index 9344c9c..8eceb08 100644 --- a/dist.ini +++ b/dist.ini @@ -5,9 +5,6 @@ copyright_year = 2022 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 @@ -24,10 +21,12 @@ POSIX::1003 = 0 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 diff --git a/lib/File/KDBX/Cipher.pm b/lib/File/KDBX/Cipher.pm index 5c1f120..5dbde84 100644 --- a/lib/File/KDBX/Cipher.pm +++ b/lib/File/KDBX/Cipher.pm @@ -133,25 +133,25 @@ Get the initialization vector. 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 diff --git a/lib/File/KDBX/Dumper.pm b/lib/File/KDBX/Dumper.pm index 553b1f1..6d02063 100644 --- a/lib/File/KDBX/Dumper.pm +++ b/lib/File/KDBX/Dumper.pm @@ -169,36 +169,29 @@ sub dump_file { 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; } diff --git a/lib/File/KDBX/Dumper/V3.pm b/lib/File/KDBX/Dumper/V3.pm index 890af02..635931f 100644 --- a/lib/File/KDBX/Dumper/V3.pm +++ b/lib/File/KDBX/Dumper/V3.pm @@ -8,10 +8,10 @@ use Crypt::Digest qw(digest_data); 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'; @@ -148,7 +148,7 @@ sub _write_body { 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'; @@ -156,12 +156,16 @@ sub _write_body { $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; @@ -169,9 +173,6 @@ sub _write_body { 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; diff --git a/lib/File/KDBX/Dumper/V4.pm b/lib/File/KDBX/Dumper/V4.pm index b96e568..8100212 100644 --- a/lib/File/KDBX/Dumper/V4.pm +++ b/lib/File/KDBX/Dumper/V4.pm @@ -9,10 +9,10 @@ use Crypt::Mac::HMAC qw(hmac); 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; @@ -233,18 +233,22 @@ sub _write_body { $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; @@ -254,9 +258,6 @@ sub _write_body { 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 { diff --git a/lib/File/KDBX/IO.pm b/lib/File/KDBX/IO.pm new file mode 100644 index 0000000..0ea5d9c --- /dev/null +++ b/lib/File/KDBX/IO.pm @@ -0,0 +1,419 @@ +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 subclass which provides self-tying and buffering. It currently provides an interface +for subclasses that is similar to L, but this is subject to change. Don't depend on this outside +of the L distribution. Currently-available subclasses: + +=for :list +* L +* L +* L + +=cut diff --git a/lib/File/KDBX/IO/Crypt.pm b/lib/File/KDBX/IO/Crypt.pm new file mode 100644 index 0000000..22fe45e --- /dev/null +++ b/lib/File/KDBX/IO/Crypt.pm @@ -0,0 +1,165 @@ +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 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 diff --git a/lib/PerlIO/via/File/KDBX/HashBlock.pm b/lib/File/KDBX/IO/HashBlock.pm similarity index 50% rename from lib/PerlIO/via/File/KDBX/HashBlock.pm rename to lib/File/KDBX/IO/HashBlock.pm index e4a772b..adb1cc6 100644 --- a/lib/PerlIO/via/File/KDBX/HashBlock.pm +++ b/lib/File/KDBX/IO/HashBlock.pm @@ -1,5 +1,5 @@ -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; @@ -11,60 +11,64 @@ use File::KDBX::Util qw(:io); 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 When writing, you mustn't close the filehandle before popping this layer (using -C) 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) -=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 = $@) { @@ -74,26 +78,26 @@ sub FILL { 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 @@ -101,14 +105,14 @@ sub POPPED { $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); } }; @@ -120,55 +124,7 @@ sub FLUSH { 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. - -=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; @@ -177,8 +133,7 @@ sub _read_hash_block { 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'; @@ -186,19 +141,18 @@ sub _read_hash_block { 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; } @@ -206,16 +160,16 @@ sub _write_next_hash_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)); @@ -224,7 +178,7 @@ sub _write_next_hash_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; } @@ -232,7 +186,7 @@ sub _write_final_hash_block { 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; @@ -241,7 +195,7 @@ sub _write_final_hash_block { $buf = pack('L<', 0); print $fh $buf or throw 'Failed to write hash block size'; - $self->{eof} = 1; + $self->_finished(1); return 0; } @@ -254,7 +208,7 @@ sub _set_error { elsif (exists &Errno::EIO) { $! = &Errno::EIO; } - $self->{error} = $ERROR = File::KDBX::Error->new(@_); + $self->_error($ERROR = error(@_)); } 1; @@ -262,12 +216,14 @@ __END__ =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 diff --git a/lib/File/KDBX/IO/HmacBlock.pm b/lib/File/KDBX/IO/HmacBlock.pm new file mode 100644 index 0000000..ac07e7e --- /dev/null +++ b/lib/File/KDBX/IO/HmacBlock.pm @@ -0,0 +1,242 @@ +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 diff --git a/lib/File/KDBX/Loader/V3.pm b/lib/File/KDBX/Loader/V3.pm index 68d7f9c..f7f9516 100644 --- a/lib/File/KDBX/Loader/V3.pm +++ b/lib/File/KDBX/Loader/V3.pm @@ -20,9 +20,9 @@ use Crypt::Digest qw(digest_data); 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'; @@ -127,7 +127,7 @@ sub _read_body { 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'; @@ -138,12 +138,14 @@ sub _read_body { $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; @@ -151,9 +153,6 @@ sub _read_body { $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 diff --git a/lib/File/KDBX/Loader/V4.pm b/lib/File/KDBX/Loader/V4.pm index 5148d12..fa8d21d 100644 --- a/lib/File/KDBX/Loader/V4.pm +++ b/lib/File/KDBX/Loader/V4.pm @@ -23,8 +23,8 @@ use Encode qw(decode); 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; @@ -188,18 +188,20 @@ sub _read_body { $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; @@ -207,9 +209,6 @@ sub _read_body { $self->_read_inner_headers($fh); $self->_read_inner_body($fh); - - binmode($fh, ':pop') if $compress; - binmode($fh, ':pop:pop'); } sub _read_inner_headers { @@ -226,30 +225,34 @@ sub _read_inner_header { 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}; @@ -259,7 +262,7 @@ sub _read_inner_header { }; } - return wantarray ? ($type => $val) : $type; + return wantarray ? ($dualtype => $val) : $dualtype; } 1; diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 7d51a21..a074d3e 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -18,6 +18,7 @@ our $VERSION = '999.999'; # VERSION our %EXPORT_TAGS = ( assert => [qw(assert_64bit)], + bool => [qw(FALSE TRUE)], clone => [qw(clone clone_nomagic)], crypt => [qw(pad_pkcs7)], debug => [qw(dumper)], @@ -819,6 +820,17 @@ sub uuid { } +=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 }; diff --git a/lib/PerlIO/via/File/KDBX/Compression.pm b/lib/PerlIO/via/File/KDBX/Compression.pm deleted file mode 100644 index 6e6bff5..0000000 --- a/lib/PerlIO/via/File/KDBX/Compression.pm +++ /dev/null @@ -1,183 +0,0 @@ -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. - -This is identical to: - - binmode($fh, ':via(File::KDBX::Compression)'); - -except this allows you to specify compression options. - -B When writing, you mustn't close the filehandle before popping this layer (using -C) 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; diff --git a/lib/PerlIO/via/File/KDBX/Crypt.pm b/lib/PerlIO/via/File/KDBX/Crypt.pm deleted file mode 100644 index cb354c1..0000000 --- a/lib/PerlIO/via/File/KDBX/Crypt.pm +++ /dev/null @@ -1,185 +0,0 @@ -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. - -You mustn't push this layer using C directly because the layer needs to be initialized with the -required cipher object. - -B When writing, you mustn't close the filehandle before popping this layer (using -C) 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 diff --git a/lib/PerlIO/via/File/KDBX/HmacBlock.pm b/lib/PerlIO/via/File/KDBX/HmacBlock.pm deleted file mode 100644 index 5655aa1..0000000 --- a/lib/PerlIO/via/File/KDBX/HmacBlock.pm +++ /dev/null @@ -1,291 +0,0 @@ -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 You mustn't push this layer using C directly because the layer needs to be initialized -with the key and any other desired attributes. - -B When writing, you mustn't close the filehandle before popping this layer (using -C) 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 diff --git a/t/compression.t b/t/compression.t deleted file mode 100644 index 3412dc2..0000000 --- a/t/compression.t +++ /dev/null @@ -1,45 +0,0 @@ -#!/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; diff --git a/t/crypt.t b/t/crypt.t index 7e54ce9..c003a5f 100644 --- a/t/crypt.t +++ b/t/crypt.t @@ -9,8 +9,8 @@ use TestCommon; 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 { @@ -32,20 +32,21 @@ subtest 'Round-trip cipher 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'; }; @@ -58,10 +59,9 @@ sub test_roundtrip { 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> }; @@ -73,7 +73,7 @@ sub test_roundtrip { 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); diff --git a/t/hash-block.t b/t/hash-block.t index 461ad55..78008ab 100644 --- a/t/hash-block.t +++ b/t/hash-block.t @@ -8,7 +8,7 @@ use TestCommon qw(:no_warnings_test); use File::KDBX::Util qw(can_fork); use IO::Handle; -use PerlIO::via::File::KDBX::HashBlock; +use File::KDBX::IO::HashBlock; use Test::More; { @@ -16,12 +16,11 @@ 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); @@ -33,40 +32,39 @@ 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::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; diff --git a/t/hmac-block.t b/t/hmac-block.t index 75b467c..d0488c6 100644 --- a/t/hmac-block.t +++ b/t/hmac-block.t @@ -6,9 +6,9 @@ use strict; 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; @@ -18,16 +18,17 @@ 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: { @@ -35,40 +36,39 @@ 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;