view release on metacpan or  search on metacpan

lib/CTK/Crypt/GPG.pm  view on Meta::CPAN

Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C<LICENSE> file and L<https://dev.perl.org/licenses/>

=cut

use vars qw/$VERSION/;
$VERSION = '1.01';

use Carp;
use CTK::Util qw(:API :FORMAT :UTIL :FILE );
use File::Temp qw();
use File::Spec;

use constant {
    # GPG (GNUPG)
    GPGBIN    => 'gpg',
    GPGCONF   => 'gpg.conf',
    GPGOPTS   => ["verbose", "yes"],
    GPGEXT    => ".asc",
};

sub new {
    my $class = shift;
    my ($gpgbin, $gpghome, $gpgconf, $gpgopts, $pubkey, $seckey, $pass, $recipient) =
    read_attributes([
        ['GPG','GPGBIN','BIN','CMD','COMMAND'],
        ['GPGHOME','GPGDIR','DIRGPG','HOMEGPG','HOMEDIR'],
        ['GPGCONF','CONFIG','CONF'],
        ['GPGOPTS','GPGOPTIONS','OPTIONS','OPTS'],
        ['PUBLIC','PUBLICKEY','PUP','PUBKEY','PUBRING'],
        ['PRIVATE','PRIV','PRIVATEKEY','SEC','SECKEY','SECRETKEY','PRIVKEY','PRIVRING','SECRING'],
        ['PASS','PASSWORD','PASSPHRASE','PASSW'],
        ['RECIPIENT','KEYID','ID','USER','KEYGRIP'],
    ], @_) if defined $_[0];
    $gpgbin ||= which(GPGBIN);
    my $tmpdir = File::Temp->newdir(TEMPLATE => 'gpgXXXXX', TMPDIR => 1) unless $gpghome;
    if ($gpghome) {
        preparedir($gpghome, 0700) or do {
            carp(sprintf("Can't prepare dir: %s", $gpghome));
            return undef;
        };
    } else {
        $gpghome = $tmpdir->dirname;
    }
    $gpgconf ||= File::Spec->catfile($gpghome, GPGCONF);
    $gpgopts ||= GPGOPTS;
    my @opts = ('# Do not edit this file');
    if (ref($gpgopts) eq 'ARRAY') { push @opts, @$gpgopts }
    else { push @opts, $gpgopts }
    fsave($gpgconf, join("\n", @opts)) or do {
        carp(sprintf("Can't save GPG conffile: %s", $gpgconf));
        return undef;
    };
    eval { chmod $gpgconf, 0600 };

    # Get version
    my @cmd = ();
    push(@cmd, $gpgbin, "--homedir", $gpghome, "--options", $gpgconf, "--version");
    my $err = "";
    my $out = execute( [@cmd], undef, \$err, 1 );
    my $version = $out && $out =~ /gpg.+?([0-9\.]+)\s*$/m ? $1 : 0;
    if ($version) {
        my $tv = pack("U*",split(/\./, $version));
        unless ($tv gt pack("U*", 2, 0)) {
            carp(sprintf("Incorrect GPG version v%vd. Require v2.0.0 and above", $tv));
            return undef;
        }
    }
    $out = "" if $version;

    # Import keys
    foreach my $key ($pubkey, $seckey) {
        next unless $key;
        next unless length($key);
        next unless -e $key;
        @cmd = ($gpgbin, "--homedir", $gpghome, "--options", $gpgconf);
        push @cmd, "--pinentry-mode", "loopback", "--passphrase", $pass if $pass && length($pass);
        push @cmd, "--import", $key;
        $out = execute( [@cmd], undef, \$err, 1 );
        unless ($recipient) {
            foreach my $t ($out, $err) {
                next unless $t;
                $recipient = $1 if $t =~ /key\s+([a-z0-9]+)\:/im;
                last if $recipient;
            }
        }
    }

    my $self = bless {
        gpgbin  => $gpgbin,
        homedir => $gpghome,
        tempdir => $tmpdir,
        gpgconf => $gpgconf,
        options => [@opts],
        cmd     => join(" ", @cmd),
        stdout  => $out,
        stderr  => $err,
        version => $version,
        pubkey  => $pubkey,
        seckey  => $seckey,
        password => $pass,
        recipient => $recipient,
        error => $recipient ? "" : "Incorrect recipient!",
    }, $class;
    return $self;
}

sub encrypt {
    my $self = shift;
    my ($inf, $outf, $armor) =
    read_attributes([
        ['IN','FILEIN','INPUT','FILESRC','SRC','INFILE'],
        ['OUT','FILEOUT','OUTPUT','FILEDST','DST','OUTFILE'],
        ['ARMOR','ASCII'],