view release on metacpan or  search on metacpan

lib/PerlIO/via/GnuPG.pm  view on Meta::CPAN

#
# This file is part of PerlIO-via-GnuPG
#
# This software is Copyright (c) 2013 by Chris Weyl.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package PerlIO::via::GnuPG;
our $AUTHORITY = 'cpan:RSRCHBOY';
# git description: 0.005-1-gdb3e32f
$PerlIO::via::GnuPG::VERSION = '0.006';

# ABSTRACT: Layer to try to decrypt on read

# required for how we're registering a warnings category
use v5.14;

use strict;
use warnings::register qw{ unencrypted };
#use warnings::register;
use warnings;

use autodie 2.25;

use IPC::Open3 'open3';
use Symbol 'gensym';
use List::AllUtils 'part';

# gpg --decrypt -q --status-file aksdja --no-tty
# gpg --decrypt -q --status-file aksdja --no-tty .pause.gpg

sub PUSHED {
    my ($class, $mode) = @_;

    return bless { }, $class;
}

sub _passthrough_unencrypted { 0 }

sub FILL {
    my ($self, $fh) = @_;

    return shift @{ $self->{buffer} }
        if exists $self->{buffer};

    ### pull in all of fh and try to decrypt it...
    my $maybe_encrypted = do { local $/; <$fh> };

    ### $maybe_encrypted
    my ($in, $out, $error) = (gensym, gensym, gensym);
    my $run = 'gpg -qd --no-tty --command-fd 0';
    my $pid = open3($in, $out, $error, $run);

    ### $pid
    print $in $maybe_encrypted;
    close $in;
    my @output = <$out>;
    my @errors = <$error>;

    waitpid $pid, 0;

    ### @output
    ### @errors

    ### filter warnings out...
    chomp @errors;
    my ($errors, $warnings) = map { $_ || [] } part { /WARNING:/ ? 1 : 0 } @errors;

    ### $warnings
    warnings::warnif(@$warnings)
        if !!$warnings && @$warnings;

    if (!!$errors && @$errors) {

        my $not_encrypted = scalar grep { /no valid OpenPGP data found/ } @$errors;

        ### $not_encrypted
        ### passthrough: $self->_passthrough_unencrypted
        if ($not_encrypted) {

            if ($self->_passthrough_unencrypted) {
                warnings::warnif(
                    'PerlIO::via::GnuPG::unencrypted',
                    'File does not appear to be encrypted!',
                );
                @output = ($maybe_encrypted);
            }
            else {
                die "File does not appear to be encrypted!";
            }
        }
        else {

            # "@errors" here is intentional -- show the warnings, too
            die "Errors while attempting decryption: @errors";
        }
    }

    $self->{buffer} = [ @output ];
    return shift @{ $self->{buffer} };
}

!!42;

__END__

=pod

=encoding UTF-8

=for :stopwords Chris Weyl decrypt