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

   1 package PerlIO::via::File::KDBX::Crypt;
   2 # ABSTRACT: Encrypter/decrypter PerlIO layer
   3
   4 use warnings;
   5 use strict;
   6
   7 use Errno;
   8 use File::KDBX::Error;
   9 use File::KDBX::Util qw(:io);
  10 use IO::Handle;
  11 use namespace::clean;
  12
  13 our $VERSION = '999.999'; # VERSION
  14 our $BUFFER_SIZE = 8192;
  15 our $ERROR;
  16
  17 =method push
  18
  19     PerlIO::via::File::KDBX::Crypt->push($fh, cipher => $cipher);
  20
  21 Push an encryption or decryption layer onto a filehandle. C<$cipher> must be compatible with
  22 L<File::KDBX::Cipher>.
  23
  24 You mustn't push this layer using C<binmode> directly because the layer needs to be initialized with the
  25 required cipher object.
  26
  27 B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
  28 C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
  29 before the filehandle closes so it can finish the encryption correctly, and the way to indicate that is by
  30 popping the layer.
  31
  32 =cut
  33
  34 my %PUSHED_ARGS;
  35 sub push {
  36     %PUSHED_ARGS and throw 'Pushing Crypt layer would stomp existing arguments';
  37     my $class = shift;
  38     my $fh = shift;
  39     my %args = @_ % 2 == 0 ? @_ : (cipher => @_);
  40     $args{cipher} or throw 'Must pass a cipher';
  41     $args{cipher}->finish if defined $args{finish} && !$args{finish};
  42
  43     %PUSHED_ARGS = %args;
  44     binmode($fh, ':via(' . __PACKAGE__ . ')');
  45 }
  46
  47 sub PUSHED {
  48     my ($class, $mode) = @_;
  49
  50     $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
  51     %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::Crypt->push instead of binmode';
  52
  53     my $self = bless {
  54         buffer  => \(my $buf = ''),
  55         cipher  => $PUSHED_ARGS{cipher},
  56         mode    => $mode,
  57     }, $class;
  58     %PUSHED_ARGS = ();
  59     return $self;
  60 }
  61
  62 sub FILL {
  63     my ($self, $fh) = @_;
  64
  65     $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
  66     return if $self->EOF($fh);
  67
  68     $fh->read(my $buf, $BUFFER_SIZE);
  69     if (0 < length($buf)) {
  70         my $plaintext = eval { $self->cipher->decrypt($buf) };
  71         if (my $err = $@) {
  72             $self->_set_error($err);
  73             return;
  74         }
  75         return $plaintext;
  76     }
  77
  78     # finish
  79     my $plaintext = eval { $self->cipher->finish };
  80     if (my $err = $@) {
  81         $self->_set_error($err);
  82         return;
  83     }
  84     delete $self->{cipher};
  85     return $plaintext;
  86 }
  87
  88 sub WRITE {
  89     my ($self, $buf, $fh) = @_;
  90
  91     $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
  92     return 0 if $self->EOF($fh);
  93
  94     ${$self->buffer} .= eval { $self->cipher->encrypt($buf) } || '';
  95     if (my $err = $@) {
  96         $self->_set_error($err);
  97         return 0;
  98     }
  99     return length($buf);
 100 }
 101
 102 sub POPPED {
 103     my ($self, $fh) = @_;
 104
 105     $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
 106     return if $self->EOF($fh) || !is_writable($self->mode);
 107
 108     ${$self->buffer} .= eval { $self->cipher->finish } || '';
 109     if (my $err = $@) {
 110         $self->_set_error($err);
 111         return;
 112     }
 113
 114     delete $self->{cipher};
 115     $self->FLUSH($fh);
 116 }
 117
 118 sub FLUSH {
 119     my ($self, $fh) = @_;
 120
 121     $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
 122     return 0 if !ref $self;
 123
 124     my $buf = $self->buffer;
 125     print $fh $$buf or return -1 if 0 < length($$buf);
 126     $$buf = '';
 127     return 0;
 128 }
 129
 130 sub EOF {
 131     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
 132     !$_[0]->{cipher} || $_[0]->ERROR($_[1]);
 133 }
 134 sub ERROR {
 135     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
 136     $_[0]->{error} ? 1 : 0;
 137 }
 138 sub CLEARERR {
 139     $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
 140     # delete $_[0]->{error};
 141 }
 142
 143 sub cipher  { $_[0]->{cipher} }
 144 sub mode    { $_[0]->{mode} }
 145 sub buffer  { $_[0]->{buffer} }
 146
 147 sub _set_error {
 148     my $self = shift;
 149     $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
 150     delete $self->{cipher};
 151     if (exists &Errno::EPROTO) {
 152         $! = &Errno::EPROTO;
 153     }
 154     elsif (exists &Errno::EIO) {
 155         $! = &Errno::EIO;
 156     }
 157     $self->{error} = $ERROR = File::KDBX::Error->new(@_);
 158 }
 159
 160 1;
 161 __END__
 162
 163 =head1 SYNOPSIS
 164
 165     use PerlIO::via::File::KDBX::Crypt;
 166     use File::KDBX::Cipher;
 167
 168     my $cipher = File::KDBX::Cipher->new(...);
 169
 170     open(my $out_fh, '>:raw', 'ciphertext.bin');
 171     PerlIO::via::File::KDBX::Crypt->push($out_fh, cipher => $cipher);
 172
 173     print $out_fh $plaintext;
 174
 175     binmode($out_fh, ':pop');   # <-- This is required.
 176     close($out_fh);
 177
 178     open(my $in_fh, '<:raw', 'ciphertext.bin');
 179     PerlIO::via::File::KDBX::Crypt->push($in_fh, cipher => $cipher);
 180
 181     my $plaintext = do { local $/; <$in_fh> );
 182
 183     close($in_fh);
 184
 185 =cut