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(:io 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 (mode: $mode)\n";
  53
  54     my $self = bless {
  55         buffer  => \(my $buf = ''),
  56         mode    => $mode,
  57         is_readable($mode) ? (inflator => _inflator(@PUSHED_ARGS)) : (),
  58         is_writable($mode) ? (deflator => _deflator(@PUSHED_ARGS)) : (),
  59     }, $class;
  60     @PUSHED_ARGS = ();
  61     return $self;
  62 }
  63
  64 sub FILL {
  65     my ($self, $fh) = @_;
  66
  67     $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
  68     return if $self->EOF($fh);
  69
  70     $fh->read(my $buf, $BUFFER_SIZE);
  71     if (0 < length($buf)) {
  72         my $status = $self->inflator->inflate($buf, my $out);
  73         $status == Compress::Raw::Zlib::Z_OK() || $status == Compress::Raw::Zlib::Z_STREAM_END() or do {
  74             $self->_set_error("Failed to uncompress: $status", status => $status);
  75             return;
  76         };
  77         return $out;
  78     }
  79
  80     delete $self->{inflator};
  81     delete $self->{deflator};
  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) || !$self->deflator;
  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) || !is_writable($self->mode);
 106
 107     # finish
 108     my $status = $self->deflator->flush(my $out, Compress::Raw::Zlib::Z_FINISH());
 109     delete $self->{inflator};
 110     delete $self->{deflator};
 111     $status == Compress::Raw::Zlib::Z_OK() or do {
 112         $self->_set_error("Failed to compress: $status", status => $status);
 113         return;
 114     };
 115
 116     ${$self->buffer} .= $out;
 117     $self->FLUSH($fh);
 118 }
 119
 120 sub FLUSH {
 121     my ($self, $fh) = @_;
 122
 123     $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
 124     return 0 if !ref $self;
 125
 126     my $buf = $self->buffer;
 127     print $fh $$buf or return -1 if 0 < length($$buf);
 128     $$buf = '';
 129     return 0;
 130 }
 131
 132 sub EOF {
 133     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
 134     !($_[0]->{inflator} || $_[0]->{deflator}) || $_[0]->ERROR($_[1]);
 135 }
 136 sub ERROR {
 137     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
 138     $ERROR = $_[0]->{error} if $_[0]->{error};
 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 inflator { $_[0]->{inflator} }
 147 sub deflator { $_[0]->{deflator} }
 148 sub mode     { $_[0]->{mode} }
 149 sub buffer   { $_[0]->{buffer} }
 150
 151 sub _inflator {
 152     load_optional('Compress::Raw::Zlib');
 153     my ($inflator, $status)
 154         = Compress::Raw::Zlib::Inflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
 155     $status == Compress::Raw::Zlib::Z_OK()
 156         or throw 'Failed to initialize inflator', status => $status;
 157     return $inflator;
 158 }
 159
 160 sub _deflator {
 161     load_optional('Compress::Raw::Zlib');
 162     my ($deflator, $status)
 163         = Compress::Raw::Zlib::Deflate->new(-WindowBits => Compress::Raw::Zlib::WANT_GZIP(), @_);
 164     $status == Compress::Raw::Zlib::Z_OK()
 165         or throw 'Failed to initialize deflator', status => $status;
 166     return $deflator;
 167 }
 168
 169 sub _set_error {
 170     my $self = shift;
 171     $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
 172     delete $self->{inflator};
 173     delete $self->{deflator};
 174     if (exists &Errno::EPROTO) {
 175         $! = &Errno::EPROTO;
 176     }
 177     elsif (exists &Errno::EIO) {
 178         $! = &Errno::EIO;
 179     }
 180     $self->{error} = $ERROR = File::KDBX::Error->new(@_);
 181 }
 182
 183 1;