From: Charles McGarvey <ccm@cpan.org>
Date: Tue, 19 Apr 2022 00:24:20 +0000 (-0600)
Subject: Add better IO support for possible fopen modes
X-Git-Tag: v0.800~31
X-Git-Url: https://git.brokenzipper.com/gitweb?a=commitdiff_plain;h=b0afc7004220cc502ea07ab8d2555b8fcd2a11d5;p=chaz%2Fp5-File-KDBX

Add better IO support for possible fopen modes
---

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index 4b4c2c7..7d51a21 100644
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -26,7 +26,7 @@ our %EXPORT_TAGS = (
     empty       => [qw(empty nonempty)],
     erase       => [qw(erase erase_scoped)],
     gzip        => [qw(gzip gunzip)],
-    io          => [qw(read_all)],
+    io          => [qw(is_readable is_writable read_all)],
     load        => [qw(load_optional load_xs try_load_optional)],
     search      => [qw(query search simple_expression_query)],
     text        => [qw(snakify trim)],
@@ -424,6 +424,20 @@ sub gzip {
     return $out;
 }
 
+=func is_readable
+
+=func is_writable
+
+    $bool = is_readable($mode);
+    $bool = is_writable($mode);
+
+Determine of an C<fopen>-style mode is readable, writable or both.
+
+=cut
+
+sub is_readable { $_[0] !~ /^[aw]b?$/ }
+sub is_writable { $_[0] !~ /^rb?$/ }
+
 =func is_uuid
 
     $bool = is_uuid($thing);
diff --git a/lib/PerlIO/via/File/KDBX/Compression.pm b/lib/PerlIO/via/File/KDBX/Compression.pm
index a1fd120..6e6bff5 100644
--- a/lib/PerlIO/via/File/KDBX/Compression.pm
+++ b/lib/PerlIO/via/File/KDBX/Compression.pm
@@ -6,7 +6,7 @@ use strict;
 
 use Errno;
 use File::KDBX::Error;
-use File::KDBX::Util qw(load_optional);
+use File::KDBX::Util qw(:io load_optional);
 use IO::Handle;
 use namespace::clean;
 
@@ -49,14 +49,13 @@ sub push {
 sub PUSHED {
     my ($class, $mode) = @_;
 
-    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
-    my $buf = '';
+    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
 
     my $self = bless {
-        buffer  => \$buf,
+        buffer  => \(my $buf = ''),
         mode    => $mode,
-        $mode =~ /^r/ ? (inflator => _inflator(@PUSHED_ARGS)) : (),
-        $mode =~ /^w/ ? (deflator => _deflator(@PUSHED_ARGS)) : (),
+        is_readable($mode) ? (inflator => _inflator(@PUSHED_ARGS)) : (),
+        is_writable($mode) ? (deflator => _deflator(@PUSHED_ARGS)) : (),
     }, $class;
     @PUSHED_ARGS = ();
     return $self;
@@ -79,6 +78,7 @@ sub FILL {
     }
 
     delete $self->{inflator};
+    delete $self->{deflator};
     return undef;
 }
 
@@ -86,7 +86,7 @@ sub WRITE {
     my ($self, $buf, $fh) = @_;
 
     $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
-    return 0 if $self->EOF($fh);
+    return 0 if $self->EOF($fh) || !$self->deflator;
 
     my $status = $self->deflator->deflate($buf, my $out);
     $status == Compress::Raw::Zlib::Z_OK() or do {
@@ -102,10 +102,11 @@ sub POPPED {
     my ($self, $fh) = @_;
 
     $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
-    return if $self->EOF($fh) || $self->mode !~ /^w/;
+    return if $self->EOF($fh) || !is_writable($self->mode);
 
     # finish
     my $status = $self->deflator->flush(my $out, Compress::Raw::Zlib::Z_FINISH());
+    delete $self->{inflator};
     delete $self->{deflator};
     $status == Compress::Raw::Zlib::Z_OK() or do {
         $self->_set_error("Failed to compress: $status", status => $status);
@@ -128,11 +129,11 @@ sub FLUSH {
     return 0;
 }
 
-sub EOF      {
+sub EOF {
     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
-    (!$_[0]->inflator && !$_[0]->deflator) || $_[0]->ERROR($_[1]);
+    !($_[0]->{inflator} || $_[0]->{deflator}) || $_[0]->ERROR($_[1]);
 }
-sub ERROR    {
+sub ERROR {
     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
     $ERROR = $_[0]->{error} if $_[0]->{error};
     $_[0]->{error} ? 1 : 0;
diff --git a/lib/PerlIO/via/File/KDBX/Crypt.pm b/lib/PerlIO/via/File/KDBX/Crypt.pm
index 4e1231e..cb354c1 100644
--- a/lib/PerlIO/via/File/KDBX/Crypt.pm
+++ b/lib/PerlIO/via/File/KDBX/Crypt.pm
@@ -4,7 +4,9 @@ package PerlIO::via::File::KDBX::Crypt;
 use warnings;
 use strict;
 
+use Errno;
 use File::KDBX::Error;
+use File::KDBX::Util qw(:io);
 use IO::Handle;
 use namespace::clean;
 
@@ -45,12 +47,11 @@ sub push {
 sub PUSHED {
     my ($class, $mode) = @_;
 
-    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
+    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
     %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::Crypt->push instead of binmode';
 
-    my $buf = '';
     my $self = bless {
-        buffer  => \$buf,
+        buffer  => \(my $buf = ''),
         cipher  => $PUSHED_ARGS{cipher},
         mode    => $mode,
     }, $class;
@@ -102,7 +103,7 @@ sub POPPED {
     my ($self, $fh) = @_;
 
     $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
-    return if $self->EOF($fh) || $self->mode !~ /^w/;
+    return if $self->EOF($fh) || !is_writable($self->mode);
 
     ${$self->buffer} .= eval { $self->cipher->finish } || '';
     if (my $err = $@) {
@@ -126,15 +127,11 @@ sub FLUSH {
     return 0;
 }
 
-# sub EOF      { !$_[0]->cipher || $_[0]->ERROR($_[1]) }
-# sub ERROR    { $_[0]->{error} ? 1 : 0 }
-# sub CLEARERR { delete $_[0]->{error}; 0 }
-
-sub EOF      {
+sub EOF {
     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
-    !$_[0]->cipher || $_[0]->ERROR($_[1]);
+    !$_[0]->{cipher} || $_[0]->ERROR($_[1]);
 }
-sub ERROR    {
+sub ERROR {
     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
     $_[0]->{error} ? 1 : 0;
 }
diff --git a/lib/PerlIO/via/File/KDBX/HashBlock.pm b/lib/PerlIO/via/File/KDBX/HashBlock.pm
index ce1b935..e4a772b 100644
--- a/lib/PerlIO/via/File/KDBX/HashBlock.pm
+++ b/lib/PerlIO/via/File/KDBX/HashBlock.pm
@@ -5,6 +5,7 @@ use warnings;
 use strict;
 
 use Crypt::Digest qw(digest_data);
+use Errno;
 use File::KDBX::Error;
 use File::KDBX::Util qw(:io);
 use IO::Handle;
@@ -46,13 +47,12 @@ sub push {
 sub PUSHED {
     my ($class, $mode) = @_;
 
-    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
-    my $buf = '';
+    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
     my $self = bless {
         algorithm   => $PUSHED_ARGS{algorithm} || $ALGORITHM,
         block_index => 0,
         block_size  => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
-        buffer      => \$buf,
+        buffer      => \(my $buf = ''),
         eof         => 0,
         mode        => $mode,
     }, $class;
@@ -120,11 +120,11 @@ sub FLUSH {
     return 0;
 }
 
-sub EOF      {
+sub EOF {
     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
     $_[0]->{eof} || $_[0]->ERROR($_[1]);
 }
-sub ERROR    {
+sub ERROR {
     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
     $ERROR = $_[0]->{error} if $_[0]->{error};
     $_[0]->{error} ? 1 : 0;
diff --git a/lib/PerlIO/via/File/KDBX/HmacBlock.pm b/lib/PerlIO/via/File/KDBX/HmacBlock.pm
index ba54d60..5655aa1 100644
--- a/lib/PerlIO/via/File/KDBX/HmacBlock.pm
+++ b/lib/PerlIO/via/File/KDBX/HmacBlock.pm
@@ -6,6 +6,7 @@ use strict;
 
 use Crypt::Digest qw(digest_data);
 use Crypt::Mac::HMAC qw(hmac);
+use Errno;
 use File::KDBX::Error;
 use File::KDBX::Util qw(:io assert_64bit);
 use namespace::clean;
@@ -54,12 +55,11 @@ sub PUSHED {
 
     %PUSHED_ARGS or throw 'Programmer error: Use PerlIO::via::File::KDBX::HmacBlock->push instead of binmode';
 
-    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class\n";
-    my $buf = '';
+    $ENV{DEBUG_STREAM} and print STDERR "PUSHED\t$class (mode: $mode)\n";
     my $self = bless {
         block_index => 0,
         block_size  => $PUSHED_ARGS{block_size} || $BLOCK_SIZE,
-        buffer      => \$buf,
+        buffer      => \(my $buf = ''),
         key         => $PUSHED_ARGS{key},
         mode        => $mode,
     }, $class;
@@ -131,11 +131,11 @@ sub FLUSH {
     return 0;
 }
 
-sub EOF      {
+sub EOF {
     $ENV{DEBUG_STREAM} and print STDERR "EOF\t$_[0]\n";
     $_[0]->{eof} || $_[0]->ERROR($_[1]);
 }
-sub ERROR    {
+sub ERROR {
     $ENV{DEBUG_STREAM} and print STDERR "ERROR\t$_[0] : ", $_[0]->{error} // 'ok', "\n";
     $ERROR = $_[0]->{error} if $_[0]->{error};
     $_[0]->{error} ? 1 : 0;