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