xref: /dports/security/signing-party/signing-party-8f6c9d59d8edbb08dade7bac06417fce07626f7f/caff/caff

#!/usr/local/bin/perl

# caff  --  CA - Fire and Forget
#
# Copyright (c) 2004, 2005, 2006 Peter Palfrader <peter@palfrader.org>
# Copyright (c) 2005, 2006 Christoph Berg <cb@df7cb.de>
# Copyright (c) 2014-2016 Guilhem Moulin <guilhem@debian.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> [-eERS] [-m I<yes|ask-yes|ask-no|no>] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]

=item B<caff> [-eERS] [-m I<yes|ask-yes|ask-no|no>] [-u I<yourkeyid>] [I<keyid> ..] <I</path/to/ksp-annotated.txt>

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

The list of keys to sign can also be provided through caff's standard
input, as gpgparticipants(1) formatted content.  Only keys for which
both the "Fingerprint OK" and "ID OK" boxes are ticked (i.e., marked
with an "x") are considered for signing.  Furthermore, the input header
must include at least one checksum line, and all checksum boxes must be
marked as verified (with an "x").

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

=item B<--debug>

Enable debug messages.

=back

=head1 ENVIRONMENT

=over

=item I<HOME>

The default home directory.

=item I<GNUPGBIN>

The gpg binary.  Default: C<"gpg">.

=item I<GNUPGHOME>

The default working directory for gpg.  Default: C<$HOME/.gnupg>.

=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 directory for gpg

=item $HOME/.caff/gnupghome/gpg.conf  -  gpg configuration (see B<NOTES> below)

useful options include use-agent, keyserver, 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/>.

=item B<colors> [hash]

How to color output messages.  See the C<Term::ANSIColor> documentation
for the list of supported colors; colored output can be disabled by
setting this option to an empty hash B<{}>.  Default:

	{ error => 'bold bright_red'
	, warn => 'bright_red'
	, notice => 'bold'
	, info => ''
	, success => 'green' # used in combination with 'notice' and 'info'
	, fail => 'yellow'   # used in combination with 'notice' and 'info'
	}

=back

=head2 GnuPG settings

=over

=item B<gpg> [string]

Path to the GnuPG binary.  Default: The value of the I<GNUPGBIN>
environment variable if set, otherwise C<gpg>.

=item B<secret-keyring> [string]

Path to your secret keyring (GnuPG < 2.1), or to the GnuPGHOME
of the agent managing the secret key material (GnuPG >= 2.1).
Default: B<$HOME/.gnupg/secring.gpg>.
If the value is not a directory with GnuPG >= 2.1, the parent directory
(i.e., B<$HOME/.gnupg> by default) is considered instead.

=item B<also-encrypt-to> [keyid, or list of keyids]

Additional keyids to encrypt messages to. Default: none.

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

The prefix to the "sign" command used to make the signature from gpg's
shell.  Can be set to a mix of "l" (local), "nr" (non-revocable) or "t"
(trust) to make a signature of the given type.  See gpg(1) for
details.  Default: "" (i.e., make a regular, exportable, signature).

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

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

=back

=head2 Key import settings

=over

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

=item B<also-lsign-in-gnupghome> [auto|ask|no]

Whether to locally sign the UIDs in the user's GnuPGHOME, in addition to
caff's signatures in its own GnuPGHOME.  Such signatures are not
exportable.  This can be useful when the recipient forgets to upload the
signatures caff sent (or if they are non-exportable as well), as it
gives a way to keep track of which UIDs were verified.  However, note
that local signatures will not be deleted once the recipient does the
upload and the signer refreshes her keyring.

If the value is not I<no> and if B<gpg-sign-type> contains "l", each
(local) signature is merely exported from caff's own GnuPGHOME to the
user's.  Otherwise, if the value is I<auto>, each UID signed in caff's
own GnuPGHOME gets automatically locally signed in the user's, using the
same certification level; this requires a working gpg-agent(1).  If
I<ask>, the user is prompted for which UIDs to locally sign.  Default:
B<no>.

=item B<show-photos> [boolean]

If true, then before signing a key gpg will display the photos attached
to it, if any.  (The photo viewer can be specified with a "photo-viewer"
option in caff's GnuPGHOME.)  Default: B<0>.

=back

=head2 Mail settings

=over

=item B<mail> [yes|ask-yes|ask-no|no]

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-cant-encrypt> [yes|ask-yes|ask-no|no]

The value of this option is considered instead of that of B<mail> for
recipient keys without encryption capability.  Default to the value of
B<mail>.

=item B<mail-subject> [string]

Sets the value of the "Subject:" header field.  C<%k> will be expanded
to the long key ID of the signed key.
Default: C<Your signed PGP key 0x%k>.

=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

Note that you should probably customize the template if you intend to
send non-exportable signatures (i.e., if B<gpg-sign-type> contains "l"),
as uploading such signatures doesn't make sense, and they require the
import option "import-local-sigs" which isn't set by default.

=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.  Default: none.
Setting this option is strongly discouraged: fix your local MTA instead.

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', '-f', $CONFIG{'email'}, '-it' ];

to pass arguments to the sendmail program.  To specify a sendmail binary
you can set the C<< PERL_MAILERS >> environment variable as follows:

    $ENV{'PERL_MAILERS'} = 'sendmail:/path/to/sendmail_compatible_mta';

For more information see Mail::Mailer(3pm).

=back

=head1 NOTES

As noted above caff uses its own GnuPGHOME and GnuPG configuration file.
In fact it only needs its own keyring for the signing work, but it would
be unsafe to reuse the same GnuPG configuration file because the user
could have set an option in $HOME/.gnupg/gpg.conf which would break caff.

Therefore the GnuPG options that are intended to be used with caff, such
as C<keyserver> or C<cert-digest-algo>, need to be placed in
$HOME/.caff/gnupghome/gpg.conf instead.  If this file does not exist,
the GnuPG options found in $HOME/.gnupg/gpg.conf that are known to be
safe (and useful) for caff, are passed to gpg(1) as command-line
options.

=head1 AUTHORS

=over

=item Peter Palfrader <peter@palfrader.org>

=item Christoph Berg <cb@df7cb.de>

=item Guilhem Moulin <guilhem@debian.org>

=back

=head1 SEE ALSO

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

=cut

use strict;
use warnings;
use IO::Handle;
use File::Copy qw{copy};
use File::Temp;
use Text::Template;
use MIME::Entity;
use Encode ();
use I18N::Langinfo qw{langinfo};
use Net::IDN::Encode qw{email_to_ascii domain_to_ascii};
use Fcntl;
use IO::Select;
use Getopt::Long;
use GnuPG::Interface;
use POSIX qw{strftime setlocale};
use Term::ANSIColor qw{colored};

my %CONFIG;
my $VERSION = '@@VERSION@@';
my $LOCALE = Encode::find_encoding(langinfo(I18N::Langinfo::CODESET()));
my $USER_AGENT = "caff $VERSION";

# Global variables
my @KEYIDS;
my @LOCAL_USER;
my $PARAMS;

my $KEYSBASE;
my $GNUPGHOME;


##
# 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 mycolored($@) {
    my $msg = shift;
    my $color = join (' ', grep defined, map { defined $_ ? $CONFIG{colors}->{$_} : undef } @_) if defined $CONFIG{colors};
    $msg = colored($msg, $color) if defined $color and $color !~ /^\s*$/;
    return $msg;
}
sub myerror($$) {
    my ($exitcode, $line) = @_;
    print STDERR mycolored("[ERROR] $line", 'error'), "\n";
    exit $exitcode;
}

sub mywarn($) {
    my ($line) = @_;
    print STDERR mycolored("[WARN] $line", 'warn'), "\n";
}
sub notice($;$) {
    my ($line,$color) = @_;
    $color = $color ? 'success' : 'fail' if defined $color;
    print STDERR mycolored("[NOTICE] $line", 'notice', $color), "\n";
}
sub info($;$) {
    my ($line,$color) = @_;
    $color = $color ? 'success' : 'fail' if defined $color;
    print STDERR mycolored("[INFO] $line", 'info', $color), "\n";
}
sub debug($) {
    my ($line) = @_;
    print STDERR "[DEBUG] $line\n" if $PARAMS->{debug};
}
sub trace($) {
    my ($line) = @_;
    #print STDERR "[trace] $line\n";
}
sub trace2($) {
    my ($line) = @_;
    #print STDERR "[trace2] $line\n";
}

sub mysystem(@) {
    system { $_[0] } @_;
    myerror($?, "$_[0] exited with value ".($? >> 8)) if $?;
}


# Return -1 if the GnuPG version is < $_[0], 0 if == $_[0], 1 if > $_[0].
my $GNUPG_VERSION;
sub GnuPG_version($) {
    unless (defined $GNUPG_VERSION) { # cache the version
        $GNUPG_VERSION = `$CONFIG{gpg} --no-options --with-colons --list-config version` or exit 1;
        chomp $GNUPG_VERSION;
        $GNUPG_VERSION =~ s/^cfg:version:// or die;
        debug "gpg (GnuPG) $GNUPG_VERSION";
    }
    my @v1 = split /\./, $GNUPG_VERSION;
    my @v2 = split /\./, shift;
    while (@v1 or @v2) {
        my $v1 = shift @v1 // 0;
        my $v2 = shift @v2 // 0;
        my $r = $v1 <=> $v2;
        return $r unless $r == 0;
    }
    return 0;
}

sub gpgconf(@) {
    my $pid = open my $fh, '-|', 'gpgconf', @_;
    my %conf;
    while (<$fh>) {
        my ($k, $v) = split /:/, $_;
        chomp ($conf{$k} = $v);
        $conf{$k} =~ s/%(\p{AHex}{2})/ chr(hex($1)) /ge; # unescape the %-encoded chars
    }
    waitpid $pid, 0;
    myerror($?, "gpgconf exited with value ".($? >> 8)) if $? > 0;
    close $fh;
    return \%conf;
}

# See RFC 5322 section 3.4.1; only the pattern for the local part, which
# doesn't go beyond the ASCII range, is validated.  The domain part is
# NOT checked against RFC 5322, as it must be encoded to ASCII first;
# for now any string in the full-range unicode that does not contain
# U+0040 (commercial at), U+FE6B (small commercial at) and U+FF20
# (fullwidth commercial at) is accepted.
my $RE_word = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+ # atom: any ASCII CHAR except specials, SPACE and CTLs
                 |\x22(?:[\x00-\x21\x23-\x5B\x5D-\x7E]|\x5C\p{ASCII})*\x22       # quoted string
                /x;
my $RE_address_spec = qr/(?<l>$RE_word(?:\.$RE_word)*)[\@\N{U+FE6B}\N{U+FF20}](?<d>[^\@\N{U+FE6B}\N{U+FF20}]+)/o;

# A domain label is a non-empty ASCII string of length at most 63
# characters (RFC 1035 2.3.4).  Valid characters are alphanumeric and
# hyphen '-', but an hyphen may not appear at the start or end of a
# label (RFC 952, RFC 1123 2.1).
my $RE_label = qr/[0-9a-z](?:[0-9a-z\x2D]{0,61}[0-9a-z])?/aai;

# Take a 'mailbox' (RFC 5322 section 3.4) and return its ASCII-encoded
# 'addr-spec'; or undef if it violates one of RFC 5322/5892/1035/5321.
# We're not using Email::Valid because it's not unicode-friendly.
# NOTE: This subroutine should only be used to extract e-mail addresses
# from UIDs.  The phrase is NOT checked against RFC 5322 (any string
# containing only characters in the full-unicode printable range are
# accepted), but we don't care as long as it's not used in email
# headers.
sub email_valid($) {
    local $_ = shift // return;
    return unless /\A$RE_address_spec\z/ao or                         # addr-spec
                  /\A(?:\p{Print}*\p{Space})?<$RE_address_spec>\z/ao; # [phrase] "<" addr-spec ">"
    my ($l,$d) = @+{qw/l d/};
    if ($d =~ /\P{ASCII}/) {
        # encode the IDN to ASCII using Punycode for RFC 5321 validation
        eval { $d = domain_to_ascii($d) };
        return if $@; # violates RFC 5892
    }
    my $address = "$l\@$d";
    return unless
        length $d > 0 and length $d <= 255 # violates RFC 1035 2.3.4 "size limits"
        and length $l <= 64                # violates RFC 5321 4.5.3.1.1
        and length $address <= 254         # violates RFC 5321 4.5.3.1.3
        and $d =~ /\A$RE_label(?:\.$RE_label)+\z/o; # ignore non-FQDN
    return $address;
}

open NULL, '+<', '/dev/null';
my $NULL = fileno NULL;
sub generate_config() {
    notice("Error: \$LOGNAME is not set", 0) 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/,.*//;

        $CONFIG{'gpg'} = $ENV{GNUPGBIN} // 'gpg';
        my $gpg = mkGnuPG( extra_args => ['--with-colons'] );
        my $handles = mkGnuPG_fds ( stdout => undef );
        my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $gecos ]);
        my %output = readwrite_gpg($handles);
        waitpid $pid, 0;
        $handles->{stdout}->close;

        if ($output{stdout} eq '') {
            mywarn "No data from $CONFIG{gpg} for list-key"; # There should be at least 'tru:' everywhere.
        };

        @keys = ($output{stdout} =~ /^pub:[^eir:]*:(?:[^:]*:){2}([0-9A-F]{16}):/mg);
        unless (scalar @keys) {
            notice("Error: No keys were found using \"$CONFIG{gpg} --list-public-keys '$gecos'\"", 0);
            @keys = qw{0123456789ABCDEF 89ABCDEF76543210};
            $Ckeys = '#';
        }
        my @emails = ($output{stdout} =~ /^uid:[^eir:]*:(?:[^:]*:){7}([^:]+)(?::.*)?$/mg);
        if (@emails) {
            s/\\x(\p{AHex}{2})/ chr(hex($1)) /ge foreach @emails;
            @emails = grep defined, map {email_valid(Encode::decode_utf8($_))} @emails;
            $email = shift @emails; # take the first valid address
        }
        unless (defined $email) {
            notice("Error: No email address was found using \"$CONFIG{gpg} --list-public-keys '$gecos'\"", 0);
            $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
#   $CONFIG{gpg} --keyid-format long --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;
}

my @GNUPGOPTS;
sub load_config() {
    my $config = $ENV{'HOME'} . '/.caffrc';
    unless (-f $config) {
        notice "No configfile $config present, I will use this template:";
        my $template = generate_config();
        print $template, "\n";
        notice "Please edit $config and run caff again.";
        open F, '>', $config or myerror(1, "$config: $!");
        print F $template;
        close F;
        exit(1);
    }
    unless (scalar eval `cat $config`) {
        myerror(1, "Couldn't parse $config: $@") if $@;
    };

    myerror(1, "$0: $_ is not defined in $config") for grep {!defined $CONFIG{$_}} qw/owner email keyid/;
    myerror(1, "$0: keyid is not an array ref in $config") unless ref $CONFIG{'keyid'} eq 'ARRAY';
    myerror(1, "$0: key $_ is not specified as a long (16 digit) keyid or fingerprint in $config") for
        grep !/^((?:0x)?\p{AHex}{16}|\p{AHex}{40}|(?:\p{AHex}{4} ){5}(?: \p{AHex}{4}){5})$/, @{$CONFIG{'keyid'}};

    $CONFIG{'caffhome'} //= $ENV{'HOME'}.'/.caff';
    $KEYSBASE  = $CONFIG{'caffhome'}.'/keys';
    $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
    foreach ($CONFIG{'caffhome'}, $KEYSBASE, $GNUPGHOME) {
        next if -d $_;
        debug("Creating $_");
        mkdir $_, 0700 or myerror(1, "Cannot mkdir $_: $!");
    }

    @{$CONFIG{'keyid'}} = map { s/^0x//; uc (substr y/ //dr, -16) } @{$CONFIG{'keyid'}}; # must be a list of long keyids
    $CONFIG{'export-sig-age'} //= 24*60*60;
    $CONFIG{'gpg'} //= $ENV{GNUPGBIN} // 'gpg';

    $CONFIG{'secret-keyring'} //= ($ENV{'GNUPGHOME'} // "$ENV{'HOME'}/.gnupg") . '/secring.gpg';
    $CONFIG{'no-download'} //= 0;
    $CONFIG{'no-sign'} //= 0;
    $CONFIG{'key-files'} //= [];
    $CONFIG{'mailer-send'} //= [];
    myerror(1, "$0: mailer-send is not an array ref in $config") unless ref $CONFIG{'mailer-send'} eq 'ARRAY';
    $CONFIG{'mail-subject'} //= "Your signed PGP key 0x%k";
    $CONFIG{'mail-template'} //= do { local $/; <DATA> };
    $CONFIG{'also-encrypt-to'} = [ $CONFIG{'also-encrypt-to'} ]
        if defined $CONFIG{'also-encrypt-to'} and !ref $CONFIG{'also-encrypt-to'};
    if (defined $LOCALE) {
        $CONFIG{$_} = $LOCALE->decode($CONFIG{$_}) for qw/owner mail-template mail-subject/;
        $CONFIG{$_} = email_to_ascii($LOCALE->decode($CONFIG{$_}))
            for grep {defined $CONFIG{$_}} qw/email bcc reply-to/;
    }
    $CONFIG{'gpg-sign-type'} //= '';
    myerror(1, "$0: $CONFIG{'gpg-sign-type'} is an invalid signature type")
        unless $CONFIG{'gpg-sign-type'} =~ /^(?:l|nr|t)*$/;
    $CONFIG{'also-lsign-in-gnupghome'} //= 'no';
    $CONFIG{'also-lsign-in-gnupghome'} = 'no' if $CONFIG{'no-sign'};
    myerror(1, "$0: invalid value for 'also-lsign-in-gnupghome': $CONFIG{'also-lsign-in-gnupghome'}")
        unless grep { $_ eq $CONFIG{'also-lsign-in-gnupghome'} } qw/auto ask no/;
    $CONFIG{'show-photos'} //= 0;

    $CONFIG{colors} //= {
        error => 'bold bright_red',
        warn => 'bright_red',
        notice => 'bold',
        info => '',
        success => 'green',
        fail => 'yellow'
    };

    # Import some options from ~/.gnupghome/gpg.conf.  We don't symlink
    # the whole file because the user could have set an option in
    # ~/.gnupg/gpg.conf which would break caff.
    my $gpgconf = ($ENV{'GNUPGHOME'} // "$ENV{'HOME'}/.gnupg") . '/gpg.conf';
    if ( ! -f "$GNUPGHOME/gpg.conf" and -f $gpgconf and open my $fh, '<', $gpgconf) {
        # the list of options to import from ~/.gnupg/gpg.conf; only
        # safe (and useful) options for caff should be listed here
        my @gnupgopts_n = qw/
            disable-ccid
            ask-cert-level no-ask-cert-level
            use-agent no-use-agent
            no-random-seed-file
            no-greeting
            expert no-expert
            gnupg no-pgp2 pgp6 no-pgp6 pgp7 no-pgp7 pgp8 no-pgp8
            rfc2440 rfc4880 openpgp
            default-comment no-comments
            emit-version no-emit-version no-version
            allow-weak-digest-algos
            ask-cert-expire no-ask-cert-expire
            utf8-strings no-utf8-strings
            only-sign-text-ids
        /;
        my @gnupgopts_i = qw/
            default-cert-level
            limit-card-insert-tries
        /;
        my @gnupgopts_s = qw/
            photo-viewer
            exec-path
            pcsc-driver
            reader-port
            display-charset charset
            keyserver keyserver-options
            gpg-agent-info
            personal-cipher-preferences personal-digest-preferences
            comment
            cert-notation set-notation
            cert-policy-url set-policy-url
            cipher-algo cert-digest-algo
            pinentry-mode
            weak-digest
            default-cert-expire
            disable-cipher-algo disable-pubkey-algo
            agent-program dirmngr-program
        /;

        push @GNUPGOPTS, '--no-options';
        notice('Importing GnuPG options from '.($ENV{'GNUPGHOME'} // '~/.gnupg').'/gpg.conf:');
        while (<$fh>) {
            s/(?:\r\n|\r|\n)\z// or next;
            if (/\A\s*([0-9a-zA-Z\-]+)\z/ and grep { $_ eq $1 } @gnupgopts_n) {
                push @GNUPGOPTS, "--$1";
            } elsif (/\A\s*([0-9a-zA-Z\-]+)\s+(\d+)\z/ and grep { $_ eq $1 } @gnupgopts_i) {
                push @GNUPGOPTS, "--$1=$2";
            } elsif (/\A\s*([0-9a-zA-Z\-]+)\s+(\P{Control}+)\z/ and grep { $_ eq $1 } @gnupgopts_s) {
                push @GNUPGOPTS, "--$1=$2";
            } else {
                next;
            }
            notice("    $_");
        }
        close $fh;
    }

    # deprecated options, will be removed in a future release
    mywarn("Deprecated option \$CONFIG{'$_'} = '$CONFIG{$_}'") foreach
        grep {defined $CONFIG{$_}} qw{gpg-sign gpg-delsig keyserver};
}

# Create a new GnuPG::Interface object with common options
sub mkGnuPG(%) {
    my %h = @_;
    my $gpg = GnuPG::Interface::->new();
    $gpg->call( $CONFIG{'gpg'} );

    $h{meta_interactive} //= 0;
    $h{always_trust} //= 1;
    $h{extra_args} //= [];

    unshift @{$h{extra_args}}, '--no-auto-check-trustdb';
    unshift @{$h{extra_args}}, '--fixed-list-mode' if GnuPG_version('2.0.0') <  0;
    unshift @{$h{extra_args}}, '--no-autostart'    if GnuPG_version('2.1.0') >= 0; # never autostart
    unshift @{$h{extra_args}}, @GNUPGOPTS if @GNUPGOPTS and defined $h{homedir};

    $gpg->options->hash_init(%h);
    debug(join (' ', $gpg->call(), $gpg->options->get_args(), "..."));
    return $gpg;
}


# Create a GnuPG::Handles object.  This function takes a hash where keys
# are handle names, and values are either IO::Handle objects, in which
# case the existing handle is used, or undefined, in which case a new
# IO::Handle is created.
sub mkGnuPG_fds(%) {
    my %fd = @_;
    my @direct;

    foreach (keys %fd) {
        push @direct, $_ if defined $fd{$_} and $fd{$_} !~ /^[<>]&/;
        $fd{$_} //= IO::Handle::->new();
    }

    # Redirect the STDIN and STDOUT to /dev/null unless explicitly
    # redirected.  Also redirect logger to /dev/null in non-debug mode,
    # but NEVER redirect STDERR!
    $fd{stdin}  = "<&=$NULL" unless exists $fd{stdin};
    $fd{stdout} = ">&=$NULL" unless exists $fd{stdout};
    $fd{logger} = ">&=$NULL" unless exists $fd{logger} or $PARAMS->{debug};

    my $handles = GnuPG::Handles::->new(%fd);
    $handles->options($_)->{direct} = 1 foreach @direct;
    debug(join (', ', map {"$_: " . ($handles->options($_)->{direct} ? $fd{$_}->fileno : $fd{$_})} keys %fd));

    return $handles;
}

sub done_gpg($;$) {
    my ($pid, $handles) = @_;
    waitpid $pid, 0;
    mywarn("$CONFIG{gpg} exited with value ".($? >> 8)) if $? > 0;
    return unless defined $handles;
    foreach (GnuPG::Handles::HANDLES) {
        next unless defined $handles->{$_} and $handles->{$_} !~ /^[<>]&/;
        $handles->{$_}->close if $handles->{$_}->opened;
    }
}


# Send some data on GnuPG handles, and retrieve output from all handles
# at once using select(2) syscalls.  Stop when some output matches a
# given regex, or when there nothing more to read or write.  A newline
# '\n' character is automatically appended to the text to be send to the
# 'command' handle; the prefix "[GNUPG:] " to the 'status' handle is
# added as well.
sub readwrite_gpg($%) {
    my $handles = shift;
    my %opts = @_;

    # ignore direct and dup handles
    my @infhs  = grep {defined $opts{$_}      and !$handles->options($_)->{direct} and $handles->{$_} !~ /^[<>]&/} qw/stdin passphrase command/;
    my @outfhs = grep {defined $handles->{$_} and !$handles->options($_)->{direct} and $handles->{$_} !~ /^[<>]&/} qw/stdout stderr status logger/;
    my %fh = map { $handles->{$_} => $_ } (@infhs, @outfhs);

    my %offset = map {$_ => 0}  @infhs;
    my %output = map {$_ => ''} @outfhs;

    if (defined $opts{command}) {
        # automatically send the command
        chomp $opts{command};
        $opts{command} .= "\n";
    }
    $opts{status} = qr/^\[GNUPG:\] $opts{status}$/m if defined $opts{status};

    $handles->{$_}->blocking(0) foreach (@infhs, @outfhs);
    my $sin  = IO::Select::->new(map {$handles->{$_}} @infhs);
    my $sout = IO::Select::->new(map {$handles->{$_}} @outfhs);

    trace("entering readwrite_gpg.");
    trace("doing stuff until one of: ". join(', ', map {"$_ =~ $opts{$_}"} grep {defined $opts{$_}} @outfhs))
        if grep {defined $opts{$_}} @outfhs;

    my $readwrote_stuff_this_time = 0;
    my $do_not_wait_on_select = 0;
    while ($sin->count() + $sout->count() > 0) {
        if (!$sin->count() and grep {defined $opts{$_} and $output{$_} =~ $opts{$_}} @outfhs) {
            if ($readwrote_stuff_this_time) {
                trace("read/write some more.");
                $do_not_wait_on_select = 1;
            } else {
                trace("that's it in our while loop.");
                last;
            }
        };

        trace("select waiting for ".($sin->count()+$sout->count())." fds.");
        my ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
        trace("ready: write: ". join (',', map {$fh{$_}} @{$readyw // []}).
                    "; read: ". join (',', map {$fh{$_}} @{$readyr // []}));
        $readwrote_stuff_this_time = 0;

        for my $fd (@{$readyw // []}) {
            $readwrote_stuff_this_time = 1;
            my $fh = $fh{$fd};
            if ($offset{$fh} != length $opts{$fh}) {
                trace ("writing to '$fh'". ($offset{$fh} ? "" : ": ".(split /\n/, $opts{$fh}, 2)[0]));
                my $written = $fd->syswrite($opts{$fh}, length($opts{$fh}) - $offset{$fh}, $offset{$fh});
                $offset{$fh} += $written;
            }
            if ($offset{$fh} == length $opts{$fh}) {
                trace "done writing to '$fh'.";
                $sin->remove($fd);
                $fd->close && trace "closed '$fh'." if $opts{autoclose};
            }
        }
        for my $fd (@{$readyr // []}) {
            $readwrote_stuff_this_time = 1;
            my $fh = $fh{$fd};
            if ($fd->eof) {
                trace "done reading from '$fh'.";
                $sout->remove($fd);
                next;
            }
            trace "reading from '$fh'.";
            $output{$fh} .= do { local $/; <$fd> };
            trace2 "$fh is now:\n$output{$fh}\n================";
        }
    }
    trace("readwrite_gpg done.");
    return %output;
}


sub ask($$;$$) {
    my ($question, $default, $forceyes, $forceno) = @_;

    my $fd = fileno(TTY) // die;
    my $termios = POSIX::Termios::->new();
    $termios->getattr($fd) // die "getattr: $!";
    my $echo = POSIX::ECHO | POSIX::ECHOK | POSIX::ICANON;
    my $c_iflag = $termios->getiflag();
    my $c_lflag = $termios->getlflag();
    unless ($c_iflag & POSIX::ICRNL and ($c_lflag & $echo) == $echo) {
        debug("Sanitizing TTY");
        $termios->setiflag( $c_iflag | POSIX::ICRNL );
        $termios->setlflag( $c_lflag | $echo );
        $termios->setattr($fd, POSIX::TCSANOW) // warn "setattr: $!";
    }

    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 = <TTY>;
        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 = qr/GET_LINE keyedit\.prompt/;
my $KEYEDIT_DELUID_PROMPT = qr/GET_BOOL keyedit\.remove\.uid\.okay/;
my $KEYEDIT_DELSIG_PROMPT = qr/GET_BOOL keyedit\.delsig\.(?:unknown|invalid|valid)/; # we won't delete selfsigs
my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = qr/$KEYEDIT_PROMPT|$KEYEDIT_DELSIG_PROMPT/;
my $KEYEDIT_DELSUBKEY_PROMPT = qr/GET_BOOL keyedit\.remove\.subkey\.okay/;
my $KEYEDIT_SIGNUID_CLASS_PROMPT = qr/GET_LINE sign_uid\.class/;
my $KEYEDIT_SIGNUID_PROMPT = qr/GET_BOOL sign_uid\.okay/;


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

sub usage($$) {
    my ($fd, $exitcode) = @_;
    version($fd);
    print $fd "Usage: $0 [-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 keys @$keyids from $gnupghome.  In list context, fork and
# return the pid and the file descriptor of its standard output;
# otherwise, wait until the export is done and return the ASCII key.
#
# /!\ Failure to export a key will not be detected, unless *all* keys
#       couldn't be exported.  Therefore for safe export/import, you need
#       to inspect '$asciikey' or the status FD on the import side.
######
sub export_keys($$@) {
    my ($gnupghome, $keyids, @export_options) = @_;
    myerror(1, "Nothing to export") unless defined $keyids and @$keyids;
    my @extra_args = ('--export-options', join (',', @export_options)) if @export_options;

    # don't armor when piping since it's faster
    my $gpg = mkGnuPG( homedir => $gnupghome, armor => (wantarray ? 0 : 1), extra_args => \@extra_args );
    my $handles = mkGnuPG_fds( stdout => undef );
    my $pid = $gpg->export_keys( handles => $handles, command_args => $keyids );

    if (wantarray) {
        return ($pid, $handles->{stdout});
    } else {
        my $asciikey = do { local $/; readline $handles->{stdout} };
        done_gpg($pid, $handles);
        return $asciikey;
    }
}


######
# 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'});
    myerror(1, "Cannot create template: $Text::Template::ERROR") unless defined $template;

    my $message = $template->fill_in(HASH => { key => $key_id,
                           uids => [ map {$_->{'text'}} @keys ],
                           owner => $CONFIG{'owner'}});
    myerror(1, "Cannot fill in template: $Text::Template::ERROR") unless defined $message;

    my $message_entity = MIME::Entity->build(
        Type        => "text/plain",
        Charset     => "utf-8",
        Disposition => 'inline',
        Data        => Encode::encode_utf8($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 ".Encode::encode_utf8($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 $gpg = mkGnuPG( homedir => $GNUPGHOME, armor => 1, textmode => 1 );
        $gpg->options->push_recipients($key_id);
        $gpg->options->push_recipients(@{$CONFIG{'also-encrypt-to'}}) if defined $CONFIG{'also-encrypt-to'};
        my $handles = mkGnuPG_fds( stdin => undef, stdout => undef, status => undef );
        my $pid = $gpg->encrypt(handles => $handles);
        my %output = readwrite_gpg($handles, stdin => $message_entity->stringify(), autoclose => 1);
        done_gpg($pid, $handles);
        my ($message, $status) = @output{qw/stdout status/};

        if ($message 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'}}) {
                    mywarn "Could not encrypt to $keyid, specified in CONFIG{'also-encrypt-to'}";
                    mywarn "Try to update the key using gpg --homedir=$GNUPGHOME --import <exported key>";
                    return;
                };
            };
            mywarn "No data from gpg for encrypting mail; status output was:\n$status";
            return;
        };

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

    my $from = Encode::encode('MIME-Q', $CONFIG{owner})." <$CONFIG{email}>";
    $message_entity->head->add("From", $from);
    $message_entity->head->add("Date", strfCtime("%a, %e %b %Y %H:%M:%S %z", localtime));
    $message_entity->head->add("Subject", Encode::encode('MIME-Q', $CONFIG{'mail-subject'} =~ s/%k/$key_id/gr));
    $message_entity->head->add("To", $address);
    $message_entity->head->add("Sender", $from);
    $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 existent, 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;
}

# Delete all non self-sigs that are not made by one of the @$keyids, and
# return the date of the most recent signature and a hash reference
# {$signer => $level} of the keys in @$keyids that have an exportable
# signature on that $uid.  If $keep_lsigs_only, our exportable
# signatures are removed as well.
sub delete_signatures($$$$;$) {
    my ($handles, $longkeyid, $uid, $keyids, $keep_lsigs_only) = @_;

    readwrite_gpg($handles, command => "uid 0",    status => $KEYEDIT_PROMPT); # unmark all uids from delsig
    readwrite_gpg($handles, command => "uid $uid", status => $KEYEDIT_PROMPT); # mark $uid for delsig

    my $last_signed_on = 0;
    my %xsigners;

    my %output = readwrite_gpg($handles, command => "delsig", status => $KEYEDIT_DELSIG_PROMPT);

    while($output{status} =~ /$KEYEDIT_DELSIG_PROMPT/m) {
        # sig:?::17:EA2199412477CAF8:1058095214:::::13x
        my @sigline = grep /^sig:/, (split /\n/, $output{stdout});
        my $answer = "no";
        if (!@sigline) {
            debug("[sigremoval] no sig line here, only got:\n".$output{stdout});
        }
        else { # only if we found a sig here - we never remove revocation packets for instance
            my $sig = pop @sigline;
            $sig =~ /^sig:(?:[^:]*:){3}([0-9A-F]{16}):(\d+):(?:[^:]*:){4}(1[0-3]|30)([lx])(?::.*)?$/ or
                mywarn("I hit a bug, please report: Couldn't parse sigline $sig");
            debug("[sigremoval] doing sigline $sig");
            if ($1 eq $longkeyid) {
                debug("[sigremoval] selfsig ($1)");
                $answer = "no";
            } elsif (grep { $1 eq $_ } @$keyids and $3 != 30) {
                debug("[sigremoval] signed by us ($1)");
                $answer = ($keep_lsigs_only and $4 eq 'x') ? "yes" : "no";
                $last_signed_on = $2 if $last_signed_on < $2;
                $xsigners{$1} = $3-10 if $4 eq 'x';
            } else {
                debug("[sigremoval] not interested in that sig ($1)");
                $answer = "yes";
            };
            mywarn("I hit a bug, please report: Found the following ".($#sigline+2)." siglines in that part of the dialog:\n".$output{stdout}) if @sigline;
        }
        %output = readwrite_gpg($handles, command => $answer, status => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT);
    }

    return ($last_signed_on, \%xsigners);
}

##
# 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() {
    # No user-defined key id has been specified by the user, no need for
    # further checks
    return @{$CONFIG{'keyid'}} unless $CONFIG{'local-user'};

    # Parse the list of keys
    my @key_list = ref $CONFIG{'local-user'} ?  @{$CONFIG{'local-user'}} : split /\s*,\s*/, $CONFIG{'local-user'};
    my @local_user;

    # Check every key defined by the user...
    for my $user_key (@key_list) {
        unless ($user_key =~ m/^((?:0x)?\p{AHex}{8}|(?:0x)?\p{AHex}{16}|\p{AHex}{40}|(?:\p{AHex}{4} ){5}(?: \p{AHex}{4}){5})$/) {
            mywarn "Local-user $user_key is not a valid keyid";
            next;
        }

        $user_key =~ s/^0x//;
        $user_key =~ y/ //d;
        if (my @matching_keyids = grep {$user_key =~ /\Q$_\E$/i or /\Q$user_key\E$/i} @{$CONFIG{'keyid'}}) {
            push @local_user, @matching_keyids; # @{$CONFIG{'keyid'}} is always a list of long keyids
        } else {
            mywarn "Local-user $user_key is not defined as one of your keyid in ~/.caffrc (it will not be used)";
        }
    }

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

##
# Import keys from a gnupghome to another.
#
# @param keyids         keyids of the OpenPGP keys to import
# @param src_gnupghome  gnupghome directory where to export the key from
# @param dst_gnupghome  gnupghome directory where to import the key into
# @param die_on_error   whether to die if some of the keyids couldn't be imported
# @param import_options a list of import-options, see gpg(1)
#
# @ return a hash reference mapping each key ID to the list of matching
#   imported key fingerprint.
#
sub import_keys_from_gnupghome($$$$@) {
    my ($keyids, $src_gpghome, $dst_gpghome, $die_on_error, @import_options) = @_;
    my $src = $src_gpghome // "your normal GnuPGHOME";
    my $dst = $dst_gpghome // "your normal GnuPGHOME";

    my @extra_args;
    push @import_options, 'import-local-sigs' if $CONFIG{'gpg-sign-type'} =~ /l/ and !grep /import-local-sigs$/, @import_options;
    push @import_options, 'keep-ownertrust' unless defined $dst_gpghome or GnuPG_version('2.1.0') >= 0; # don't modify our own trustdb
    push @extra_args, '--min-cert-level=1' if grep { $_ eq 'import-clean' } @import_options;
    push @extra_args, '--import-options', join (',', @import_options) if @import_options;

    # export the (non-armored) keys to $pipe
    debug("Exporting key(s) ".(join ',', @$keyids)." from $src to $dst");
    my @export_options = ('export-local-sigs') if grep {$_ eq 'import-local-sigs'} @import_options;
    my ($ePid, $pipe) = export_keys($src_gpghome, $keyids, @export_options);

    my $gpg = mkGnuPG( homedir => $dst_gpghome, quiet => 1, extra_args => \@extra_args );
    my $handles = mkGnuPG_fds( stdin  => $pipe, status => undef ); # import keys from $pipe
    my $iPid = $gpg->import_keys( handles => $handles );

    my $status = import_loop($handles->{status}, defined $src_gpghome ? 0 : 1, $keyids);
    done_gpg($iPid, $handles);  # import done
    waitpid $ePid => 0;         # export done

    my @failed = grep { !@{$status->{$_}} } keys %$status;
    if (@failed) {
        my $msg = "Couldn't import key(s) ".(join ',', @failed)." from $src";
        $die_on_error ? myerror(1, $msg) : info($msg, 0);
    }
    return $status;
}

##
# Import loop.
#
# @param fh                 the status file handle from GnuPG::Interface
# @param verbose            whether to list the status of each key as it
#                           is being imported.
# @param keyids             an array of keyids to be imported
# @param ignore_unexpected  whether not to print a warning upon receiving
#                           an unexpected key
#
# @ return a hash reference mapping each key ID to the list of matching
#   imported key fingerprint.
#
sub import_loop($$$;$) {
    my ($fh, $verbose, $keyids, $ignore_unexpected) = @_;

    # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
    # [GNUPG:] NODATA 1
    # [GNUPG:] NODATA 1
    # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
    my %status = map { $_ => [] } @$keyids;
    while (<$fh>) {
        # inspect the $status FD as data gets out
        if (/^\[GNUPG:\] IMPORT_OK (\d+) ([0-9A-F]{40})$/) {
            my ($r, $fpr) = ($1, $2);
            my @matching_keyids = grep { $fpr =~ /\Q$_\E$/ } @$keyids;
            unless (@matching_keyids) {
                unless ($ignore_unexpected) {
                    mywarn("Imported unexpected key $fpr.  Are you trying to work on a subkey?");
                } elsif ($verbose) {
                    info( "Key $fpr ". ($r == 0 ? 'not changed' : 'imported'), ($r == 0 ? undef : 1) );
                }
                next;
            }
            debug( "Imported $fpr for ".join(',', @matching_keyids));
            info( "Key " .join(',', @matching_keyids).' '. ($r == 0 ? 'not changed' : 'imported'), ($r == 0 ? undef : 1) ) if $verbose;
            push @{$status{$_} //= []}, $fpr foreach @matching_keyids;
        }
        elsif (/^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})$/) {
            mywarn("Imported v3 key $1.  Version 3 keys are obsolete, should not be used, and are not and will not be properly supported.");
        }
        elsif (!/^\[GNUPG:\]\ (?:NODATA\ \d
                               | IMPORT_RES\ .+
                               | IMPORTED\ .+
                               | KEYEXPIRED\ \d+
                               | SIGEXPIRED\ (?:\ deprecated-use-keyexpired-instead)?
                               | KEY_CONSIDERED\ [0-9A-F]{40}\ \d+
                               | FAILURE\ recv-keys\ \d+
                               )$/x) {
            mywarn("Got unknown reply from gpg: ".$_);
        }
    }
    return \%status;
}

##
# 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($) {
    my $keyids = shift;
    return unless $CONFIG{'keys-from-gnupg'} or @{$CONFIG{'key-files'}} or !$CONFIG{'no-download'};

    # map each keyid to a list of matching fingerprints; there is a
    # collision if a keyid is mapped to multiple fingerprints, but we'll
    # detect that later in the code
    my $status = { map { $_ => [] } @$keyids };

    if ($CONFIG{'keys-from-gnupg'}) {
        notice("Importing keys from your normal GnuPGHOME (".($ENV{'GNUPGHOME'} // "~/.gnupg").")");
        merge_import_status( $status, import_keys_from_gnupghome($keyids, undef, $GNUPGHOME, 0) );
    }

    foreach my $keyfile (@{$CONFIG{'key-files'}}) {
        notice("Importing key file $keyfile");

        my $gpg = mkGnuPG( homedir => $GNUPGHOME, quiet => 1 );
        $gpg->options->push_extra_args(qw/--import-options import-local-sigs/) if $CONFIG{'gpg-sign-type'} =~ /l/;
        my $handles = mkGnuPG_fds( status => undef );
        my $pid = $gpg->import_keys( handles => $handles, command_args => $keyfile );

        merge_import_status( $status, import_loop($handles->{status}, 1, $keyids, 1) );
        done_gpg($pid, $handles);
    }

    # Receive keys from keyserver
    unless ($CONFIG{'no-download'}) {
        notice("Fetching keys from a keyserver (this may take a while)...");
        my @args = (extra_args => ['--keyserver='.$CONFIG{'keyserver'}]) if defined $CONFIG{'keyserver'};
        my $gpg = mkGnuPG( homedir => $GNUPGHOME, @args );
        # logger: requesting key ... from hkp
        # stdout: gpgkeys: key ... not found on keyserver
        my $handles = mkGnuPG_fds( status => undef );
        my $pid = $gpg->recv_keys(handles => $handles, command_args => $keyids);

        my $s = import_loop($handles->{status}, 1, $keyids);
        merge_import_status($status, $s);
        done_gpg($pid, $handles);

        my @failed = grep { !@{$s->{$_}} } keys %$s;
        info("Couldn't import key(s) ".(join ',', @failed)." from the keyserver", 0) if @failed;
    }

    my @failed = grep { !@{$status->{$_}} } keys %$status;
    if (@failed) {
        exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
        mywarn("Assuming ". join(' ', @failed).' '.($#failed > 0 ? 'are' : 'is a')." fine keyid".($#failed > 0 ? 's' : ''));
    }
}
sub merge_import_status($$) {
    foreach my $keyid (keys %{$_[1]}) {
        push @{$_[0]->{$keyid} //= []}, @{$_[1]->{$keyid}};
    }
}

##
# A non-localized version of POSIX::strftime.
#
sub strfCtime($@) {
    my $lc_time = setlocale(POSIX::LC_TIME);
    setlocale(POSIX::LC_TIME, 'C');
    my $str = strftime(@_);
    setlocale(POSIX::LC_TIME, $lc_time);
    return $str;
}


###################
# 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'},
    '--debug'           =>  \$PARAMS->{'debug'},
    )) {
    usage(\*STDERR, 1);
}
if ($PARAMS->{'help'}) {
    usage(\*STDOUT, 0);
}
if ($PARAMS->{'version'}) {
    version(\*STDOUT);
    exit(0);
}

load_config();

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


if (-t \*STDIN) {
    # we're already talking to a TTY
    usage(\*STDERR, 1) unless @ARGV;
    *TTY = *STDIN;
} else {
    my @checksums;
    my $goodblock;
    my $got_input; # detect xargs, /dev/null, ...
    while (<STDIN>) {
        unless ($got_input) {
            notice("Reading gpgparticipants formatted input on STDIN");
            $got_input = 1;
        }

        if (/^(\S+)\s+Checksum:\s+[_ 0-9A-F]+(?:\s+\[(.)\])?$/i) {
            # ensure the checksum is (claimed to be) verified
            my ($md, $r) = ($1, $2);
            while (!defined $r) {
                $_ = <STDIN>;
                if (/^\s+[_ 0-9A-F]+\s+\[(.)\]$/i) {
                    $r = $1;
                }
                elsif (!/^(:?\s+[_ 0-9A-F]+)?$/i) {
                    myerror(1, "Unexpected input line: $_");
                }
            }
            myerror(1, "$md checksum wasn't marked as verified!") unless lc $r eq 'x';
            notice "Found $md checksum (marked as verified, assumed good)";
            push @checksums, uc $md;
        }
        elsif (/^(?:-+|_+)$/) {
            $goodblock = 0;
        }
        elsif (/^(#*)\d*\s+\[(.)\] Fingerprint(?:\(s\)|s)? OK\s+\[(.)\] ID OK\s*$/) {
            $goodblock = (!$1 and lc $2 eq 'x' and lc $3 eq 'x') ? 1 : 0;
        }
        elsif (/^ {5,}Key fingerprint = ([A-F0-9]{32}|(?:[A-F0-9]{2} ){8}(?: [A-F0-9]{2}){8})$/) {
            mywarn("Ignoring v3 fingerprint ".($1 =~ y/ //dr).".  v3 keys are obsolete.");
        }
        elsif (/^ {5,}(?:Key fingerprint = )?([A-F0-9]{40}|(?:[A-F0-9]{4} ){5}(?: [A-F0-9]{4}){5})$/) {
            my $fpr = ($1 =~ y/ //dr);
            if ($goodblock) {
                info("Adding fingerprint $fpr", 1);
                push @KEYIDS, $fpr;
            } else {
                info("Ignoring fingerprint $fpr", 0);
            }
        }
    }

    if ($got_input) {
        if (!@checksums) {
            mywarn "No checksum found!";
        } elsif (!grep { my $x = $_; grep { $x eq $_ } qw/SHA256 SHA384 SHA512 SHA224/ } @checksums) {
            mywarn "No checksum of the SHA-2 family found!";
        }
    }

    close STDIN;
    open TTY, '<', '/dev/tty' or myerror(1,"No TTY.")
}
my $TERMIOS = do {
    my $t = POSIX::Termios::->new();
    $t->getattr(fileno(TTY)) // die "getattr: $!";
    $t;
};

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';
}
$CONFIG{'mail-cant-encrypt'} //= $CONFIG{'mail'};

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
    if ($keyid =~ /^(\p{AHex}{32}|(?:\p{AHex}{2} ){8}(?: \p{AHex}{2}){8})$/) {
        mywarn("Ignoring v3 fingerprint ".($keyid =~ y/ //dr).".  v3 keys are obsolete.");
        next;
    }
    elsif ($keyid !~ /^((?:0x)?\p{AHex}{8}|(?:0x)?\p{AHex}{16}|\p{AHex}{40}|(?:\p{AHex}{4} ){5}(?: \p{AHex}{4}){5})$/) {
        print STDERR "$keyid is not a keyid.\n";
        usage(\*STDERR, 1);
    }

    $keyid =~ s/^0x//;
    $keyid =~ y/ //d; # gpg --fingerprint includes spaces
    push @KEYIDS, uc($keyid);
}


if (GnuPG_version('2.1.0') >= 0) {
    my %sockets;
    unless ($CONFIG{'no-sign'}) {
        # Ensure we have a working agent for our secret key material
        my $secdir = $CONFIG{'secret-keyring'};
        $secdir =~ s#/[^/]+$## unless -d $secdir;
        mysystem('gpg-connect-agent', '--homedir', $secdir, '/bye');
        $sockets{'agent-socket'} = GnuPG_version('2.1.13') < 0 ?
            # gpgconf < 2.1.13 doesn't understand --homedir; but on
            # these versions the gpg-agent socket path is always
            # $GNUPGHOME/S.gpg-agent.
            "$secdir/S.gpg-agent" :
            gpgconf('--homedir', $secdir, '--list-dirs')->{'agent-socket'};
    }
    unless ($CONFIG{'no-download'}) {
        # Ensure we have a working agent for the downloads
        my $homedir = $ENV{'GNUPGHOME'} // "$ENV{'HOME'}/.gnupg";
        mysystem('gpg-connect-agent', '--homedir', $homedir, '--dirmngr', '/bye');
        $sockets{'dirmngr-socket'} = GnuPG_version('2.1.13') < 0 ?
            # gpgconf < 2.1.13 doesn't understand --homedir; but on
            # these versions the gpg-agent socket path is always
            # $GNUPGHOME/S.dirmngr.
            "$homedir/S.dirmngr" :
            gpgconf('--homedir', $homedir, '--list-dirs')->{'dirmngr-socket'};
    }

    foreach my $k (keys %sockets) {
        my $socket = $sockets{$k};
        my $l = GnuPG_version('2.1.13') < 0 ?
            $socket =~ s#.*/#$GNUPGHOME/#r :
            gpgconf('--homedir', $GNUPGHOME, '--list-dirs')->{$k};
        if (-l $l) {
            unlink $l
        } elsif (-S $l) {
            # don't run agents in caff's homedir
            myerror(1, "$l: socket exists; runaway gpg-agent?");
        } elsif (! -S $socket) {
            myerror(1, "Missing socket $socket");
        }
        debug "Creating symlink $l to $socket";
        symlink $socket, $l or myerror(1, "Cannot symlink: $!");
    }
}
elsif ($CONFIG{'also-lsign-in-gnupghome'} eq 'auto' and $CONFIG{'gpg-sign-type'} !~ /l/) {
    # Ensure there is a working gpg-agent if $CONFIG{'also-lsign-in-gnupghome'} is 'auto'
    system qw/gpg-agent -q/;
    unless ($? == 0) {
        mywarn("No gpg-agent running: set \$CONFIG{'also-lsign-in-gnupghome'} = 'ask'");
        $CONFIG{'also-lsign-in-gnupghome'} = 'ask';
    }
}

##################################
# import own keys and keys to sign
##################################
import_keys_from_gnupghome($CONFIG{'keyid'}, undef, $GNUPGHOME, 1);
import_keys_from_gnupghome($CONFIG{'also-encrypt-to'}, undef, $GNUPGHOME, 0) if defined $CONFIG{'also-encrypt-to'};
@LOCAL_USER = get_local_user_keys() unless $CONFIG{'no-sign'};

import_keys_to_sign(\@KEYIDS);
if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
    $CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
}

my %KEYS;
for my $keyid (@KEYIDS) {
    # get key listing (and ensure there is no collision)
    ####################################################
    my $gpg = mkGnuPG( homedir => $GNUPGHOME, extra_args => ['--with-fingerprint', '--with-colons'] );
    my $handles = mkGnuPG_fds( stdout => undef );

    # process the keys one by one so we can detect collisions
    my $pid = $gpg->list_public_keys( handles => $handles, command_args => [$keyid] );

    my @matching_keys;
    while (readline $handles->{stdout}) {
        if (/^pub:([^:]+):(?:[^:]*:){2}([0-9A-F]{16}):(?:[^:]*:){6}([^:]+)/) {
            push @matching_keys, { validity => $1, longkeyid => $2, capability => $3, uids => [], subkeys => [] };
        }
        elsif (/^fpr:(?:[^:]*:){8}([0-9A-F]{40}|[0-9A-F]{32})(?::.*)?$/) {
            $matching_keys[$#matching_keys]->{fpr} //= $1;
        }
        elsif (/^sub:[^:]+:(?:[^:]*:){2}([0-9A-F]{16}):/) {
            push @{$matching_keys[$#matching_keys]->{subkeys}}, $1;
        }
        elsif (/^(uid|uat):([^:]+):(?:[^:]*:){5}([0-9A-F]{40}):[^:]*:([^:]+)/) {
            my $uid = { type => $1
                      , validity => $2
                      , hash => $3
                      , text => $1 eq 'uid' ? $4 : '[attribute]'
            };
            $uid->{text} =~ s/\\x(\p{AHex}{2})/ chr(hex($1)) /ge;
            # --with-colons always outputs UTF-8
            $uid->{text} = Encode::decode_utf8($uid->{text});
            $uid->{address} = email_valid $uid->{text} if $uid->{type} eq 'uid';
            push @{$matching_keys[$#matching_keys]->{uids}}, $uid;
        }
        elsif (!/^(?:rvk|tru):/) {
            chomp;
            mywarn("Got unknown reply from gpg: ".$_);
        }
    }
    done_gpg($pid, $handles);

    unless (@matching_keys) {
        mywarn("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME)");
        next;
    }

    my $key;
    foreach (@matching_keys) {
        my $reason = $_->{fpr}        =~ /^\p{AHex}{32}$/ ? 'obsolete v3'
                   : $_->{validity}   =~ /e/ ? 'expired'
                   : $_->{validity}   =~ /i/ ? 'invalid'
                   : $_->{validity}   =~ /r/ ? 'revoked'
                   : $_->{capability} =~ /D/ ? 'disabled'
                   : do { $key = $_; last };
        mywarn("Ignoring $reason key $_->{fpr}");
    }
    mywarn( "More than one key matched $keyid (assuming $key->{fpr}).  "
          . "Try to specify the long keyid or full fingerprint to avoid collisions.")
      if $#matching_keys > 0 and defined $key;

    if (defined $key) {
        $KEYS{$keyid} = $key;
    } else {
        my $msg = "public key found with list-key $keyid";
        mywarn( @matching_keys ? "No valid $msg" : "No $msg  (note that caff uses its own keyring in $GNUPGHOME)" );
    }
}

unless (keys %KEYS) {
    notice("No keys to sign found", 0);
    exit 0;
}


for my $keyid (@KEYIDS) {
    next unless exists $KEYS{$keyid};
    my ($longkeyid, $fpr) = @{$KEYS{$keyid}}{qw/longkeyid fpr/};

    ###########
    # sign keys
    ###########
    unless ($CONFIG{'no-sign'}) {
        notice("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
        foreach my $local_user (@LOCAL_USER) {
            my @command = ($CONFIG{'gpg'});
            push @command, "--homedir=$GNUPGHOME";
            push @command, @GNUPGOPTS if @GNUPGOPTS;
            push @command, '--secret-keyring', $CONFIG{'secret-keyring'} if GnuPG_version('2.1.0') < 0;
            push @command, qw/--no-auto-check-trustdb --trust-model=always/;
            push @command, '--local-user', $local_user;
            push @command, '--edit-key', $fpr;
            push @command, 'showphoto' if $CONFIG{'show-photos'};
            push @command, $CONFIG{'gpg-sign-type'}.'sign';
            push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
            print join(' ', @command),"\n";
            mysystem(@command);
        };
    };


    ##################
    # export and prune
    ##################

    # export the key
    ################
    my $keydir = File::Temp->newdir( "caff-$keyid-XXXXX", TMPDIR => 1 );
    # we can't use only one import here because the cleaning is done as the
    # keys come and our keys might not be imported yet
    import_keys_from_gnupghome($CONFIG{'keyid'}, $GNUPGHOME, $keydir, 1, 'import-minimal', 'import-local-sigs');
    import_keys_from_gnupghome([$fpr],           $GNUPGHOME, $keydir, 1, 'import-clean',   'import-local-sigs');

    # the first UID. we won't delete that one when pruning for UATs because a key has to have at least one UID
    my @uids = @{$KEYS{$keyid}->{uids}};
    my $first_uid = (grep {$_->{type} eq 'uid'} @uids)[0];

    for (my $uid_number = 1; $uid_number <= $#uids+1; $uid_number++) {
        debug("Doing key $keyid, uid $uid_number");
        my $uid = $uids[$uid_number-1];

        # /!\ this serial is valid in caff's GnuPGHOME only, and can't
        # be relied upon if the keyring is modified in the meantime.
        $uid->{serial} = $uid_number;

        next if $uid->{validity} =~ /[eir]/; # skip expired / invalid / revokey UIDs

        # copy pubring to temporary gpghome
        ###################################
        my $uiddir = File::Temp->newdir( "caff-$keyid-$uid_number-XXXXX", TMPDIR => 1 );
        foreach (qw/pubring.gpg pubring.kbx/) {
            copy($keydir.'/'.$_, $uiddir.'/'.$_) if -e $keydir.'/'.$_;
        }

        # prune it
        ##########
        my $gpg = mkGnuPG( homedir => $uiddir, extra_args => ['--with-colons'] );
        my $handles = mkGnuPG_fds( command => undef, stdout => undef, status => undef );
        my $pid = $gpg->wrap_call(
            commands     => [ '--edit-key' ],
            command_args => [ $fpr ],
            handles      => $handles );

        debug("Starting edit session");
        my %output = readwrite_gpg($handles, status => $KEYEDIT_PROMPT);

        # delete other uids
        ###################
        my $delete_some = 0;
        for (my $i = 1; $i <= $#uids+1; $i++) {
            # it's quicker with gpg2: 'uid *' then 'uid $i'
            next if $i == $uid_number;
            next if $uid->{type} ne 'uid' and $uids[$i-1]->{hash} eq $first_uid->{hash}; # keep the first UID

            debug("Marking UID $i ($uids[$i-1]->{hash}) for deletion");
            readwrite_gpg($handles, command => "uid $i", status => $KEYEDIT_PROMPT);
            $delete_some++;
        }

        if ($delete_some) {
            debug("Need to delete $delete_some uids");
            readwrite_gpg($handles, command => "deluid", status => $KEYEDIT_DELUID_PROMPT);
            readwrite_gpg($handles, command => "yes",    status => $KEYEDIT_PROMPT);
        };

        # delete all subkeys
        ####################
        if (@{$KEYS{$keyid}->{subkeys}}) {
            for (my $i = 1; $i <= $#{$KEYS{$keyid}->{subkeys}} + 1; $i++) {
                debug("Marking subkey $i ($KEYS{$keyid}->{subkeys}->[$i-1]) for deletion");
                readwrite_gpg($handles, command => "key $i", status => $KEYEDIT_PROMPT);
            };
            readwrite_gpg($handles, command => "delkey", status => $KEYEDIT_DELSUBKEY_PROMPT);
            readwrite_gpg($handles, command => "yes", status => $KEYEDIT_PROMPT);
        };

        # delete signatures
        ###################
        # this shouldn't delete anything as $longkeyid is already clean, but maybe we didn't sign that uid with all keys in @{$CONFIG{'keyid'}}
        my ($last_signed_on, $xsigners) = delete_signatures($handles, $longkeyid, $uid->{hash}, $CONFIG{'keyid'});

        delete_signatures($handles, $longkeyid, $first_uid->{hash}, [])
            if $uid->{type} ne 'uid'; # delete all sigs on the first UID if $uid is an attribute


        readwrite_gpg($handles, command => "save");
        done_gpg($pid, $handles);
        debug("Done editing");

        my $asciikey = export_keys($uiddir, [$fpr], 'export-local-sigs');
        undef $uiddir; # delete dir

        unless ($asciikey) {
            mywarn "No data from gpg for export $fpr";
            next;
        };

        if ($last_signed_on) {
            # it's a bit inefficient to store the $asciikey in memory,
            # but it has been pruned so it's shouldn't be too big
            $uid->{key} = $asciikey;
            $uid->{xsigners} = $xsigners;
            $uid->{last_signed_on} = $last_signed_on;
        };
    };


    unless ($CONFIG{'also-lsign-in-gnupghome'} eq 'no') {
        # remove all exportable sigs, and import into our GnuPGHOME
        ###########################################################
        my $gpg = mkGnuPG( homedir => $keydir, extra_args => ['--with-colons'] );
        my $handles = mkGnuPG_fds( command => undef, stdout => undef, status => undef );
        my $pid = $gpg->wrap_call(
            commands     => [ '--edit-key' ],
            command_args => [ $fpr ],
            handles      => $handles );

        debug("Starting edit session on $keyid");
        my %output = readwrite_gpg($handles, status => $KEYEDIT_PROMPT);
        delete_signatures($handles, $longkeyid, $uids[$_]->{hash}, $CONFIG{'keyid'}, 1) foreach (0 .. $#uids);

        readwrite_gpg($handles, command => "save");
        done_gpg($pid, $handles);
        debug("Done editing");

        # import the pruned keys with our own local sigs only; this is
        # required even if there are no lsigs, to ensure we've got all
        # UIDs in our own GnuPGHOME
        import_keys_from_gnupghome( [$fpr], $keydir, undef, 1, 'import-local-sigs' );
    }
    undef $keydir; # delete dir

    if ($CONFIG{'also-lsign-in-gnupghome'} eq 'ask') {
        # manually lsign the key
        ########################
        foreach my $local_user (@LOCAL_USER) {
            my @command = ($CONFIG{'gpg'});
            push @command, '--secret-keyring', $CONFIG{'secret-keyring'} if GnuPG_version('2.1.0') < 0;
            push @command, qw/--no-auto-check-trustdb --trust-model=always/;
            push @command, '--local-user', $local_user;
            push @command, '--edit-key', $fpr;
            push @command, 'showphoto' if $CONFIG{'show-photos'};
            push @command, 'lsign';
            push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
            print join(' ', @command),"\n";
            mysystem(@command);
        }
    }
    elsif ($CONFIG{'also-lsign-in-gnupghome'} eq 'auto') {
        # auto lsign the uids we for which we have an exportable sig
        ############################################################
        my @uids = grep {exists $_->{xsigners}} @{$KEYS{$keyid}->{uids}};
        my @signers = map {keys %{$_->{xsigners}}} @uids;
        # which of @LOCAL_USER has signed at least one UID in this key?
        @signers = grep { my $u = $_; grep { $u eq $_ } @signers } @LOCAL_USER;
        @signers = keys %{{ map { $_ => 1 } @signers }}; # remove duplicates to avoid double signing

        foreach my $u (@signers) {
            my @signeduids; # uids signed by $u
            foreach my $uid (@uids) {
                # we use UIDs hashes to distinguish and select UIDs; it's the only reliable way to identify them across keyrings
                push @signeduids, $uid if grep { $u eq $_ } (keys %{$uid->{xsigners}}) and
                                         !grep { $uid->{hash} eq $_->{hash} } @signeduids;
            }

            my $gpg = mkGnuPG( extra_args => ['--local-user' => $u, '--ask-cert-level', '--with-colons', '--no-batch'] );
            $gpg->options->push_extra_args('--secret-keyring', $CONFIG{'secret-keyring'}) if GnuPG_version('2.1.0') < 0;
            $gpg->options->push_extra_args('--use-agent') if GnuPG_version('2.0.0') < 0; # we know there is a working agent
            my $handles = mkGnuPG_fds( command => undef, stdout => undef, status => undef );
            my $pid = $gpg->wrap_call(
                commands     => [ '--edit-key' ],
                command_args => [ $fpr ],
                handles      => $handles );

            debug("Starting edit session on $keyid, signer $u");
            readwrite_gpg($handles, status => $KEYEDIT_PROMPT);

            foreach my $level (0..3) {
                my @signeduids_with_level = grep {$_->{xsigners}->{$u} eq $level} @signeduids;
                next unless @signeduids_with_level;

                notice("Key $longkeyid UID(s) #".(join ',', sort (map {$_->{serial}} @signeduids_with_level)).": lsign'ing with $u, cert level $level", 1);
                readwrite_gpg($handles, command => "uid 0",          status => $KEYEDIT_PROMPT); # unselect UIDs
                readwrite_gpg($handles, command => "uid $_->{hash}", status => $KEYEDIT_PROMPT) for @signeduids_with_level;
                my %output = readwrite_gpg($handles, command => "lsign", status => qr/$KEYEDIT_SIGNUID_CLASS_PROMPT|$KEYEDIT_PROMPT/);
                next if $output{status} =~ /^\[GNUPG:\] $KEYEDIT_PROMPT/m; # already signed
                readwrite_gpg($handles, command => $level, status => $KEYEDIT_SIGNUID_PROMPT);
                readwrite_gpg($handles, command => "yes",  status => $KEYEDIT_PROMPT);
            }

            readwrite_gpg($handles, command => "save");
            done_gpg($pid, $handles);
            debug("Done editing");
        }
    }
}

#############
# send emails
#############
for my $keyid (@KEYIDS) {
    next unless exists $KEYS{$keyid};
    my $longkeyid = $KEYS{$keyid}->{longkeyid};
    my $can_encrypt = $KEYS{$keyid}->{capability} =~ /E/;
    my @uids = @{$KEYS{$keyid}->{uids}};

    unless (grep {$_->{last_signed_on}} @uids) {
        info("Key 0x$longkeyid has no signed uids, skipping", 0);
        next;
    }

    my @attached;
    for my $uid (@uids) {
        my $text = defined $LOCALE ? $LOCALE->encode($uid->{text}) : $uid->{text};

        trace("UID: $text\n");
        if ($uid->{validity} =~ /[eir]/) {
            my $reason = $uid->{validity} =~ /e/ ? 'expired' :
                         $uid->{validity} =~ /i/ ? 'invalid' :
                         $uid->{validity} =~ /r/ ? 'revoked' : die;
            info("Key 0x$longkeyid ".(uc $uid->{type})." $uid->{serial} $text is $reason, skipping", 0);
            next;
        }
        unless ($uid->{last_signed_on}) {
            info("Key 0x$longkeyid ".(uc $uid->{type})." $uid->{serial} $text is not signed by me, skipping", 0);
            next;
        }

        if ($NOW - $uid->{last_signed_on} > $CONFIG{'export-sig-age'} and
                !ask("Signature on $text is old.  Export?", 0, $PARAMS->{'export-old'}, $PARAMS->{'no-export-old'})) {
            next;
        }

        # save the armored key
        my $keydir = "$KEYSBASE/$DATE_STRING";
        -d $keydir || mkdir $keydir, 0700 or myerror(1, "Cannot mkdir $keydir: $!");

        my $keyfile = "$keydir/$longkeyid.key.$uid->{serial}.".sanitize_uid($text).".asc";
        open my $KEY, '>', $keyfile or myerror(1, "Cannot open $keyfile: $!");
        debug "Writing armored key 0x$longkeyid to $keyfile";
        print $KEY $uid->{key};
        close $KEY;

        if ($uid->{type} eq 'uat') {
            if (ask("UID $text is an attribute UID, attach it to every email?", 1)) {
                push @attached, $uid;
                $uid->{export} = 1;
            }
        } elsif (!defined $uid->{address}) {
            if (ask("UID $text is no email address, attach it to every email?", 1)) {
                push @attached, $uid;
                $uid->{export} = 1;
            }
        }
        else {
            $uid->{export} = 1;
        }

        info("Key 0x$longkeyid ".(uc $uid->{type})." $uid->{serial} $text done", 1);
    }

    @uids = grep {$_->{last_signed_on}} @uids;              # ignore UIDs we didn't sign
    delete $_->{key} foreach grep {!$_->{export}} @uids;    # delete non-exported keys

    if (!grep {defined $_->{address}} @uids) {
        mywarn "No signed RFC 5322 UID on $longkeyid; won't send other signed UID and attributes!"
            if @attached;
    }
    elsif (grep {$_->{export}} @uids) {
        notice("Key 0x$longkeyid has no encryption capabilities, mail(s) will be sent/stored unencrypted", 0) unless $can_encrypt;
        my $sendmail = $can_encrypt ? $CONFIG{'mail'} : $CONFIG{'mail-cant-encrypt'};

        for my $uid (@uids) {
            next unless defined $uid->{address};
            next unless $uid->{export} or @attached;
            my @keys = @attached;
            unshift @keys, $uid if exists $uid->{key};

            my $mail = create_mail($uid->{address}, $can_encrypt, $longkeyid, @keys);
            if (defined $mail) {
                my @sentuids = map {$_->{text}} @attached;
                unshift @sentuids, $uid->{text} if $uid->{export};
                do { $_ = $LOCALE->encode($_) foreach @sentuids; } if defined $LOCALE;
                my $text = join(', ', map {"'$_'"} @sentuids);

                my $should_send_mail = ask("Mail ".($can_encrypt ? '' : '*unencrypted* ')."signature for $text to '$uid->{address}'?",
                                           $sendmail ne 'ask-no', $sendmail eq 'yes', $sendmail eq 'no');
                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($text);
                open my $MAILFILE, '>', $mailfile or myerror(1, "Cannot open $mailfile: $!");
                debug "Writing message to $mailfile";
                $mail->print($MAILFILE);
                close $MAILFILE;
            } else {
                mywarn "Generating mail failed";
            }
        }
    }

    info("Key 0x$longkeyid done", 1);
}

END {
    if (defined $TERMIOS and defined (my $fd = fileno(TTY))) {
        $TERMIOS->setattr($fd, POSIX::TCSANOW) // warn "setattr: $!";
    }
}

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

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

Regards,
--
{$owner}