Dogcows Code - chaz/p5-File-KDBX/blob - lib/File/KDBX/IO/Crypt.pm

   1 package File::KDBX::IO::Crypt;
   2 # ABSTRACT: Encrypter/decrypter IO handle
   3
   4 use warnings;
   5 use strict;
   6
   7 use Errno;
   8 use File::KDBX::Error;
   9 use File::KDBX::Util qw(:class :empty);
  10 use namespace::clean;
  11
  12 extends 'File::KDBX::IO';
  13
  14 our $VERSION = '0.905'; # VERSION
  15 our $BUFFER_SIZE = 16384;
  16 our $ERROR;
  17
  18
  19 my %ATTRS = (
  20     cipher  => undef,
  21 );
  22 while (my ($attr, $default) = each %ATTRS) {
  23     no strict 'refs'; ## no critic (ProhibitNoStrict)
  24     *$attr = sub {
  25         my $self = shift;
  26         *$self->{$attr} = shift if @_;
  27         *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
  28     };
  29 }
  30
  31
  32 sub new {
  33     my $class = shift;
  34     my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
  35     my $self = $class->SUPER::new;
  36     $self->_fh($args{fh}) or throw 'IO handle required';
  37     $self->cipher($args{cipher}) or throw 'Cipher required';
  38     return $self;
  39 }
  40
  41 sub _FILL {
  42     my ($self, $fh) = @_;
  43
  44     $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
  45     my $cipher = $self->cipher or return;
  46
  47     $fh->read(my $buf = '', $BUFFER_SIZE);
  48     if (0 < length($buf)) {
  49         my $plaintext = eval { $cipher->decrypt($buf) };
  50         if (my $err = $@) {
  51             $self->_set_error($err);
  52             return;
  53         }
  54         return $plaintext if 0 < length($plaintext);
  55     }
  56
  57     # finish
  58     my $plaintext = eval { $cipher->finish };
  59     if (my $err = $@) {
  60         $self->_set_error($err);
  61         return;
  62     }
  63     $self->cipher(undef);
  64     return $plaintext;
  65 }
  66
  67 sub _WRITE {
  68     my ($self, $buf, $fh) = @_;
  69
  70     $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
  71     my $cipher = $self->cipher or return 0;
  72
  73     my $new_data = eval { $cipher->encrypt($buf) } || '';
  74     if (my $err = $@) {
  75         $self->_set_error($err);
  76         return 0;
  77     }
  78     $self->_buffer_out_add($new_data) if nonempty $new_data;
  79     return length($buf);
  80 }
  81
  82 sub _POPPED {
  83     my ($self, $fh) = @_;
  84
  85     $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
  86     return if $self->_mode ne 'w';
  87     my $cipher = $self->cipher or return;
  88
  89     my $new_data = eval { $cipher->finish } || '';
  90     if (my $err = $@) {
  91         $self->_set_error($err);
  92         return;
  93     }
  94     $self->_buffer_out_add($new_data) if nonempty $new_data;
  95
  96     $self->cipher(undef);
  97     $self->_FLUSH($fh);
  98 }
  99
 100 sub _FLUSH {
 101     my ($self, $fh) = @_;
 102
 103     $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
 104     return if $self->_mode ne 'w';
 105
 106     my $buffer = $self->_buffer_out;
 107     while (@$buffer) {
 108         my $read = shift @$buffer;
 109         next if empty $read;
 110         $fh->print($read) or return -1;
 111     }
 112     return 0;
 113 }
 114
 115 sub _set_error {
 116     my $self = shift;
 117     $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
 118     if (exists &Errno::EPROTO) {
 119         $! = &Errno::EPROTO;
 120     }
 121     elsif (exists &Errno::EIO) {
 122         $! = &Errno::EIO;
 123     }
 124     $self->cipher(undef);
 125     $self->_error($ERROR = File::KDBX::Error->new(@_));
 126 }
 127
 128 1;
 129
 130 __END__
 131
 132 =pod
 133
 134 =encoding UTF-8
 135
 136 =head1 NAME
 137
 138 File::KDBX::IO::Crypt - Encrypter/decrypter IO handle
 139
 140 =head1 VERSION
 141
 142 version 0.905
 143
 144 =head1 SYNOPSIS
 145
 146     use File::KDBX::IO::Crypt;
 147     use File::KDBX::Cipher;
 148
 149     my $cipher = File::KDBX::Cipher->new(...);
 150
 151     open(my $out_fh, '>:raw', 'ciphertext.bin');
 152     $out_fh = File::KDBX::IO::Crypt->new($out_fh, cipher => $cipher);
 153
 154     print $out_fh $plaintext;
 155
 156     close($out_fh);
 157
 158     open(my $in_fh, '<:raw', 'ciphertext.bin');
 159     $in_fh = File::KDBX::IO::Crypt->new($in_fh, cipher => $cipher);
 160
 161     my $plaintext = do { local $/; <$in_fh> );
 162
 163     close($in_fh);
 164
 165 =head1 ATTRIBUTES
 166
 167 =head2 cipher
 168
 169 A L<File::KDBX::Cipher> instance to do the actual encryption or decryption.
 170
 171 =head1 METHODS
 172
 173 =head2 new
 174
 175     $fh = File::KDBX::IO::Crypt->new(%attributes);
 176     $fh = File::KDBX::IO::Crypt->new($fh, %attributes);
 177
 178 Construct a new crypto IO handle.
 179
 180 =head1 BUGS
 181
 182 Please report any bugs or feature requests on the bugtracker website
 183 L<https://github.com/chazmcgarvey/File-KDBX/issues>
 184
 185 When submitting a bug or request, please include a test-file or a
 186 patch to an existing test-file that illustrates the bug or desired
 187 feature.
 188
 189 =head1 AUTHOR
 190
 191 Charles McGarvey <ccm@cpan.org>
 192
 193 =head1 COPYRIGHT AND LICENSE
 194
 195 This software is copyright (c) 2022 by Charles McGarvey.
 196
 197 This is free software; you can redistribute it and/or modify it under
 198 the same terms as the Perl 5 programming language system itself.
 199
 200 =cut