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

   1 package PerlIO::via::File::KDBX::Compression;
   2 # ABSTRACT: [De]compressor PerlIO layer
   3
   4 use warnings;
   5 use strict;
   6
   7 use Errno;
   8 use File::KDBX::Error;
   9 use File::KDBX::Util qw(load_optional);
  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::Compression->push($fh);
  20     PerlIO::via::File::KDBX::Compression->push($fh, %options);
  21
  22 Push a compression or decompression layer onto a filehandle. Data read from the handle is decompressed, and
  23 data written to a handle is compressed.
  24
  25 Any arguments are passed along to the Inflate or Deflate constructors of C<Compress::Raw::Zlib>.
  26
  27 This is identical to:
  28
  29     binmode($fh, ':via(File::KDBX::Compression)');
  30
  31 except this allows you to specify compression options.
  32
  33 B<WARNING:> When writing, you mustn't close the filehandle before popping this layer (using
  34 C<binmode($fh, ':pop')>) or the stream will be truncated. The layer needs to know when there is no more data
  35 before the filehandle closes so it can finish the compression correctly, and the way to indicate that is by
  36 popping the layer.
  37
  38 =cut
  39
  40 my @PUSHED_ARGS;
  41 sub push {
  42     @PUSHED_ARGS and throw 'Pushing Compression layer would stomp existing arguments';
  43     my $class = shift;
  44     my $fh    = shift;
  45     @PUSHED_ARGS = @_;
  46     binmode($fh, ':via(' . __PACKAGE__ . ')');
  47 }
  48
  49 sub PUSHED {
  50     my ($class, $mode) = @_;
  51
  52     $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
  53     my $buf = '';
  54
  55     my $self = bless {
  56         buffer  => \$buf,
  57         mode    => $mode,
  58         $mode =~ /^r/ ? (inflator => _inflator(@PUSHED_ARGS)) : (),
  59         $mode =~ /^w/ ? (deflator => _deflator(@PUSHED_ARGS)) : (),
  60     }, $class;
  61     @PUSHED_ARGS = ();
  62     return $self;
  63 }
  64
  65 sub FILL {
  66     my ($self, $fh) = @_;
  67
  68     $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
  69     return if $self->EOF($fh);
  70
  71     $fh->read(my $buf, $BUFFER_SIZE);
  72     if (0 < length($buf)) {
  73         my $status = $self->inflator->inflate($buf, my $out);
  74         $status == Compress::Raw::Zlib::Z_OK() || $status == Compress::Raw::Zlib::Z_STREAM_END() or do {
  75             $self->_set_error("Failed to uncompress: $status", status => $status);
  76             return;
  77         };
  78         return $out;
  79     }
  80
  81     delete $self->{inflator};
  82     return undef;
  83 }
  84
  85 sub WRITE {
  86     my ($self, $buf, $fh) = @_;
  87
  88     $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
  89     return 0 if $self->EOF($fh);
  90
  91     my $status = $self->deflator->deflate($buf, my $out);
  92     $status == Compress::Raw::Zlib::Z_OK() or do {
  93         $self->_set_error("Failed to compress: $status", status => $status);
  94         return 0;
  95     };
  96
  97     ${$self->buffer} .= $out;
  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     # finish
 108     my $status = $self->deflator->flush(my $out, Compress::Raw::Zlib::Z_FINISH());
 109     delete $self->{deflator};
 110     $status == Compress::Raw::Zlib::Z_OK() or do {
 111         $self->_set_error("Failed to compress: $status", status => $status);
 112         return;
 113     };
 114
 115     ${$self->buffer} .= $out;
 116     $self->FLUSH($fh);
 117 }
 118
 119 sub FLUSH {
 120     my ($self, $fh) = @_;
 121
 122     $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
 123     return 0 if !ref $self;
 124
 125     my $buf = $self->buffer;
 126     print $fh $$buf or return -1 if 0 < length($$buf);
 127     $$buf = '';
 128     return 0;
 129 }
 130
 131 sub EOF      {
 132     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
 133     (!$_[0]->inflator && !$_[0]->deflator) || $_[0]->ERROR($_[1]);
 134 }
 135 sub ERROR    {
 136     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
 137     $ERROR = $_[0]->{error} if $_[0]->{error};
 138     $_[0]->{error} ? 1 : 0;
 139 }
 140 sub CLEARERR {
 141     $ENV{DEBUG_STREAM} and print STDERR "CLEARERR\t$_[0]\n";
 142     # delete $_[0]->{error};
 143 }
 144
 145 sub inflator { $_[0]->{inflator} }
 146 sub deflator { $_[0]->{deflator} }
 147 sub mode     { $_[0]->{mode} }
 148 sub buffer   { $_[0]->{buffer} }
 149
 150 sub _inflator {
 151     load_optional('Compress::Raw::Zlib');
 152     my ($inflator, $status)
 153         = Compress::Raw::Zlib::Inflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
 154     $status == Compress::Raw::Zlib::Z_OK()
 155         or throw 'Failed to initialize inflator', status => $status;
 156     return $inflator;
 157 }
 158
 159 sub _deflator {
 160     load_optional('Compress::Raw::Zlib');
 161     my ($deflator, $status)
 162         = Compress::Raw::Zlib::Deflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
 163     $status == Compress::Raw::Zlib::Z_OK()
 164         or throw 'Failed to initialize deflator', status => $status;
 165     return $deflator;
 166 }
 167
 168 sub _set_error {
 169     my $self = shift;
 170     $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
 171     delete $self->{inflator};
 172     delete $self->{deflator};
 173     if (exists &Errno::EPROTO) {
 174         $! = &Errno::EPROTO;
 175     }
 176     elsif (exists &Errno::EIO) {
 177         $! = &Errno::EIO;
 178     }
 179     $self->{error} = $ERROR = File::KDBX::Error->new(@_);
 180 }
 181
 182 1;