Contents of /trunk/caff/caff

#!/usr/bin/perl -w

# caff  --  CA - Fire and Forget
# $Id$
#
# Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=pod

=head1 NAME

caff -- CA - Fire and Forget

=head1 SYNOPSIS

=over

=item B<caff> [-mMR] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]

=back

=head1 DESCRIPTION

CA Fire and Forget is a script that helps you in keysigning.  It takes a list
of keyids on the command line, fetches them from a keyserver and calls GnuPG so
that you can sign it.  It then mails each key to all its email addresses - only
including the one UID that we send to in each mail, pruned from all but self
sigs and sigs done by you.

=head1 OPTIONS

=over

=item B<-m>, B<--mail>

Send mail after signing. Default is to ask the user for each uid.

=item B<-M>, B<--no-mail>

Do not send mail after signing. Default is to ask the user for each uid.

=item B<-R>, B<--no-download>

Do not retrieve the key to be signed from a keyserver.

=item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>

Select the key that is used for signing, in case you have more than one key.

=back

=head1 FILES

=over

=item $HOME/.caffrc  -  configuration file

=back

=head1 CONFIGURATION FILE OPTIONS

The configuration file is a perl script that sets values in the hash B<%CONFIG>.

Example:

        $CONFIG{owner} = q{Peter Palfrader};
        $CONFIG{email} = q{peter@palfrader.org};
        $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];

=head2 Valid keys

=over

=item B<caffhome> [string]

Base directory for the files caff stores.  Default: B<$HOME/.caff/>.

=item B<owner> [string]

Your name.  B<REQUIRED>.

=item B<email> [string]

Your email address, used in From: lines.  B<REQUIRED>.

=item B<keyid> [list of keyids]

A list of your keys.  This is used to determine which signatures to keep
in the pruning step.  If you select a key using B<-u> it has to be in
this list.  B<REQUIRED>.

=item B<export-sig-age> [seconds]

Don't export UIDs by default, on which your latest signature is older
than this age.  Default: B<24*60*60> (i.e. one day).

=item B<keyserver> [string]

Keyserver to download keys from.  Default: B<subkeys.pgp.net>.

=item B<gpg> [string]

Path to the GnuPG binary.  Default: B<gpg>.

=item B<gpg-sign> [string]

Path to the GnuPG binary which is used to sign keys.  Default: what
B<gpg> is set to.

=item B<gpg-delsig> [string]

Path to the GnuPG binary which is used to split off signatures.  This was
needed while the upstream GnuPG was not fixed.  Default: what B<gpg>
is set to.

=item B<secret-keyring> [string]

Path to your secret keyring.  Default: B<$HOME/.gnupg/secring.gpg>.

=item B<also-encrypt-to> [keyid]

An additional keyid to encrypt messages to. Default: none.

=item B<no-download> [boolean]

If true, then skip the step of fetching keys from the keyserver.
Default: B<0>.

=item B<no-sign> [boolean]

If true, then skip the signing step. Default: B<0>.

=item B<mail-template> [string]

Email template which is used as the body text for the email sent out.
instead of the default text if specified. The following perl variables
can be used in the template:

=over

=item B<{owner}> [string]

Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.

=item B<{key}> [string]

The keyid of the key you signed.

=item B<{@uids}> [array]

The UIDs for which signatures are included in the mail.

=back

=back

=head1 AUTHOR

Peter Palfrader <peter@palfrader.org>

=head1 WEBSITE

http://pgp-tools.alioth.debian.org/

=cut

use strict;
use IO::Handle;
use English;
use File::Path;
use File::Temp qw{tempdir};
use Text::Template;
use MIME::Entity;
use Fcntl;
use IO::Select;
use Getopt::Long;
use GnuPG::Interface;

my %CONFIG;
my $REVISION = '$Rev$';
my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
my $VERSION = "0.0.0.$REVISION_NUMER";

sub load_config() {
        my $config = $ENV{'HOME'} . '/.caffrc';
        -f $config or die "No file $config present.  See caff(1).\n";
        unless (scalar eval `cat $config`) {
                die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
        };

        $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
        die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
        die ("email is not defined.\n") unless defined $CONFIG{'email'};
        die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
        die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
        for my $keyid (@{$CONFIG{'keyid'}}) {
                $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
        };
        @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
        $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
        $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
        $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
        $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
        $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
        $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
        $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
        $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
        $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
Hi,

please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
{foreach $uid (@uids) {
    $OUT .= "\t".$uid."\n";
};} of your key {$key} signed by me.

Note that I did not upload your key to any keyservers. If you want this
new signature to be available to others, please upload it yourself.
With GnuPG this can be done using
        gpg --keyserver subkeys.pgp.net --send-key {$key}

If you have any questions, don't hesitate to ask.

Regards,
{$owner}
EOM
};

sub notice($) {
        my ($line) = @_;
        print "[NOTICE] $line\n";
};
sub info($) {
        my ($line) = @_;
        print "[INFO] $line\n";
};
sub debug($) {
        my ($line) = @_;
        #print "[DEBUG] $line\n";
};
sub trace($) {
        my ($line) = @_;
        #print "[trace] $line\n";
};
sub trace2($) {
        my ($line) = @_;
        #print "[trace2] $line\n";
};

sub make_gpg_fds() {
        my %fds = (
                stdin => IO::Handle->new(),
                stdout => IO::Handle->new(),
                stderr => IO::Handle->new(),
                status => IO::Handle->new() );
        my $handles = GnuPG::Handles->new( %fds );
        return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
};

sub readwrite_gpg($$$$$%) {
        my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;

        trace("Entering readwrite_gpg.");

        my ($first_line, undef) = split /\n/, $in;
        debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));

        local $INPUT_RECORD_SEPARATOR = undef;
        my $sout = IO::Select->new();
        my $sin = IO::Select->new();
        my $offset = 0;

        trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");

        $inputfd->blocking(0);
        $stdoutfd->blocking(0);
        $statusfd->blocking(0) if defined $statusfd;
        $stderrfd->blocking(0);
        $sout->add($stdoutfd);
        $sout->add($stderrfd);
        $sout->add($statusfd) if defined $statusfd;
        $sin->add($inputfd);

        my ($stdout, $stderr, $status) = ("", "", "");
        my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
        trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;

        my $readwrote_stuff_this_time = 0;
        my $do_not_wait_on_select = 0;
        my ($readyr, $readyw, $written);
        while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
                if (defined $exitwhenstatusmatches) {
                        if ($status =~ /$exitwhenstatusmatches/m) {
                                trace("readwrite_gpg found match on $exitwhenstatusmatches");
                                if ($readwrote_stuff_this_time) {
                                        trace("read/write some more\n");
                                        $do_not_wait_on_select = 1;
                                } else {
                                        trace("that's it in our while loop.\n");
                                        last;
                                }
                        };
                };

                $readwrote_stuff_this_time = 0;
                trace("select waiting for ".($sout->count())." fds.");
                ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
                trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
                for my $wfd (@$readyw) {
                        $readwrote_stuff_this_time = 1;
                        if (length($in) != $offset) {
                                trace("writing to $wfd.");
                                $written = $wfd->syswrite($in, length($in) - $offset, $offset);
                                $offset += $written;
                        };
                        if ($offset == length($in)) {
                                trace("writing to $wfd done.");
                                unless ($options{'nocloseinput'}) {
                                        close $wfd;
                                        trace("$wfd closed.");
                                };
                                $sin->remove($wfd);
                                $sin = undef;
                        }
                }

                next unless (defined(@$readyr)); # Wait some more.

                for my $rfd (@$readyr) {
                        $readwrote_stuff_this_time = 1;
                        if ($rfd->eof) {
                                trace("reading from $rfd done.");
                                $sout->remove($rfd);
                                close($rfd);
                                next;
                        }
                        trace("reading from $rfd.");
                        if ($rfd == $stdoutfd) {
                                $stdout .= <$rfd>;
                                trace2("stdout is now $stdout\n================");
                                next;
                        }
                        if (defined $statusfd && $rfd == $statusfd) {
                                $status .= <$rfd>;
                                trace2("status is now $status\n================");
                                next;
                        }
                        if ($rfd == $stderrfd) {
                                $stderr .= <$rfd>;
                                trace2("stderr is now $stderr\n================");
                                next;
                        }
                }
        }
        trace("readwrite_gpg done.");
        return ($stdout, $stderr, $status);
};

sub ask($$) {
        my ($question, $default) = @_;
        my $answer;
        while (1) {
                print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
                $answer = <STDIN>;
                chomp $answer;
                last if ((defined $answer) && (length $answer <= 1));
                print "grrrrrr.\n";
                sleep 1;
        };
        my $result = $default;
        $result = 1 if $answer =~ /y/i;
        $result = 0 if $answer =~ /n/i;
        return $result;
};


my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';

load_config;
my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader";

my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';

-d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
-d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");

my $NOW = time;
my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);


sub version($) {
        my ($fd) = @_;
        print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader\n";
};

sub usage($$) {
        my ($fd, $exitcode) = @_;
        version($fd);
        print $fd "Usage: $PROGRAM_NAME [-mMR] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
        print $fd "Consult the manual page for more information.\n";
        exit $exitcode;
};

######
# export key $keyid from $gnupghome
######
sub export_key($$) {
        my ($gnupghome, $keyid) = @_;

        my $gpg = GnuPG::Interface->new();
        $gpg->call( $CONFIG{'gpg'} );
        $gpg->options->hash_init(
                'homedir' => $gnupghome,
                'armor' => 1 );
        $gpg->options->meta_interactive( 0 );
        my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
        my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
        my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
        waitpid $pid, 0;

        return $stdout;
};

######
# import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
######
sub import_key($$) {
        my ($gnupghome, $asciikey) = @_;

        my $gpg = GnuPG::Interface->new();
        $gpg->call( $CONFIG{'gpg'} );
        $gpg->options->hash_init( 'homedir' => $gnupghome );
        $gpg->options->meta_interactive( 0 );
        my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
        my $pid = $gpg->import_keys(handles => $handles);
        my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
        waitpid $pid, 0;

        if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
                return undef;
        };
        return 1;
};


######
# Send an email to $address.  If $can_encrypt is true then the mail
# will be PGP/MIME encrypted to $longkeyid.
#
# $longkeyid, $uid, and @attached will be used in the email and the template.
######
#send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
sub send_mail($$$@) {
        my ($address, $can_encrypt, $key_id, @keys) = @_;

        my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
            or die "Error creating template: $Text::Template::ERROR";

        my @uids;
        for my $key (@keys) {
            push @uids, $key->{'text'};
        };
        my $message = $template->fill_in(HASH => { key => $key_id,
                                                   uids => \@uids,
                                                   owner => $CONFIG{'owner'}})
            or die "Error filling template in: $Text::Template::ERROR";

        my $message_entity = MIME::Entity->build(
                Type        => "text/plain",
                Charset     => "utf-8",
                Disposition => 'inline',
                Data        => $message);

        my @key_entities;
        for my $key (@keys) {
                $message_entity->attach(
                        Type        => "application/pgp-keys",
                        Disposition => 'attachment',
                        Encoding    => "7bit",
                        Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
                        Data        => $key->{'key'},
                        Filename    => "0x$key_id.".$key->{'serial'}.".asc");
        };

        if ($can_encrypt) {
                my $message = $message_entity->stringify();

                my $gpg = GnuPG::Interface->new();
                $gpg->call( $CONFIG{'gpg'} );
                $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
                        'extra_args' => '--always-trust',
                        'armor' => 1 );
                $gpg->options->meta_interactive( 0 );
                my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
                $gpg->options->push_recipients( $key_id );
                $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
                my $pid = $gpg->encrypt(handles => $handles);
                my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
                waitpid $pid, 0;
                if ($stdout eq '') {
                        warn ("No data from gpg for list-key $key_id\n");
                        next;
                };
                $message = $stdout;

                $message_entity = MIME::Entity->build(
                        Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');

                $message_entity->attach(
                        Type        => "application/pgp-encrypted",
                        Disposition => 'attachment',
                        Encoding    => "7bit",
                        Data        => "Version: 1\n");
                        
                $message_entity->attach(
                        Type        => "application/octet-stream",
                        Filename    => 'msg.asc',
                        Disposition => 'inline',
                        Encoding    => "7bit",
                        Data        => $message);
        };

        $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
        $message_entity->head->add("To", $address);
        $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
        $message_entity->head->add("User-Agent", $USER_AGENT);
        $message_entity->send();
        $message_entity->stringify();
};

######
# clean up a UID so that it can be used on the FS.
######
sub sanitize_uid($) {
        my ($uid) = @_;

        my $good_uid = $uid;
        $good_uid =~ tr#/:\\#_#;
        trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
        return $good_uid;
};

sub delete_signatures($$$$$$) {
        my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;

        my $signed_by_me = 0;

        my ($stdout, $stderr, $status) =
                readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);

        while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
                # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
                my @sigline = grep { /^sig/ } (split /\n/, $stdout);
                $stdout =~ s/\n/\\n/g;
                notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
                my $line = pop @sigline;
                my $answer = "no";
                if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
                        debug("[sigremoval] doing line $line.");
                        my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
                        if ($signer eq $longkeyid) {
                                debug("[sigremoval] selfsig ($signer).");
                                $answer = "no";
                        } elsif (grep { $signer eq $_ } @{$keyids}) {
                                debug("[sigremoval] signed by us ($signer).");
                                $answer = "no";
                                $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
                        } else {
                                debug("[sigremoval] not interested in that sig ($signer).");
                                $answer = "yes";
                        };
                } else {
                        debug("[sigremoval] no sig line here, only got: ".$stdout);
                };
                ($stdout, $stderr, $status) =
                        readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
        };

        return $signed_by_me;
};


my $USER;
my @KEYIDS;
my $params;

Getopt::Long::config('bundling');
if (!GetOptions (
        '-h'              =>  \$params->{'help'},
        '--help'          =>  \$params->{'help'},
        '--version'       =>  \$params->{'version'},
        '-V'              =>  \$params->{'version'},
        '-u=s'            =>  \$params->{'local-user'},
        '--local-user=s'  =>  \$params->{'local-user'},
        '-m'              =>  \$params->{'mail'},
        '--mail'          =>  \$params->{'mail'},
        '-M'              =>  \$params->{'no-mail'},
        '--no-mail'       =>  \$params->{'no-mail'},
        '-R'              =>  \$params->{'no-download'},
        '--no-download'   =>  \$params->{'no-download'},
        )) {
        usage(\*STDERR, 1);
};
if ($params->{'help'}) {
        usage(\*STDOUT, 0);
};
if ($params->{'version'}) {
        version(\*STDOUT);
        exit(0);
};
usage(\*STDERR, 1) unless scalar @ARGV >= 1;


if ($params->{'local-user'}) {
        $USER = $params->{'local-user'};
        $USER =~ s/^0x//i;
        unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
                print STDERR "-u $USER is not a keyid.\n";
                usage(\*STDERR, 1);
        };
        $USER = uc($USER);
};

for my $keyid (@ARGV) {
        $keyid =~ s/^0x//i;
        unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8}|[A-Za-z0-9]{32})?$/) {
                print STDERR "$keyid is not a keyid.\n";
                usage(\*STDERR, 1);
        };
        push @KEYIDS, uc($keyid);
};

$CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
$CONFIG{'no-mail'}     = $params->{'no-mail'}     if defined $params->{'no-mail'};
$CONFIG{'mail'}        = $params->{'mail'}        if defined $params->{'mail'};


#################
# import own keys
#################
        my $gpg = GnuPG::Interface->new();
        $gpg->call( $CONFIG{'gpg'} );
        $gpg->options->hash_init(
                'homedir' => $GNUPGHOME,
                'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
        $gpg->options->meta_interactive( 0 );
        my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
        $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
        my $pid = $gpg->list_public_keys(handles => $handles, command_args => $CONFIG{'keyid'});
        my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
        waitpid $pid, 0;
        if ($stdout eq '') {
                warn ("No data from gpg for list-key\n");
                next;
        };
        foreach my $keyid (@{$CONFIG{'keyid'}}) {
                unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
                        info("Importing $keyid");
                        system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
                }
        }

#############################
# receive keys from keyserver
#############################
my @keyids_ok;
my @keyids_failed;
if ($CONFIG{'no-download'}) {
        @keyids_ok = @KEYIDS;
} else {
        my $gpg = GnuPG::Interface->new();
        $gpg->call( $CONFIG{'gpg'} );
        $gpg->options->hash_init(
                'homedir' => $GNUPGHOME,
                'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
        $gpg->options->meta_interactive( 0 );
        my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
        
        my @local_keyids = @KEYIDS;
        for my $keyid (@local_keyids) {
                info ("fetching $keyid...");
                my $pid = $gpg->recv_keys(handles => $handles, command_args => [ $keyid ]);
                my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
                waitpid $pid, 0;

# [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
# [GNUPG:] NODATA 1
# [GNUPG:] NODATA 1
# [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
                my $handled = 0;
                for my $line (split /\n/, $status) {
                        if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
                                my $imported_key = $1;
                                if ($keyid ne $imported_key &&
                                    $keyid ne substr($imported_key, -16) &&
                                    $keyid ne substr($imported_key, -8)) {
                                    warn("Imported unexpected key.  expected: $keyid; got: $imported_key.\n");
                                    next;
                                };
                                push @keyids_ok, $keyid;
                                shift @KEYIDS;
                                $handled = 1;
                                last;
                        } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
                                push @keyids_failed, $keyid;
                                shift @KEYIDS;
                                $handled = 1;
                                last;
                        };
                };
                unless ($handled) {
                        notice ("Huh, what's up with $keyid?");
                        push @keyids_failed, $keyid;
                        shift @KEYIDS;
                };
        };
        die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
        notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
};

###########
# sign keys
###########
unless ($CONFIG{'no-sign'}) {
        info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
        for my $keyid (@keyids_ok) {
                my @command;
                push @command, $CONFIG{'gpg-sign'};
                push @command, '--local-user', $USER if (defined $USER);
                push @command, "--homedir=$GNUPGHOME";
                push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
                push @command, '--edit', $keyid;
                push @command, 'sign';
                print join(' ', @command),"\n";
                system (@command);
        };
};

##################
# export and prune
##################
KEYS:
for my $keyid (@keyids_ok) {
        # get key listing
        #################
        my $gpg = GnuPG::Interface->new();
        $gpg->call( $CONFIG{'gpg'} );
        $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
        $gpg->options->meta_interactive( 0 );
        my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
        $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
        my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
        my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
        waitpid $pid, 0;
        if ($stdout eq '') {
                warn ("No data from gpg for list-key $keyid\n");
                next;
        };
        my @publine = grep { /^pub/ } (split /\n/, $stdout);
        if (scalar @publine == 0) {
                warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
                next;
        };
        my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
        if (scalar @publine > 0) {
                warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
                next;
        };
        unless (defined $longkeyid) {
                warn ("Didn't find public keyid in --list-key of key $keyid.\n");
                next;
        };
        unless (defined $flags) {
                warn ("Didn't find flags in --list-key of key $keyid.\n");
                next;
        };
        my $can_encrypt = $flags =~ /E/;

        # export the key
        ################
        my $asciikey = export_key($GNUPGHOME, $keyid);
        if ($asciikey eq '') {
                warn ("No data from gpg for export $keyid\n");
                next;
        };

        my @UIDS;
        my $uid_number = 0;
        while (1) {
                my $this_uid_text = '';
                $uid_number++;
                debug("Doing key $keyid, uid $uid_number");
                my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);

                # import into temporary gpghome
                ###############################
                my $result = import_key($tempdir, $asciikey);
                unless ($result) {
                        warn ("Could not import $keyid into temporary gnupg.\n");
                        next;
                };

                # prune it
                ##########
                $gpg = GnuPG::Interface->new();
                $gpg->call( $CONFIG{'gpg-delsig'} );
                $gpg->options->hash_init(
                        'homedir' => $tempdir,
                        'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
                ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
                $pid = $gpg->wrap_call(
                        commands     => [ '--edit' ],
                        command_args => [ $keyid ],
                        handles      => $handles );

                debug("Starting edit session");
                ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);

                # delete other uids
                ###################
                my $number_of_subkeys = 0;
                my $i = 1;
                my $have_one = 0;
                my $is_uat = 0;
                my $delete_some = 0;
                debug("Parsing stdout output.");
                for my $line (split /\n/, $stdout) {
                        debug("Checking line $line");
                        my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
                        if ($type eq 'sub') {
                                $number_of_subkeys++;
                        };
                        next unless ($type eq 'uid' || $type eq 'uat');
                        debug("line is interesting.");
                        if ($uid_number != $i) {
                                debug("mark for deletion.");
                                readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
                                $delete_some++;
                        } else {
                                debug("keep it.");
                                $have_one = 1;
                                $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
                                $is_uat = $type eq 'uat';
                        };
                        $i++;
                };
                debug("Parsing stdout output done.");
                unless ($have_one) {
                        debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
                        info("key $keyid done.");
                        last;
                };

                my $prune_some_sigs_on_uid;
                my $prune_all_sigs_on_uid;
                if ($is_uat) {
                        debug("handling attribute userid of key $keyid.");
                        if ($uid_number == 1) {
                                debug(" attribute userid is #1, unmarking #2 for deletion.");
                                readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
                                $delete_some--;
                                $prune_some_sigs_on_uid = 1;
                                $prune_all_sigs_on_uid = 2;
                        } else {
                                debug("attribute userid is not #1, unmarking #1 for deletion.");
                                readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
                                $delete_some--;
                                $prune_some_sigs_on_uid = 2;
                                $prune_all_sigs_on_uid = 1;
                        };
                } else {
                        $prune_some_sigs_on_uid = 1;
                };

                if ($delete_some) {
                        debug("need to delete $delete_some uids.");
                        readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
                        readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
                };

                # delete subkeys
                ################
                if ($number_of_subkeys > 0) {
                        for (my $i=1; $i<=$number_of_subkeys; $i++) {
                                readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
                        };
                        readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
                        readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
                };

                # delete signatures
                ###################
                readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
                my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
                readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
                if (defined $prune_all_sigs_on_uid) {
                        readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
                        delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
                        readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
                };


                readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
                waitpid $pid, 0;

                my $asciikey = export_key($tempdir, $keyid);
                if ($asciikey eq '') {
                        warn ("No data from gpg for export $keyid\n");
                        next;
                };

                if ($signed_by_me) {
                        if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
                                my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
                                next unless $write;
                        };
                        my $keydir = "$KEYSBASE/$DATE_STRING";
                        -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");

                        my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
                        open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
                        print KEY $asciikey;
                        close KEY;

                        push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };

                        info("$longkeyid $uid_number $this_uid_text done.");
                } else {
                        info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
                };
        };

        if (scalar @UIDS == 0) {
                info("found no signed uids for $keyid");
        } else {
                next if $CONFIG{'no-mail'}; # do not send mail

                my @attached;
                for my $uid (@UIDS) {
                        trace("UID: $uid->{'text'}\n");
                        if ($uid->{'is_uat'}) {
                                my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
                                push @attached, $uid if $attach;
                        } elsif ($uid->{'text'} !~ /@/) {
                                my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
                                push @attached, $uid if $attach;
                        };
                };

                notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
                for my $uid (@UIDS) {
                        if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
                                my $address = $uid->{'text'};
                                $address =~ s/.*<(.*)>.*/$1/;
                                if ($CONFIG{'mail'} or ask("Send mail to '$address' for $uid->{'text'}?", 1)) {
                                        my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);

                                        my $keydir = "$KEYSBASE/$DATE_STRING";
                                        my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
                                        open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
                                        print KEY $mail;
                                        close KEY;
                                };
                        };
                };
        };

};