view release on metacpan or  search on metacpan

lib/AnyEvent/GnuPG.pm  view on Meta::CPAN

sub _cmdline {
    my $self = shift;
    my $args = [ $self->{gnupg_path} ];

    # Default options
    push @$args, "--no-tty", "--no-greeting", "--yes";

    # Check for homedir and options file
    push @$args, "--homedir", $self->{homedir} if $self->{homedir};
    push @$args, "--options", $self->{options} if $self->{options};

    # Command options
    push @$args, @{ $self->_options };

    # Command and arguments
    push @$args, "--" . $self->_command;
    push @$args, @{ $self->_args };

    return $args;
}

sub _condvar {
    my $cb = shift;
    return $cb if ref $cb eq 'AnyEvent::CondVar';
    my $cv = AE::cv;
    $cv->cb($cb) if ref $cb eq 'CODE';
    $cb ||= '';
    $cv;
}

sub _croak {
    my ( $cv, $msg ) = @_;
    AE::log error => $msg;
    $cv->croak($msg);
    $cv;
}

sub _catch {
    my ( $cv1, $cb ) = @_;
    AE::cv {
        my $cv2 = shift;
        try {
            $cb->( $cv2->recv );
        }
        catch {
            s{ at \S+ line \d+\.\s+$}{};
            $cv1->croak($_)
        };
    }
}

sub _eq($_) { shift eq pop }    ## no critic

sub _parse_status {
    my ( $self, $cv, %actions ) = @_;
    my $commands;
    $self->{status_fd}->readlines_cb(
        sub {
            my $line = shift;
            unless ( defined $line ) {
                AE::log debug => "end of status parsing";
                $cv->send($commands);
            }
            if ( my ( $cmd, $arg ) =
                $line =~ m{^\[gnupg:\]\s+(\w+)\s*(.+)?\s*$}i )
            {
                $arg ||= '';
                my @args = $arg ? ( split /\s+/, $arg ) : ();
                AE::log debug => "got command: $cmd ($arg)";
                try {
                    for ( lc $cmd ) {
                        _eq('newsig')  && do { last };
                        _eq('goodsig') && do { last };
                        _eq('expsig')
                          && do { die "the signature is expired ($arg)" };
                        _eq('expkeysig') && do {
                            die
                              "the signature was made by an expired key ($arg)";
                        };
                        _eq('revkeysig') && do {
                            die
                              "the signature was made by an revoked key ($arg)";
                        };
                        _eq('badsig') && do {
                            die
                              "the signature has not been verified okay ($arg)";
                        };
                        _eq('errsig') && do {
                            die "the signature could not be verified ($arg)";
                        };
                        _eq('validsig') && do { last };
                        _eq('sig_id')   && do { last };
                        _eq('enc_to')   && do { last };
                        _eq('nodata')   && do {
                            for ($arg) {
                                _eq('1') && die "no armored data";
                                _eq('2')
                                  && die
                                  "expected a packet but did not found one";
                                _eq('3') && die "invalid packet found";
                                _eq('4')
                                  && die "signature expected but not found";
                                die "no data has been found";
                            }
                        };
                        _eq('unexpected')
                          && do { die "unexpected data has been encountered" };
                        _eq('trust_undefined')
                          && do { die "signature trust undefined: $arg" };
                        _eq('trust_never')
                          && do { die "signature trust is never: $arg" };
                        _eq('trust_marginal') && do { last };
                        _eq('trust_fully')    && do { last };
                        _eq('trust_ultimate') && do { last };
                        _eq('pka_trust_good') && do { last };
                        _eq('pka_trust_bad')  && do { last };
                        _eq('sigexpired')
                          or _eq('keyexpired') && do {
                            die "the key has expired since "
                              . ( scalar localtime $arg );
                          };
                        _eq('keyrevoked') && do {
                            die "the used key has been revoked by its owner";
                        };
                        _eq('badarmor')
                          && do { die "the ASCII armor is corrupted" };
                        _eq('rsa_or_idea')         && do { last };
                        _eq('shm_info')            && do { last };
                        _eq('shm_get')             && do { last };

lib/AnyEvent/GnuPG.pm  view on Meta::CPAN

                            for ($cmd) {
                                _eq('inv_recp')
                                  && do { $prefix .= ' recipient' };
                                _eq('inv_sgnr') && do { $prefix .= ' sender' };
                            }
                            $prefix .= ': ';
                            for ( shift(@args) ) {
                                _eq('0') && die $prefix . "no specific reason";
                                _eq('1') && die $prefix . "not found";
                                _eq('2')
                                  && die $prefix . "ambigious specification";
                                _eq('3')  && die $prefix . "wrong key usage";
                                _eq('4')  && die $prefix . "key revoked";
                                _eq('5')  && die $prefix . "key expired";
                                _eq('6')  && die $prefix . "no CRL known";
                                _eq('7')  && die $prefix . "CRL too old";
                                _eq('8')  && die $prefix . "policy mismatch";
                                _eq('9')  && die $prefix . "not a secret key";
                                _eq('10') && die $prefix . "key not trusted";
                                _eq('11')
                                  && die $prefix . "missing certificate";
                                _eq('12')
                                  && die $prefix . "missing issuer certificate";
                                die $prefix . '???';
                            }
                        };
                        _eq('no_recp') && do { die "no recipients are usable" };
                        _eq('no_sgnr') && do { die "no senders are usable" };
                        _eq('already_signed')   && do { last };
                        _eq('truncated')        && do { last };
                        _eq('error')            && do { die $arg };
                        _eq('success')          && do { last };
                        _eq('attribute')        && do { last };
                        _eq('cardctrl')         && do { last };
                        _eq('plaintext')        && do { last };
                        _eq('plaintext_length') && do { last };
                        _eq('sig_subpacket')    && do { last };
                        _eq('sc_op_failure')
                          && do { die "smartcard failure ($arg)" };
                        _eq('sc_op_success')      && do { last };
                        _eq('backup_key_created') && do { last };
                        _eq('mountpoint')         && do { last };
                        AE::log note => "unknown command: $cmd";
                    }
                    my $result;
                    if ( $actions{ lc($cmd) } ) {
                        $result = $actions{ lc($cmd) }->(@args);
                    }
                    push @$commands => {
                        cmd    => $cmd,
                        arg    => $arg,
                        args   => \@args,
                        result => $result
                    };
                }
                catch {
                    s{\s+$}{};
                    $self->_abort_gnupg( $_, $cv );
                }
                finally {
                    AE::log debug => "arguments parsed as: ["
                      . ( join ', ', map { "'$_'" } @args ) . "]";
                }
            }
            else {
                return $self->_abort_gnupg(
                    "error communicating with gnupg: bad status line: $line",
                    $cv );
            }
        }
    );
    $cv;
}

sub _abort_gnupg {
    my ( $self, $msg, $cb ) = @_;
    my $cv = _condvar($cb);
    AE::log error => $msg if $msg;
    if ( $self->{gnupg_proc} ) {
        $self->{gnupg_proc}->fire_and_kill(
            10,
            sub {
                AE::log debug => "fired and killed";
                $self->_end_gnupg(
                    sub {
                        AE::log debug => "gnupg aborted";
                        $cv->croak($msg);
                    }
                );
            }
        );
    }
    $cv;
}

sub _end_gnupg {
    my ( $self, $cb ) = @_;
    my $cv = _condvar($cb);

    if ( ref $self->{input} eq 'GLOB' ) {
        close $self->{input};
    }

    if ( $self->{command_fd} ) {
        $self->{command_fd}->finish;
    }

    if ( 0 && $self->{status_fd} ) {
        $self->{status_fd}->A->destroy;
    }

    if ( $self->{gnupg_proc} ) {

        $self->{gnupg_proc}->wait(
            sub {
                if ( ref $self->{output} eq 'GLOB' ) {
                    close $self->{output};
                }

                for (
                    qw(protocol proc command options args status_fd command_fd input output next_status )
                  )
                {
                    delete $self->{$_};
                }

                AE::log debug => "gnupg exited";
                $cv->send;
            }
        );

    }
    else {
        $cv->send;
    }
    $cv;
}

sub _run_gnupg {
    my ( $self, $cv ) = @_;

    if ( defined $self->{input} and not ref $self->{input} ) {
        my $file = $self->{input};
        open( my $fh, '<', $file ) or die "cannot open file $file: $!";
        AE::log info => "input file $file opened at $fh";
        $self->{input} = $fh;
    }

    if ( defined $self->{output} and not ref $self->{output} ) {
        my $file = $self->{output};
        open( my $fh, '>', $file ) or die "cannot open file $file: $!";
        AE::log info => "output file $file opened at $fh";
        $self->{output} = $fh;
    }

    my $cmdline = $self->_cmdline;

    my $gpg = shift @$cmdline;

    my $status  = AnyEvent::Proc::reader();
    my $command = AnyEvent::Proc::writer();

    unshift @$cmdline, '--status-fd'  => $status;
    unshift @$cmdline, '--command-fd' => $command;

    my $err;

    AE::log debug => "running $gpg " . join( ' ' => @$cmdline );
    my $proc = AnyEvent::Proc->new(
        bin           => $gpg,
        args          => $cmdline,
        extras        => [ $status, $command ],
        ttl           => 600,
        on_ttl_exceed => sub { $self->_abort_gnupg( 'ttl exceeded', $cv ) },
        errstr        => \$err,
    );

    if ( defined $self->{input} ) {
        $proc->pull( $self->{input} );
    }

    if ( defined $self->{output} ) {
        $proc->pipe( out => $self->{output} );
    }

    $self->{command_fd} = $command;
    $self->{status_fd}  = $status;
    $self->{gnupg_proc} = $proc;

    AE::log debug => "gnupg ready";

    $proc;
}

sub _send_command {
    shift->{command_fd}->writeln(pop);
}

sub DESTROY {
    my $self = shift;

    $self->{gnupg_proc}->kill if $self->{gnupg_proc};
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my %args = @_;

    my $self = {};
    if ( $args{homedir} ) {
        confess("Invalid home directory: $args{homedir}")
          unless -d $args{homedir} && -x _;
        $self->{homedir} = $args{homedir};
    }
    if ( $args{options} ) {
        confess("Invalid options file: $args{options}")
          unless -r $args{options};
        $self->{options} = $args{options};
    }
    if ( $args{gnupg_path} ) {
        confess("Invalid gpg path: $args{gnupg_path}")
          unless -x $args{gnupg_path};
        $self->{gnupg_path} = $args{gnupg_path};
    }
    else {
        my ($path) = grep { -x "$_/gpg" } split /:/, $ENV{PATH};
        confess("Couldn't find gpg in PATH ($ENV{PATH})") unless $path;
        $self->{gnupg_path} = "$path/gpg";
    }

    bless $self, $class;
}

sub version {
    shift->version_cb(@_)->recv;
}

sub version_cb {
    my ( $self, $cb ) = @_;
    my $cv = _condvar($cb);

    $self->_command("version");
    $self->_options( [] );
    $self->_args(    [] );

    my $version;

    my $proc = $self->_run_gnupg($cv);