signing-party 1.1.5-1 / usr / bin / caff

#!/usr/bin/perl -w

# caff  --  CA - Fire and Forget
# $Id: caff 506 2014-01-30 13:22:46Z thijs $
#
# Copyright (c) 2004, 2005, 2006 Peter Palfrader <peter@palfrader.org>
# Copyright (c) 2005, 2006 Christoph Berg <cb@df7cb.de>
#
# 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> [-eERS] [-m I<yes|ask-yes|ask-no|no>] [-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.  The mailed key is encrypted with itself as a means
to verify that key belongs to the recipient.

=head1 OPTIONS

=over

=item B<-e>, B<--export-old>

Export old signatures. Default is to ask the user for each old signature.

=item B<-E>, B<--no-export-old>

Do not export old signatures. Default is to ask the user for each old
signature.

=item B<-m>, B<--mail> I<yes|ask-yes|ask-no|no>

Whether to send mail after signing. Default is to ask, for each uid,
with a default value of yes.

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

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

=item B<-S>, B<--no-sign>

Do not sign the keys.

=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.
To sign with multiple keys at once, separate multiple keyids by comma. This
option requires the key(s) to be defined through the keyid variable in the
configuration file.

=item B<--key-file> I<file>

Import keys from file. Can be supplied more than once.

=item B<--keys-from-gnupg>

Try to import keys from your standard GnuPG keyrings.

=back

=head1 FILES

=over

=item $HOME/.caffrc  -  configuration file

=item $HOME/.caff/keys/yyyy-mm-dd/  -  processed keys

=item $HOME/.caff/gnupghome/  -  caff's working dir for gpg

=item $HOME/.caff/gnupghome/gpg.conf  -  gpg configuration

useful options include use-agent, keyserver-options, default-cert-level, etc.

=back

=head1 CONFIGURATION FILE OPTIONS

The configuration file is a perl script that sets values in the hash B<%CONFIG>.
The file is generated when it does not exist.

Example:

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

=head2 Required basic settings

=over

=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>.

=back

=head2 General settings

=over

=item B<caffhome> [string]

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

=back

=head2 GnuPG settings

=over

=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, or list of keyids]

Additional keyids to encrypt messages to. Default: none.

=item B<gpg-sign-args> [string]

Additional commands to pass to gpg after the "sign" command.
Default: none.

=back

=head2 Keyserver settings

=over

=item B<keyserver> [string]

Keyserver to download keys from.  Default: B<pool.sks-keyservers.net>.

=item B<no-download> [boolean]

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

=item B<key-files> [list of files]

A list of files containing keys to be imported.

=back

=head2 Signing settings

=over

=item B<no-sign> [boolean]

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

=item B<ask-sign> [boolean]

If true, then pause before continuing to the signing step.
This is useful for offline signing. Default: B<0>.

=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<local-user> [keyid, or list of keyids]

Select the key that is used for signing, in case you have more than one key.
With multiple keyids, sign with each key in turn.

=back

=head2 Mail settings

=over

=item B<mail> [boolean]

Whether to send mails. This is a quad-option, with which you can set the
behaviour: yes always sends, no never sends; ask-yes and ask-no asks, for
each uid, with according defaults for the question. Default: B<ask-yes>.

In any case, the messages are also written to $CONFIG{'caffhome'}/keys/

=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

=item B<reply-to> [string]

Add a Reply-To: header to messages sent. Default: none.

=item B<bcc> [string]

Address to send blind carbon copies to when sending mail.
Default: none.

=item B<mailer-send> [array]

Parameters to pass to Mail::Mailer.
This could for example be

	$CONFIG{'mailer-send'} =  [ 'smtp', Server => 'mail.server', Auth => ['user', 'pass'] ];

to use the perl SMTP client or

	$CONFIG{'mailer-send'} =  [ 'sendmail', '-o8' ];

to pass arguments to the sendmail program.
For more information run C<< perldoc Mail::Mailer >>.
Setting this option is strongly discouraged.  Fix your local MTA
instead.
Default: none.

=back

=head1 AUTHORS

=over

=item Peter Palfrader <peter@palfrader.org>

=item Christoph Berg <cb@df7cb.de>

=back

=head1 WEBSITE

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

=head1 SEE ALSO

gpg(1), pgp-clean(1), /usr/share/doc/signing-party/caff/

=cut

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

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

# Global variables
my @KEYIDS;
my $params;

##
# Display an error message on STDERR and then exit.
#
# @param $exitcode exit code status to use to end the program
# @param $line     error message to display on STDERR
#
sub myerror($$) {
	my ($exitcode, $line) = @_;
	print "[ERROR] $line\n";	
	exit $exitcode;
};

sub mywarn($) {
	my ($line) = @_;
	print "[WARN] $line\n";
};
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 generate_config() {
	notice("Error: \$LOGNAME is not set.") unless defined $ENV{'LOGNAME'};
	my $gecos = defined $ENV{'LOGNAME'} ? (getpwnam($ENV{LOGNAME}))[6] : undef;
	my $email;
	my @keys;
	# BSD does not have hostname -f, so we try without -f first
	my $hostname = `hostname`;
	$hostname = `hostname -f` unless $hostname =~ /\./;
	chomp $hostname;
	my ($Cgecos,$Cemail,$Ckeys) = ('','','');

	if (defined $gecos) {
		$gecos =~ s/,.*//;

		my $gpg = GnuPG::Interface->new();
		$gpg->call( 'gpg' );
		$gpg->options->hash_init(
			'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
		$gpg->options->meta_interactive( 0 );
		my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
		my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $gecos ]);
		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"); # There should be at least 'tru:' everywhere.
		};

		@keys = ($stdout =~ /^pub:[^r:]*:(?:[^:]*:){2,2}([^:]+):/mg);
		unless (scalar @keys) {
			info("Error: No keys were found using \"gpg --list-public-keys '$gecos'\".");
			@keys = qw{0123456789abcdef 89abcdef76543210};
			$Ckeys = '#';
		}
		($email) =  ($stdout =~ /^uid:.*<(.+?@.+?)>.*:/m);
		unless (defined $email) {
			info("Error: No email address was found using \"gpg --list-public-keys '$gecos'\".");
			$email = $ENV{'LOGNAME'}.'@'.$hostname;
			$Cemail = '#';
		}
	} else {
		$gecos = 'Unknown Caff User';
		$email = $ENV{'LOGNAME'}.'@'.$hostname;
		@keys = qw{0123456789abcdef 89abcdef76543210};
		($Cgecos,$Cemail,$Ckeys) = ('#','#','#');
	};

	my $template = <<EOT;
# .caffrc -- vim:ft=perl:
# This file is in perl(1) format - see caff(1) for details.

$Cgecos\$CONFIG{'owner'} = '$gecos';
$Cemail\$CONFIG{'email'} = '$email';
#\$CONFIG{'reply-to'} = 'foo\@bla.org';

# You can get your long keyid from
#   gpg --with-colons --list-key <yourkeyid|name|emailaddress..>
#
# If you have a v4 key, it will simply be the last 16 digits of
# your fingerprint.
#
# Example:
#   \$CONFIG{'keyid'} = [ qw{FEDCBA9876543210} ];
#  or, if you have more than one key:
#   \$CONFIG{'keyid'} = [ qw{0123456789ABCDEF 89ABCDEF76543210} ];
$Ckeys\$CONFIG{'keyid'} = [ qw{@keys} ];

# Select this/these keys to sign with
#\$CONFIG{'local-user'} = [ qw{@keys} ];

# Additionally encrypt messages for these keyids
#\$CONFIG{'also-encrypt-to'} = [ qw{@keys} ];

# Mail template to use for the encrypted part
#\$CONFIG{'mail-template'} = << 'EOM';
EOT

	$template .= "#$_" foreach <DATA>;
	$template .= "#EOM\n";
	return $template;
};

sub check_executable($$) {
	# (GnuPG::Interface gives lousy errors when the gpg binary isn't found,
	# so we want to check manually.)
	my ($purpose, $fn) = @_;
	# Only check provided fnames with a slash in them.
	return unless defined $fn;
	if ($fn =~ m!/!) {
		die ("$PROGRAM_NAME: $purpose executable '$fn' not found.\n") unless -x $fn;
	} else {
		for my $p (split(':', $ENV{PATH})) {
			return if -x "$p/$fn";
		};
		die ("$PROGRAM_NAME: $purpose executable '$fn' not found on path.\n") unless -x $fn;
	};
};

sub load_config() {
	my $config = $ENV{'HOME'} . '/.caffrc';
	unless (-f $config) {
		print "No configfile $config present, I will use this template:\n";
		my $template = generate_config();
		print "$template\nPlease edit $config and run caff again.\n";
		open F, ">$config" or die "$config: $!";
		print F $template;
		close F;
		exit(1);
	}
	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 ("$PROGRAM_NAME: owner is not defined in $config.\n") unless defined $CONFIG{'owner'};
	die ("$PROGRAM_NAME: email is not defined in $config.\n") unless defined $CONFIG{'email'};
	die ("$PROGRAM_NAME: keyid is not defined in $config.\n") unless defined $CONFIG{'keyid'};
	die ("$PROGRAM_NAME: keyid is not an array ref in $config.\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
	for my $keyid (@{$CONFIG{'keyid'}}) {
		$keyid =~ /^[A-F0-9]{16}$/i or die ("$PROGRAM_NAME: key $keyid is not a long (16 digit) keyid in $config.\n");
	};
	@{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
	$CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
	$CONFIG{'keyserver'} = 'pool.sks-keyservers.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'};
	check_executable("gpg", $CONFIG{'gpg'});
	check_executable("gpg-sign", $CONFIG{'gpg-sign'});
	check_executable("gpg-delsig", $CONFIG{'gpg-delsig'});
	$CONFIG{'secret-keyring'} = ($ENV{'GNUPGHOME'} || "$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{'key-files'} = () unless defined $CONFIG{'key-files'};
	$CONFIG{'mailer-send'} = [] unless defined $CONFIG{'mailer-send'};
	die ("$PROGRAM_NAME: mailer-send is not an array ref in $config.\n") unless (ref $CONFIG{'mailer-send'} eq 'ARRAY');
	unless (defined $CONFIG{'mail-template'}) {
		$CONFIG{'mail-template'} .= $_ foreach <DATA>;
	}
	if ((defined $CONFIG{'also-encrypt-to'}) && ! (ref($CONFIG{'also-encrypt-to'}) eq 'ARRAY')) {
		$CONFIG{'also-encrypt-to'} = [ $CONFIG{'also-encrypt-to'} ];
	};
};

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 ($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, $forceyes, $forceno) = @_;
	my $answer;
	my $yn = $default ? '[Y/n]' : '[y/N]';
	while (1) {
		print $question,' ',$yn, ' ';
		if ($forceyes && $forceno) {
			print "$default (from config/command line)\n";
			return $default;
		};
		if ($forceyes) {
			print "YES (from config/command line)\n";
			return 1;
		};
		if ($forceno) {
			print "NO (from config/command line)\n";
			return 0;
		};

		$answer = <STDIN>;
		if (!defined $answer) {
			$OUTPUT_AUTOFLUSH = 1;
			die "\n\n".
			    "End of STDIN reached.  Are you using xargs?  Caff wants to read from STDIN,\n".
			    "so you can't really use it with xargs.  A patch against caff to read from\n".
			    "the terminal would be appreciated.\n".
			    "For now instead of   cat keys | xargs caff  do  caff `cat keys`\n";
		};
		chomp $answer;
		last if ((length $answer == 0) || ($answer =~ m/^[yYnN]$/) );
		print "What about $yn is so hard to understand?\nAnswer with either 'n' or 'y' or just press enter for the default.\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 - http://pgp-tools.alioth.debian.org/";

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, 2006 Peter Palfrader et al.\n";
};

sub usage($$) {
	my ($fd, $exitcode) = @_;
	version($fd);
	print $fd "Usage: $PROGRAM_NAME [-eERS] [-m <yes|ask-yes|ask-no|no>] [-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'} );
	if (defined $gnupghome) {
		$gpg->options->hash_init(
			'homedir' => $gnupghome,
			'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
			'armor' => 1 );
	} else {
		$gpg->options->hash_init(
			'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
			'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;
};

######
# create trustdb in $gnupghome
######
sub create_trustdb($) {
	my ($gnupghome) = @_;

	my $gpg = GnuPG::Interface->new();
	$gpg->call( $CONFIG{'gpg'} );
	$gpg->options->hash_init(
		'homedir' => $gnupghome,
		'extra_args' => [ qw{ --import-ownertrust } ] );
	$gpg->options->meta_interactive( 0 );
	my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
	my $pid = $gpg->wrap_call(handles => $handles);
	my ($stdout, $stderr, $status) = readwrite_gpg('#\n', $inputfd, $stdoutfd, $stderrfd, $statusfd);
	waitpid $pid, 0;
};

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

	create_trustdb($gnupghome);

	my $gpg = GnuPG::Interface->new();
	$gpg->call( $CONFIG{'gpg'} );
	$gpg->options->hash_init(
		'homedir' => $gnupghome,
		'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ] );
	$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;
};


######
# Create 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.
######
# create_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
sub create_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'}).'), signed by 0x'.$CONFIG{'keyid'}[0],
			Data        => $key->{'key'},
			Filename    => "0x$key_id.".$key->{'serial'}.".signed-by-0x".$CONFIG{'keyid'}[0].".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' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
			'armor' => 1 );
		$gpg->options->meta_interactive( 0 );
		my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
		$gpg->options->push_recipients( $key_id );
		if (defined $CONFIG{'also-encrypt-to'}) {
			$gpg->options->push_recipients($_) foreach @{$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 '') {
			if (($status =~ /^\[GNUPG:\] INV_RECP ([0-9]+) ([0-9A-F]+)/m) and
			    (defined $CONFIG{'also-encrypt-to'})) {
				my $reason = $1;
				my $keyid = $2;
				if (grep { $_ eq $keyid } @{$CONFIG{'also-encrypt-to'}}) {
					warn("Could not encrypt to $keyid, specified in CONFIG{'also-encrypt-to'}.\n".
					     "Try to update the key using gpg --homedir=$GNUPGHOME --import <exported key>\n".
					     "or try the following if you are slightly more daring:\n".
					     " gpg --export $keyid | gpg --homedir=$GNUPGHOME --import\n");
					return;
				};
			};
			warn ("No data from gpg for encrypting mail.  STDERR was:\n$stderr\nstatus output was:\n$status\n");
			return;
		};
		$message = $stdout;

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

		$message_entity->attach(
			Type        => "application/pgp-encrypted",
			Filename    => "signedkey.msg",
			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", '"'.Encode::encode('MIME-Q', $CONFIG{'owner'}).'" <'.$CONFIG{'email'}.'>');
	$message_entity->head->add("Sender", '"'.Encode::encode('MIME-Q', $CONFIG{'owner'}).'" <'.$CONFIG{'email'}.'>');
	$message_entity->head->add("Reply-To", $CONFIG{'reply-to'}) if defined $CONFIG{'reply-to'};
	$message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
	$message_entity->head->add("User-Agent", $USER_AGENT);
	return $message_entity;
};

######
# send a mail message (MIME::Entity)
######
my $warned_about_broken_mailer_send = 0;
sub send_message($) {
	my ($message_entity) = @_;

	if ( (scalar @{$CONFIG{'mailer-send'}} > 0) && !$warned_about_broken_mailer_send) {
		mywarn("You have set arguments to pass to Mail::Mailer.  Better fix your MTA.  (Also, Mail::Mailer's error reporting is non existant, so it won't tell you when it doesn't work.)");
		$warned_about_broken_mailer_send = 1;
	};
	$message_entity->send(@{$CONFIG{'mailer-send'}});
};

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

##
# Check the local user keys.
#
# This function checks if the keyids defined through the --local-user
# command line option or set in ~/.caffrc are valid and known to be one of the
# keyids listed in ~/.caffrc.
#
# @return an array containing the local user keys\n
#         (undef) if no valid key has been found
#
sub get_local_user_keys() {
	my @local_user = ();
	my @key_list;
	
	# No user-defined key id has been specified by the user, no need for
	# further checks
	if (!$CONFIG{'local-user'}) {
		return (undef);
	}	
	
	# Parse the list of keys
	if (ref($CONFIG{'local-user'})) {
		@key_list = @{$CONFIG{'local-user'}};
	}
	else {
		@key_list = split /\s*,\s*/, $CONFIG{'local-user'};
	}

	# Check every key defined by the user...
	for my $user_key (@key_list) {
		
		$user_key =~ s/^0x//i;
		$user_key = uc($user_key);
		
		unless ($user_key =~ m/^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/) {
			mywarn "Local-user $user_key is not a valid keyid.";
			next;
		}
		
		unless (grep (/$user_key$/, @{$CONFIG{'keyid'}})) {
			mywarn "Local-user $user_key is not defined as one of your keyid in ~/.caffrc (it will not be used).";
			next;
		}
		
		push (@local_user, $user_key);
	}

	# If no local-user key are valid, there is no need to go further
	unless (defined $local_user[0]) {
		myerror	(1, "None of the local-user keys seem to be known as a keyid listed in ~/.caffrc.");
	}

	return @local_user;
}

##
# Import a key from the user gnupghome into a specified gnupghome.
#
# @param asciikey      ascii format of the gpg key to import
# @param dst_gnupghome gnupghome directory where to import the key
#
# @return 0 if successful\n
#         1 if the key could not be exported.\n
#         2 if the key could not be imported.
#
sub import_key_from_user_gnupghome($$) {
	my $err;
	my ($asciikey, $dst_gpghome) = @_;

	trace("Exporting key $asciikey from your normal GnuPGHOME.");
	my $key = export_key(undef, $asciikey);
	if (defined $key && $key ne '') {
		trace("Importing key $asciikey into $GNUPGHOME.");
		if (import_key($GNUPGHOME, $key)) {
			$err = 0;
		} else {
			warn("Could not import $asciikey into caff's gnupghome.");
			$err = 2;
		}
	} else {
		$err = 1;
	}

	return $err;
}

##
# Import a key file into a specified gnupghome.
#
# @param keyfile       file containing the keys to import
# @param dst_gnupghome gnupghome directory where to import the key
#
# @return 0 if successful\n
#         1 if an error occured.
#
sub import_key_files($$) {
	my $err;
	my ($keyfile, $dst_gpghome) = @_;

	my $gpg = GnuPG::Interface->new();
	$gpg->call( $CONFIG{'gpg'} );
	$gpg->options->hash_init(
		'homedir' => $dst_gpghome,
		'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ] );
	$gpg->options->meta_interactive( 0 );
	my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
	my $pid = $gpg->import_keys(handles => $handles, command_args => $keyfile);
	my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
	info("Importing keys from file $keyfile");
	waitpid $pid, 0;

	if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
		warn $stderr;
		$err = 1;
	} else {
		$err = 0;
	}

	return $err;
}

##
# Import keys to be signed into caff gnupghome directory.
#
# This function imports the keys the user wants to sign into the caff gnupghome
# directory. We looks for the keys in the the user gnupghome directory first,
# and in the key files specified by the user if not all of the keys have been
# found.
#
sub import_keys_to_sign() {
	# Check if we can find the gpg key from our normal gnupghome, and then
	# try to import it into our working gnupghome directory
	if ($CONFIG{'keys-from-gnupg'}) {
		foreach my $keyid (@KEYIDS) {
			if (!import_key_from_user_gnupghome($keyid, $GNUPGHOME)) {
				info("Key $keyid imported from your normal GnuPGHOME.");
			}
		}
	};

	# Import user specified key files
	foreach my $keyfile (@{$CONFIG{'key-files'}}) {
		import_key_files($keyfile, $GNUPGHOME);
	}

	return 0;
}

###################
# argument handling
###################
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'},
	'-e'                =>  \$params->{'export-old'},
	'--export-old'      =>  \$params->{'export-old'},
	'-E'                =>  \$params->{'no-export-old'},
	'--no-export-old'   =>  \$params->{'no-export-old'},
	'-m:s'              =>  \$params->{'mail'},
	'--mail:s'          =>  \$params->{'mail'},
	'-M'                =>  \$params->{'no-mail'},
	'--no-mail'         =>  \$params->{'no-mail'},
	'-R'                =>  \$params->{'no-download'},
	'--no-download'     =>  \$params->{'no-download'},
	'-S'                =>  \$params->{'no-sign'},
	'--no-sign'         =>  \$params->{'no-sign'},
	'--key-file=s@'     =>  \$params->{'key-files'},
	'--keys-from-gnupg' =>  \$params->{'keys-from-gnupg'},
	)) {
	usage(\*STDERR, 1);
};
if ($params->{'help'}) {
	usage(\*STDOUT, 0);
};
if ($params->{'version'}) {
	version(\*STDOUT);
	exit(0);
};
usage(\*STDERR, 1) unless scalar @ARGV >= 1;

for my $hashkey (qw{local-user no-download no-sign no-mail mail keys-from-gnupg}) {
	$CONFIG{$hashkey} = $params->{$hashkey}  if defined $params->{$hashkey};
};
# If old 'no-mail' parameter, or if the 'mail' parameter is set to 'no'
if ( defined $CONFIG{'no-mail'} || 
     ( defined $CONFIG{'mail'} && $CONFIG{'mail'}  eq 'no' ) ) {
	$CONFIG{'mail'} = 'no';

} elsif ( !defined $CONFIG{'mail'} ) {
	$CONFIG{'mail'} = 'ask-yes';
}

push @{$CONFIG{'key-files'}}, @{$params->{'key-files'}} if defined $params->{'key-files'};

for my $keyid (map { split /\n/ } @ARGV) { # caff "`cat txt`" is a single argument
	$keyid =~ s/^0x//i;
	$keyid =~ s/ //g; # gpg --fingerprint includes spaces
	if ($keyid =~ /^[A-F0-9]{32}$/i) {
		info("Ignoring v3 fingerprint $keyid.  v3 keys are obsolete.");
		next;
	};
	if ($keyid !~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
		print STDERR "$keyid is not a keyid.\n";
		usage(\*STDERR, 1);
	};
	push @KEYIDS, uc($keyid);
};

#################
# import own keys
#################
for my $keyid (@{$CONFIG{'keyid'}}) {
	info("Importing key $keyid from your normal GnuPGHome.");
	if (import_key_from_user_gnupghome($keyid, $GNUPGHOME)) {
		mywarn("Key $keyid not found.");
	}
}

&import_keys_to_sign();

#############################
# receive keys from keyserver
#############################
my @keyids_ok;
if ($CONFIG{'no-download'}) {
	@keyids_ok = @KEYIDS;
} else {
	info ("fetching keys, this will take a while...");

	my $gpg = GnuPG::Interface->new();
	$gpg->call( $CONFIG{'gpg'} );
	$gpg->options->hash_init(
		'homedir' => $GNUPGHOME,
		'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always }, '--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
	my %local_keyids = map { $_ => 1 } @KEYIDS;
	my $had_v3_keys = 0;
	for my $line (split /\n/, $status) {
		if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
			my $imported_key = $1;
			my $whole_fpr = $imported_key;
			my $long_keyid = substr($imported_key, -16);
			my $short_keyid = substr($imported_key, -8);
			my $speced_key;
			for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
				$speced_key = $spec if $local_keyids{$spec};
			};
			unless ($speced_key) {
			    notice ("Imported unexpected key; got: $imported_key\nAre you trying to work on a subkey?");
			    next;
			};
			debug ("Imported $imported_key for $speced_key");
			delete $local_keyids{$speced_key};
			unshift @keyids_ok, $imported_key;
		} elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
		} elsif ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/) {
			my $imported_key = $1;
			notice ("Imported key $1 is a version 3 key.  Version 3 keys are obsolete, should not be used, and are not and will not be properly supported.");
			$had_v3_keys = 1;
		} else {
			notice ("got unknown reply from gpg: $line");
		}
	};
	if (scalar %local_keyids) {
		notice ("Import failed for: ". (join ' ', keys %local_keyids)."." . ($had_v3_keys ? " (Or maybe it's one of those ugly v3 keys?)" :  ""));
		exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
		if (scalar keys %local_keyids == 1) {
			mywarn("Assuming ". (join ' ', keys %local_keyids)." is a fine keyid.");
		} else {
			mywarn("Assuming ". (join ' ', keys %local_keyids)." are fine keyids.");
		};
		push @keyids_ok, keys %local_keyids;
	}
};

unless (@keyids_ok) {
	notice ("No keys to sign found");
	exit 0;
}

###########
# sign keys
###########
if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
	$CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
}
	
unless ($CONFIG{'no-sign'}) {
	my @local_user = get_local_user_keys();

	info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
	for my $keyid (@keyids_ok) {
		foreach my $local_user (@local_user) {
			my @command;
			push @command, $CONFIG{'gpg-sign'};
			push @command, '--local-user', $local_user if (defined $local_user);
			push @command, "--homedir=$GNUPGHOME";
			push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
			push @command, '--no-auto-check-trustdb';
			push @command, '--trust-model=always';
			push @command, '--edit', $keyid;
			push @command, 'sign';
			push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
			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,
		'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
	$gpg->options->meta_interactive( 0 );
	my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
	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' => [ qw{ --no-auto-check-trustdb --trust-model=always --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, $params->{'export-old'}, $params->{'no-export-old'});
				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{'mail'} eq 'no'); # 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/;
				my $mail = create_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
				if (defined $mail) {
					my $should_send_mail = ask("Mail signature for $uid->{'text'} to '$address'?", $CONFIG{'mail'} ne 'ask-no', $CONFIG{'mail'} eq 'yes');
					send_message($mail) if $should_send_mail;

					my $keydir = "$KEYSBASE/$DATE_STRING";
					my $mailfile = "$keydir/$longkeyid.mail.".($should_send_mail ? '' : 'unsent.').$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
					open (MAILFILE, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
					print MAILFILE $mail->stringify();
					close MAILFILE;
				} else {
					warn "Generating mail failed.\n";
				};
			};
		};
	};

};

###########################
# the default mail template
###########################

__DATA__
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.

If you have multiple user ids, I sent the signature for each user id
separately to that user id's associated email address. You can import
the signatures by running each through `gpg --import`.

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 pool.sks-keyservers.net --send-key {$key}

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

Regards,
{$owner}