#!/usr/bin/perl -w

# caff  --  CA - Fire and Forget
#
# Copyright (c) 2004 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> [-d] [-m] [-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<-u> I<yourkeyid>

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

=item B<-d> 

Do not download keys from keyserver

=item B<-m> 

Do not mail anything automatically.

=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'}       = 'Peter Palfrader';
	$CONFIG{'email'}       = 'peter@palfrader.org';

=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 is
needed while the upstream GnuPG is not fixed  (there are 2 bugs in the
Debian Bug Tracking System).  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<public-keyring> [string]

Path to your public keyring.  Default: B<$HOME/.gnupg/pubring.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<extensions> [list of extensions]

Load the named extensions when calling B<gpg-sign>.

=back

=head1 AUTHOR

Peter Palfrader <peter@palfrader.org>

=cut

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

my %CONFIG;

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

# Getopt::Std requires package-global vars
our ( $opt_u, $opt_m, $opt_d );

sub load_config() {
    my $config = $ENV{'HOME'} . '/.caffrc';
    -f $config or die "No file $config present.  See caffrc(5).\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{'public-keyring'} = $ENV{'HOME'} . '/.gnupg/pubring.gpg'
      unless defined $CONFIG{'public-keyring'};
    $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
    $CONFIG{'no-sign'}     = 0 unless defined $CONFIG{'no-sign'};
}

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, $dummy ) = 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("doign stuff until we find $exitwhenstatusmatches")
      if defined $exitwhenstatusmatches;

    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");
                last;
            }
        }

        trace( "select waiting for " . ( $sout->count() ) . " fds." );
        ( $readyr, $readyw, undef ) =
          IO::Select::select( $sout, $sin, undef, 1 );
        trace(  "ready: write: "
              . ( defined $readyw ? scalar @$readyw : 0 )
              . "; read: "
              . ( defined $readyr ? scalar @$readyr : 0 ) );
        for my $wfd (@$readyw) {
            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) {
            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 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 usage() {
    print STDERR "caff $VERSION - (c) 2004 Peter Palfrader\n";
    print STDERR "Usage: $PROGRAM_NAME [-u <yourkeyid] <keyid> [<keyid> ...]\n";
    exit 1;
}

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;
}

sub fetch_ownpubkey {
    my @notfound;
    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();
    my %found =
      map { ( $_, 1 ) } $gpg->get_public_keys( @{ $CONFIG{'keyid'} } );
    foreach my $id ( @{ $CONFIG{'keyid'} } ) {

        if ( not exists $found{$id} ) {
            push @notfound, $id;
        }
    }
    return unless @notfound;
    my ( @exp, @imp );
    push @exp, $CONFIG{'gpg'};
    push @exp, "--keyring " . $CONFIG{'public-keyring'};
    push @exp, "--quiet";
    push @exp, "--batch";
    push @exp, "--export";
    push @imp, "| $CONFIG{'gpg'}";
    push @imp, "--homedir $GNUPGHOME";
    push @imp, "--import";
    push @imp, "--quiet";
    foreach my $keyid (@notfound) {
        my @tmpexp = @exp;
        push @tmpexp, "$keyid";
        push @tmpexp, @imp;
        my $cline = join " ", @tmpexp;
        debug("calling $cline");
        if ( system($cline) != 0 ) {
            debug("$cline failed: $!");
        }
    }
}

#send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
sub send_mail($$$@) {
    my ( $address, $can_encrypt, $key_id, @keys ) = @_;

    my $message = "Hi,\n\n";

    $message .=
      'please find attached the user id'
      . ( scalar @keys >= 2 ? 's' : '' ) . "\n";
    for my $key (@keys) {
        $message .= "\t" . $key->{'text'} . "\n";
    }
    $message .= qq{of your key $key_id 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_id

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

Regards,
$CONFIG{'owner'}
};
    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 );
    unless ($opt_m) {
        debug("calling Mail::Internet->send");
        $message_entity->send();
    }
    return $message_entity->stringify();
}

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;
}

my $USER;
my @KEYIDS;

# main
getopts('u:md');
usage() unless scalar @ARGV >= 1;

if ($opt_u) {
    usage() if ( "$opt_u" eq "1" );
    $USER = $opt_u;
    unless ( $USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/ ) {
        print STDERR "-u $USER is not a keyid.\n";
        usage();
    }
    $USER = uc($USER);
}

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

#############################
# receive keys from keyserver
#############################
my @keyids_ok;
my @keyids_failed;
if ( $CONFIG{'no-download'} || $opt_d ) {
    @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 $pid = $gpg->recv_keys( handles => $handles, command_args => [@KEYIDS] );
    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
    for my $line ( split /\n/, $status ) {
        if ( $line =~ /^\[GNUPG:\] IMPORT_OK/ ) {
            push @keyids_ok, shift @KEYIDS;
        }
        elsif ( $line =~ /^\[GNUPG:\] NODATA/ ) {
            push @keyids_failed, 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;
}

fetch_ownpubkey();

###########
# sign keys
###########

unless ( $CONFIG{'no-sign'} ) {
    info("Sign the following keys according to your policy...");
    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'};
        if ( $CONFIG{'extensions'} ) {
            my @load = @{ $CONFIG{'extensions'} };
            while (@load) {
                my $ext = shift @load;
                push @command, '--load-extension', $ext;
            }
        }
        push @command, '--sign-key', $keyid;
        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 $keyinfo = $stdout;
    my @publine = grep { /^pub/ } ( split /\n/, $stdout );
    my (
        $dummy1, $dummy2, $dummy3, $dummy4,  $longkeyid, $dummy6,
        $dummy7, $dummy8, $dummy9, $dummy10, $dummy11,   $flags
      )
      = split /:/, pop @publine;
    my $can_encrypt = $flags =~ /E/;
    unless ( defined $longkeyid ) {
        warn("Didn't find public keyid in edit dialog of key $keyid.\n");
        next;
    }

    # 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++;
        info("Doing key $keyid, uid $uid_number");

        # import into temporary gpghome
        ###############################
        my $tempdir =
          tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1 );
        my $gpg = GnuPG::Interface->new();
        $gpg->call( $CONFIG{'gpg'} );
        $gpg->options->hash_init( 'homedir' => $tempdir );
        $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 ) {
            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,   $dummy2, $dummy3, $dummy4, $dummy5,
                $dummy6, $dummy7, $dummy8, $dummy9, $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 = 1;
            }
            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.");
        if ($is_uat) {
            notice("Can't handle attribute userid of key $keyid.");
            next;
        }
        unless ($have_one) {
            info("key $keyid done.");
            last;
        }
        if ($delete_some) {
            debug("need to delete a few 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
        ###################
        my $signed_by_me = 0;
        readwrite_gpg(
            "1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd,
            exitwhenstatusmatches => $KEYEDIT_PROMPT,
            nocloseinput          => 1
        );
        ( $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 );
            my $line    = pop @sigline;
            my $answer  = "no";
            if ( defined $line )
            { # only if we found a sig here - we never remove revocation packets for instance
                my (
                    $dummy1,  $dummy2, $dummy3, $dummy4, $signer,
                    $created, $dummy7, $dummy8, $dummy9
                  )
                  = split /:/, $line;
                if ( $signer eq $longkeyid ) {
                    $answer = "no";
                }
                elsif ( grep { $signer eq $_ } @{ $CONFIG{'keyid'} } ) {
                    $answer       = "no";
                    $signed_by_me =
                      $signed_by_me > $created ? $signed_by_me : $created;
                }
                else {
                    $answer = "yes";
                }
            }
            ( $stdout, $stderr, $status ) = readwrite_gpg(
                $answer . "\n", $inputfd, $stdoutfd, $stderrfd, $statusfd,
                exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT,
                nocloseinput          => 1
            );
        }
        readwrite_gpg( "save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd );
        waitpid $pid, 0;

        my $asciikey = export_key( $tempdir, $longkeyid );
        if ( $asciikey eq '' ) {
            warn("No data from gpg for export $longkeyid\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
              };

            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 {
        my @attached;
        for my $uid (@UIDS) {
            trace("UID: $uid->{'text'}\n");
            unless ( $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->{'text'} =~ /@/ ) {
                my $address = $uid->{'text'};
                $address =~ s/.*<(.*)>.*/$1/;
                my $send =
                  ask( "Send mail to '$address' for $uid->{'text'}?", 1 );
                if ($send) {
                    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;
                }
            }
        }
    }

}

###############################################################3
#### old fork gpg --edit
=cut




		my ($stdin_read, $stdin_write);
		my ($stdout_read, $stdout_write);
		my ($stderr_read, $stderr_write);
		my ($status_read, $status_write);
		pipe $stdin_read, $stdin_write;
		pipe $stdout_read, $stdout_write;
		pipe $stderr_read, $stderr_write;
		pipe $status_read, $status_write;

		$pid = fork();
		unless ($pid) { # child
			close $stdin_write;
			close $stdout_read;
			close $stderr_read;
			close $status_read;

			my @call;
			push @call, $CONFIG{'gpg-delsig'};
			push @call, "--homedir=$tempdir";
			push @call, '--with-colons';
			push @call, '--fixed-list-mode';
			push @call, '--command-fd=0';
			push @call, "--status-fd=".fileno($status_write);
			push @call, "--no-tty";
			push @call, "--edit";
			push @call, $keyid;

			close STDIN;
			close STDOUT;
			close STDERR;
			open(STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
			open(STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
			open(STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");

			fcntl $status_write, F_SETFD, 0;

			exec (@call);
			exit;
		};
		close $stdin_read;
		close $stdout_write;
		close $stderr_write;
		close $status_write;

		$inputfd = $stdin_write;
		$stdoutfd = $stdout_read;
		$stderrfd = $stderr_read;
		$statusfd = $status_read;
=cut