caff/caff

   1 #!/usr/bin/perl -w
   2
   3 # caff  --  CA - Fire and Forget
   4 # $Id$
   5 #
   6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
   7 # Copyright (c) 2005 Christoph Berg <cb@df7cb.de>
   8 #
   9 # All rights reserved.
  10 #
  11 # Redistribution and use in source and binary forms, with or without
  12 # modification, are permitted provided that the following conditions
  13 # are met:
  14 # 1. Redistributions of source code must retain the above copyright
  15 #    notice, this list of conditions and the following disclaimer.
  16 # 2. Redistributions in binary form must reproduce the above copyright
  17 #    notice, this list of conditions and the following disclaimer in the
  18 #    documentation and/or other materials provided with the distribution.
  19 # 3. The name of the author may not be used to endorse or promote products
  20 #    derived from this software without specific prior written permission.
  21 #
  22 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  23 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  24 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  25 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  26 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  27 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  28 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  29 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  30 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  31 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32
  33 =pod
  34
  35 =head1 NAME
  36
  37 caff -- CA - Fire and Forget
  38
  39 =head1 SYNOPSIS
  40
  41 =over
  42
  43 =item B<caff> [-eEmMRS] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
  44
  45 =back
  46
  47 =head1 DESCRIPTION
  48
  49 CA Fire and Forget is a script that helps you in keysigning.  It takes a list
  50 of keyids on the command line, fetches them from a keyserver and calls GnuPG so
  51 that you can sign it.  It then mails each key to all its email addresses - only
  52 including the one UID that we send to in each mail, pruned from all but self
  53 sigs and sigs done by you.
  54
  55 =head1 OPTIONS
  56
  57 =over
  58
  59 =item B<-e>, B<--export-old>
  60
  61 Export old signatures. Default is to ask the user for each old signature.
  62
  63 =item B<-E>, B<--no-export-old>
  64
  65 Do not export old signatures. Default is to ask the user for each old
  66 signature.
  67
  68 =item B<-m>, B<--mail>
  69
  70 Send mail after signing. Default is to ask the user for each uid.
  71
  72 =item B<-M>, B<--no-mail>
  73
  74 Do not send mail after signing. Default is to ask the user for each uid.
  75
  76 =item B<-R>, B<--no-download>
  77
  78 Do not retrieve the key to be signed from a keyserver.
  79
  80 =item B<-S>, B<--no-sign>
  81
  82 Do not sign the keys.
  83
  84 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
  85
  86 Select the key that is used for signing, in case you have more than one key.
  87
  88 =item B<--key-file> I<file>
  89
  90 Import keys from file. Can be supplied more than once.
  91
  92 =back
  93
  94 =head1 FILES
  95
  96 =over
  97
  98 =item $HOME/.caffrc  -  configuration file
  99
 100 =item $HOME/.caff/keys/yyyy-mm-dd/  -  processed keys
 101
 102 =item $HOME/.caff/gnupghome/  -  caff's working dir for gpg
 103
 104 =item $HOME/.caff/gnupghome/gpg.conf  -  gpg configuration
 105
 106 useful options include use-agent, default-cert-level, etc.
 107
 108 =back
 109
 110 =head1 CONFIGURATION FILE OPTIONS
 111
 112 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
 113 The file is generated when it does not exist.
 114
 115 Example:
 116
 117         $CONFIG{owner} = q{Peter Palfrader};
 118         $CONFIG{email} = q{peter@palfrader.org};
 119         $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
 120
 121 =head2 Required basic settings
 122
 123 =over
 124
 125 =item B<owner> [string]
 126
 127 Your name.  B<REQUIRED>.
 128
 129 =item B<email> [string]
 130
 131 Your email address, used in From: lines.  B<REQUIRED>.
 132
 133 =item B<keyid> [list of keyids]
 134
 135 A list of your keys.  This is used to determine which signatures to keep
 136 in the pruning step.  If you select a key using B<-u> it has to be in
 137 this list.  B<REQUIRED>.
 138
 139 =head2 General settings
 140
 141 =item B<caffhome> [string]
 142
 143 Base directory for the files caff stores.  Default: B<$HOME/.caff/>.
 144
 145 =head2 GnuPG settings
 146
 147 =item B<gpg> [string]
 148
 149 Path to the GnuPG binary.  Default: B<gpg>.
 150
 151 =item B<gpg-sign> [string]
 152
 153 Path to the GnuPG binary which is used to sign keys.  Default: what
 154 B<gpg> is set to.
 155
 156 =item B<gpg-delsig> [string]
 157
 158 Path to the GnuPG binary which is used to split off signatures.  This was
 159 needed while the upstream GnuPG was not fixed.  Default: what B<gpg>
 160 is set to.
 161
 162 =item B<secret-keyring> [string]
 163
 164 Path to your secret keyring.  Default: B<$HOME/.gnupg/secring.gpg>.
 165
 166 =item B<also-encrypt-to> [keyid]
 167
 168 An additional keyid to encrypt messages to. Default: none.
 169
 170 =item B<gpg-sign-args> [string]
 171
 172 Additional arguments to pass to gpg.  Default: none.
 173
 174 =head2 Keyserver settings
 175
 176 =item B<keyserver> [string]
 177
 178 Keyserver to download keys from.  Default: B<subkeys.pgp.net>.
 179
 180 =item B<no-download> [boolean]
 181
 182 If true, then skip the step of fetching keys from the keyserver.
 183 Default: B<0>.
 184
 185 =item B<key-files> [list of files]
 186
 187 A list of files containing keys to be imported.
 188
 189 =head2 Signing settings
 190
 191 =item B<no-sign> [boolean]
 192
 193 If true, then skip the signing step. Default: B<0>.
 194
 195 =item B<ask-sign> [boolean]
 196
 197 If true, then pause before continuing to the signing step.
 198 This is useful for offline signing. Default: B<0>.
 199
 200 =item B<export-sig-age> [seconds]
 201
 202 Don't export UIDs by default, on which your latest signature is older
 203 than this age.  Default: B<24*60*60> (i.e. one day).
 204
 205 =head2 Mail settings
 206
 207 =item B<mail> [boolean]
 208
 209 Do not prompt for sending mail, just do it. Default: B<0>.
 210
 211 =item B<no-mail> [boolean]
 212
 213 Do not prompt for sending mail. The messages are still written to
 214 $CONFIG{caffhome}/keys/. Default: B<0>.
 215
 216 =item B<mail-template> [string]
 217
 218 Email template which is used as the body text for the email sent out
 219 instead of the default text if specified. The following perl variables
 220 can be used in the template:
 221
 222 =over
 223
 224 =item B<{owner}> [string]
 225
 226 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
 227
 228 =item B<{key}> [string]
 229
 230 The keyid of the key you signed.
 231
 232 =item B<{@uids}> [array]
 233
 234 The UIDs for which signatures are included in the mail.
 235
 236 =back
 237
 238 =item B<reply-to> [string]
 239
 240 Add a Reply-To: header to messages sent. Default: none.
 241
 242 =item B<bcc> [string]
 243
 244 Address to send blind carbon copies to when sending mail.
 245 Default: none.
 246
 247 =back
 248
 249 =head1 AUTHORS
 250
 251 =over
 252
 253 =item Peter Palfrader <peter@palfrader.org>
 254
 255 =item Christoph Berg <cb@df7cb.de>
 256
 257 =back
 258
 259 =head1 WEBSITE
 260
 261 http://pgp-tools.alioth.debian.org/
 262
 263 =head1 SEE ALSO
 264
 265 gpg(1), pgp-clean(1), /usr/share/doc/signing-party/caff/caffrc.sample.
 266
 267 =cut
 268
 269 use strict;
 270 use IO::Handle;
 271 use English;
 272 use File::Path;
 273 use File::Temp qw{tempdir};
 274 use Text::Template;
 275 use MIME::Entity;
 276 use Fcntl;
 277 use IO::Select;
 278 use Getopt::Long;
 279 use GnuPG::Interface;
 280
 281 my %CONFIG;
 282 my $REVISION = '$Rev$';
 283 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
 284 my $VERSION = "0.0.0.$REVISION_NUMER";
 285
 286
 287
 288 sub notice($) {
 289         my ($line) = @_;
 290         print "[NOTICE] $line\n";
 291 };
 292 sub info($) {
 293         my ($line) = @_;
 294         print "[INFO] $line\n";
 295 };
 296 sub debug($) {
 297         my ($line) = @_;
 298         #print "[DEBUG] $line\n";
 299 };
 300 sub trace($) {
 301         my ($line) = @_;
 302         #print "[trace] $line\n";
 303 };
 304 sub trace2($) {
 305         my ($line) = @_;
 306         #print "[trace2] $line\n";
 307 };
 308
 309
 310 sub generate_config() {
 311         notice("Error: \$LOGNAME is not set.\n") unless defined $ENV{'LOGNAME'};
 312         my $gecos = defined $ENV{'LOGNAME'} ? (getpwnam($ENV{LOGNAME}))[6] : undef;
 313         my $email;
 314         my @keys;
 315         my $hostname = `hostname -f`;
 316         chomp $hostname;
 317         my ($Cgecos,$Cemail,$Ckeys) = ('','','');
 318         if (defined $gecos) {
 319                 $gecos =~ s/,.*//;
 320
 321                 my $gpg = GnuPG::Interface->new();
 322                 $gpg->call( 'gpg' );
 323                 $gpg->options->hash_init(
 324                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
 325                 $gpg->options->meta_interactive( 0 );
 326                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 327                 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $gecos ]);
 328                 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 329                 waitpid $pid, 0;
 330
 331                 if ($stdout eq '') {
 332                         warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
 333                 };
 334
 335                 @keys = ($stdout =~ /^pub:[^r:]*:(?:[^:]*:){2,2}([^:]+):/mg);
 336                 unless (scalar @keys) {
 337                         info("Error: No keys were found using \"gpg --list-public-keys '$gecos'\".");
 338                         @keys = qw{0123456789abcdef 89abcdef76543210};
 339                         $Ckeys = '#';
 340                 }
 341                 ($email) =  ($stdout =~ /^uid:.*<(.+?@.+?)>.*:/m);
 342                 unless (defined $email) {
 343                         info("Error: No email address was found using \"gpg --list-public-keys '$gecos'\".");
 344                         $email = $ENV{'LOGNAME'}.'@'.$hostname;
 345                         $Cemail = '#';
 346                 }
 347         } else {
 348                 $gecos = 'Unknown Caff User';
 349                 $email = $ENV{'LOGNAME'}.'@'.$hostname;
 350                 @keys = qw{0123456789abcdef 89abcdef76543210};
 351                 ($Cgecos,$Cemail,$Ckeys) = ('#','#','#');
 352         };
 353
 354         return <<EOT;
 355 # .caffrc -- vim:syntax=perl:
 356 # This file is in perl(1) format - see caff(1) for details.
 357
 358 $Cgecos\$CONFIG{'owner'}       = '$gecos';
 359 $Cemail\$CONFIG{'email'}       = '$email';
 360
 361 # you can get your long keyid from
 362 #   gpg --with-colons --list-key <yourkeyid|name|emailaddress..>
 363 #
 364 # if you have a v4 key, it will simply be the last 16 digits of
 365 # your fingerprint.
 366 #
 367 # Example:
 368 #   \$CONFIG{'keyid'}       = [ qw{FEDCBA9876543210} ];
 369 #  or, if you have more than one key:
 370 #   \$CONFIG{'keyid'}       = [ qw{0123456789ABCDEF 89ABCDEF76543210} ];
 371
 372 $Ckeys\$CONFIG{'keyid'}       = [ qw{@keys} ];
 373 EOT
 374 };
 375
 376 sub check_executable($$) {
 377         # (GnuPG::Interface gives lousy errors when the gpg binary isn't found,
 378         # so we want to check manually.)
 379         my ($purpose, $fn) = @_;
 380         # Only check provided fnames with a slash in them.
 381         return unless defined $fn;
 382         if ($fn =~ m!/!) {
 383                 die ("$PROGRAM_NAME: $purpose executable '$fn' not found.\n") unless -x $fn;
 384         } else {
 385                 for my $p (split(':', $ENV{PATH})) {
 386                         return if -x "$p/$fn";
 387                 };
 388                 die ("$PROGRAM_NAME: $purpose executable '$fn' not found on path.\n") unless -x $fn;
 389         };
 390 };
 391
 392 sub load_config() {
 393         my $config = $ENV{'HOME'} . '/.caffrc';
 394         unless (-f $config) {
 395                 print "No configfile $config present, I will use this template:\n";
 396                 my $template = generate_config();
 397                 print "$template\nPlease edit $config and run caff again.\n";
 398                 open F, ">$config" or die "$config: $!";
 399                 print F $template;
 400                 close F;
 401                 exit(1);
 402         }
 403         unless (scalar eval `cat $config`) {
 404                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 405         };
 406
 407         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 408         die ("$PROGRAM_NAME: owner is not defined in $config.\n") unless defined $CONFIG{'owner'};
 409         die ("$PROGRAM_NAME: email is not defined in $config.\n") unless defined $CONFIG{'email'};
 410         die ("$PROGRAM_NAME: keyid is not defined in $config.\n") unless defined $CONFIG{'keyid'};
 411         die ("$PROGRAM_NAME: keyid is not an array ref in $config.\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 412         for my $keyid (@{$CONFIG{'keyid'}}) {
 413                 $keyid =~ /^[A-F0-9]{16}$/i or die ("$PROGRAM_NAME: key $keyid is not a long (16 digit) keyid in $config.\n");
 414         };
 415         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 416         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 417         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 418         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 419         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 420         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 421         check_executable("gpg", $CONFIG{'gpg'});
 422         check_executable("gpg-sign", $CONFIG{'gpg-sign'});
 423         check_executable("gpg-delsig", $CONFIG{'gpg-delsig'});
 424         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 425         $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
 426         $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
 427         $CONFIG{'key-files'} = () unless defined $CONFIG{'key-files'};
 428         $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
 429 Hi,
 430
 431 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
 432 {foreach $uid (@uids) {
 433     $OUT .= "\t".$uid."\n";
 434 };} of your key {$key} signed by me.
 435
 436 Note that I did not upload your key to any keyservers.
 437 If you have multiple user ids, I sent the signature for each user id
 438 separately to that user id's associated email address. You can import
 439 the signatures by running each through `gpg --import`.
 440
 441 If you want this new signature to be available to others, please upload
 442 it yourself. With GnuPG this can be done using
 443         gpg --keyserver subkeys.pgp.net --send-key {$key}
 444
 445 If you have any questions, don't hesitate to ask.
 446
 447 Regards,
 448 {$owner}
 449 EOM
 450 };
 451
 452 sub make_gpg_fds() {
 453         my %fds = (
 454                 stdin => IO::Handle->new(),
 455                 stdout => IO::Handle->new(),
 456                 stderr => IO::Handle->new(),
 457                 status => IO::Handle->new() );
 458         my $handles = GnuPG::Handles->new( %fds );
 459         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 460 };
 461
 462 sub readwrite_gpg($$$$$%) {
 463         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 464
 465         trace("Entering readwrite_gpg.");
 466
 467         my ($first_line, undef) = split /\n/, $in;
 468         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 469
 470         local $INPUT_RECORD_SEPARATOR = undef;
 471         my $sout = IO::Select->new();
 472         my $sin = IO::Select->new();
 473         my $offset = 0;
 474
 475         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 476
 477         $inputfd->blocking(0);
 478         $stdoutfd->blocking(0);
 479         $statusfd->blocking(0) if defined $statusfd;
 480         $stderrfd->blocking(0);
 481         $sout->add($stdoutfd);
 482         $sout->add($stderrfd);
 483         $sout->add($statusfd) if defined $statusfd;
 484         $sin->add($inputfd);
 485
 486         my ($stdout, $stderr, $status) = ("", "", "");
 487         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 488         trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 489
 490         my $readwrote_stuff_this_time = 0;
 491         my $do_not_wait_on_select = 0;
 492         my ($readyr, $readyw, $written);
 493         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 494                 if (defined $exitwhenstatusmatches) {
 495                         if ($status =~ /$exitwhenstatusmatches/m) {
 496                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 497                                 if ($readwrote_stuff_this_time) {
 498                                         trace("read/write some more\n");
 499                                         $do_not_wait_on_select = 1;
 500                                 } else {
 501                                         trace("that's it in our while loop.\n");
 502                                         last;
 503                                 }
 504                         };
 505                 };
 506
 507                 $readwrote_stuff_this_time = 0;
 508                 trace("select waiting for ".($sout->count())." fds.");
 509                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
 510                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 511                 for my $wfd (@$readyw) {
 512                         $readwrote_stuff_this_time = 1;
 513                         if (length($in) != $offset) {
 514                                 trace("writing to $wfd.");
 515                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 516                                 $offset += $written;
 517                         };
 518                         if ($offset == length($in)) {
 519                                 trace("writing to $wfd done.");
 520                                 unless ($options{'nocloseinput'}) {
 521                                         close $wfd;
 522                                         trace("$wfd closed.");
 523                                 };
 524                                 $sin->remove($wfd);
 525                                 $sin = undef;
 526                         }
 527                 }
 528
 529                 next unless (defined(@$readyr)); # Wait some more.
 530
 531                 for my $rfd (@$readyr) {
 532                         $readwrote_stuff_this_time = 1;
 533                         if ($rfd->eof) {
 534                                 trace("reading from $rfd done.");
 535                                 $sout->remove($rfd);
 536                                 close($rfd);
 537                                 next;
 538                         }
 539                         trace("reading from $rfd.");
 540                         if ($rfd == $stdoutfd) {
 541                                 $stdout .= <$rfd>;
 542                                 trace2("stdout is now $stdout\n================");
 543                                 next;
 544                         }
 545                         if (defined $statusfd && $rfd == $statusfd) {
 546                                 $status .= <$rfd>;
 547                                 trace2("status is now $status\n================");
 548                                 next;
 549                         }
 550                         if ($rfd == $stderrfd) {
 551                                 $stderr .= <$rfd>;
 552                                 trace2("stderr is now $stderr\n================");
 553                                 next;
 554                         }
 555                 }
 556         }
 557         trace("readwrite_gpg done.");
 558         return ($stdout, $stderr, $status);
 559 };
 560
 561 sub ask($$;$$) {
 562         my ($question, $default, $forceyes, $forceno) = @_;
 563         my $answer;
 564         my $yn = $default ? '[Y/n]' : '[y/N]';
 565         while (1) {
 566                 print $question,' ',$yn, ' ';
 567                 if ($forceyes && $forceno) {
 568                         print "$default (from config/command line)\n";
 569                         return $default;
 570                 };
 571                 if ($forceyes) {
 572                         print "YES (from config/command line)\n";
 573                         return 1;
 574                 };
 575                 if ($forceno) {
 576                         print "NO (from config/command line)\n";
 577                         return 0;
 578                 };
 579
 580                 $answer = <STDIN>;
 581                 if (!defined $answer) {
 582                         $OUTPUT_AUTOFLUSH = 1;
 583                         die "\n\n".
 584                             "End of STDIN reached.  Are you using xargs?  Caff wants to read from STDIN,\n".
 585                             "so you can't really use it with xargs.  A patch against caff to read from\n".
 586                             "the terminal would be appreciated.\n".
 587                             "For now instead of   cat keys | xargs caff  do  caff `cat keys`\n";
 588                 };
 589                 chomp $answer;
 590                 last if ((length $answer == 0) || ($answer =~ m/^[yYnN]$/) );
 591                 print "What about $yn is so hard to understand?\nAnswer with either 'n' or 'y' or just press enter for the default.\n";
 592                 sleep 1;
 593         };
 594         my $result = $default;
 595         $result = 1 if $answer =~ /y/i;
 596         $result = 0 if $answer =~ /n/i;
 597         return $result;
 598 };
 599
 600
 601
 602
 603
 604 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 605 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 606 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 607 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 608 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 609
 610 load_config;
 611 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.";
 612
 613 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 614 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 615
 616 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 617 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 618
 619 my $NOW = time;
 620 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 621 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 622
 623
 624 sub version($) {
 625         my ($fd) = @_;
 626         print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.\n";
 627 };
 628
 629 sub usage($$) {
 630         my ($fd, $exitcode) = @_;
 631         version($fd);
 632         print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
 633         print $fd "Consult the manual page for more information.\n";
 634         exit $exitcode;
 635 };
 636
 637 ######
 638 # export key $keyid from $gnupghome
 639 ######
 640 sub export_key($$) {
 641         my ($gnupghome, $keyid) = @_;
 642
 643         my $gpg = GnuPG::Interface->new();
 644         $gpg->call( $CONFIG{'gpg'} );
 645         if (defined $gnupghome) {
 646                 $gpg->options->hash_init(
 647                         'homedir' => $gnupghome,
 648                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
 649                         'armor' => 1 );
 650         } else {
 651                 $gpg->options->hash_init(
 652                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
 653                         'armor' => 1 );
 654         };
 655         $gpg->options->meta_interactive( 0 );
 656         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 657         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 658         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 659         waitpid $pid, 0;
 660
 661         return $stdout;
 662 };
 663
 664 ######
 665 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
 666 ######
 667 sub import_key($$) {
 668         my ($gnupghome, $asciikey) = @_;
 669
 670         my $gpg = GnuPG::Interface->new();
 671         $gpg->call( $CONFIG{'gpg'} );
 672         $gpg->options->hash_init(
 673                 'homedir' => $gnupghome,
 674                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ] );
 675         $gpg->options->meta_interactive( 0 );
 676         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 677         my $pid = $gpg->import_keys(handles => $handles);
 678         my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 679         waitpid $pid, 0;
 680
 681         if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 682                 return undef;
 683         };
 684         return 1;
 685 };
 686
 687
 688 ######
 689 # Send an email to $address.  If $can_encrypt is true then the mail
 690 # will be PGP/MIME encrypted to $longkeyid.
 691 #
 692 # $longkeyid, $uid, and @attached will be used in the email and the template.
 693 ######
 694 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 695 sub send_mail($$$@) {
 696         my ($address, $can_encrypt, $key_id, @keys) = @_;
 697
 698         my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
 699             or die "Error creating template: $Text::Template::ERROR";
 700
 701         my @uids;
 702         for my $key (@keys) {
 703             push @uids, $key->{'text'};
 704         };
 705         my $message = $template->fill_in(HASH => { key => $key_id,
 706                                                    uids => \@uids,
 707                                                    owner => $CONFIG{'owner'}})
 708             or die "Error filling template in: $Text::Template::ERROR";
 709
 710         my $message_entity = MIME::Entity->build(
 711                 Type        => "text/plain",
 712                 Charset     => "utf-8",
 713                 Disposition => 'inline',
 714                 Data        => $message);
 715
 716         my @key_entities;
 717         for my $key (@keys) {
 718                 $message_entity->attach(
 719                         Type        => "application/pgp-keys",
 720                         Disposition => 'attachment',
 721                         Encoding    => "7bit",
 722                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).'), signed by 0x'.$CONFIG{'keyid'}[0],
 723                         Data        => $key->{'key'},
 724                         Filename    => "0x$key_id.".$key->{'serial'}.".signed-by-0x".$CONFIG{'keyid'}[0].".asc");
 725         };
 726
 727         if ($can_encrypt) {
 728                 my $message = $message_entity->stringify();
 729
 730                 my $gpg = GnuPG::Interface->new();
 731                 $gpg->call( $CONFIG{'gpg'} );
 732                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 733                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
 734                         'armor' => 1 );
 735                 $gpg->options->meta_interactive( 0 );
 736                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 737                 $gpg->options->push_recipients( $key_id );
 738                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 739                 my $pid = $gpg->encrypt(handles => $handles);
 740                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 741                 waitpid $pid, 0;
 742                 if ($stdout eq '') {
 743                         warn ("No data from gpg for list-key $key_id\n");
 744                         next;
 745                 };
 746                 $message = $stdout;
 747
 748                 $message_entity = MIME::Entity->build(
 749                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"',
 750                         Encoding    => '7bit');
 751
 752                 $message_entity->attach(
 753                         Type        => "application/pgp-encrypted",
 754                         Disposition => 'attachment',
 755                         Encoding    => "7bit",
 756                         Data        => "Version: 1\n");
 757
 758                 $message_entity->attach(
 759                         Type        => "application/octet-stream",
 760                         Filename    => 'msg.asc',
 761                         Disposition => 'inline',
 762                         Encoding    => "7bit",
 763                         Data        => $message);
 764         };
 765
 766         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 767         $message_entity->head->add("To", $address);
 768         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 769         $message_entity->head->add("Reply-To", $CONFIG{'reply-to'}) if defined $CONFIG{'reply-to'};
 770         $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
 771         $message_entity->head->add("User-Agent", $USER_AGENT);
 772         $message_entity->send();
 773         $message_entity->stringify();
 774 };
 775
 776 ######
 777 # clean up a UID so that it can be used on the FS.
 778 ######
 779 sub sanitize_uid($) {
 780         my ($uid) = @_;
 781
 782         my $good_uid = $uid;
 783         $good_uid =~ tr#/:\\#_#;
 784         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 785         return $good_uid;
 786 };
 787
 788 sub delete_signatures($$$$$$) {
 789         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
 790
 791         my $signed_by_me = 0;
 792
 793         my ($stdout, $stderr, $status) =
 794                 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 795
 796         while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 797                 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 798                 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 799                 $stdout =~ s/\n/\\n/g;
 800                 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 801                 my $line = pop @sigline;
 802                 my $answer = "no";
 803                 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 804                         debug("[sigremoval] doing line $line.");
 805                         my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 806                         if ($signer eq $longkeyid) {
 807                                 debug("[sigremoval] selfsig ($signer).");
 808                                 $answer = "no";
 809                         } elsif (grep { $signer eq $_ } @{$keyids}) {
 810                                 debug("[sigremoval] signed by us ($signer).");
 811                                 $answer = "no";
 812                                 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 813                         } else {
 814                                 debug("[sigremoval] not interested in that sig ($signer).");
 815                                 $answer = "yes";
 816                         };
 817                 } else {
 818                         debug("[sigremoval] no sig line here, only got: ".$stdout);
 819                 };
 820                 ($stdout, $stderr, $status) =
 821                         readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 822         };
 823
 824         return $signed_by_me;
 825 };
 826
 827
 828
 829 my $USER;
 830 my @KEYIDS;
 831 my $params;
 832
 833 Getopt::Long::config('bundling');
 834 if (!GetOptions (
 835         '-h'              =>  \$params->{'help'},
 836         '--help'          =>  \$params->{'help'},
 837         '--version'       =>  \$params->{'version'},
 838         '-V'              =>  \$params->{'version'},
 839         '-u=s'            =>  \$params->{'local-user'},
 840         '--local-user=s'  =>  \$params->{'local-user'},
 841         '-e'              =>  \$params->{'export-old'},
 842         '--export-old'    =>  \$params->{'export-old'},
 843         '-E'              =>  \$params->{'no-export-old'},
 844         '--no-export-old' =>  \$params->{'no-export-old'},
 845         '-m'              =>  \$params->{'mail'},
 846         '--mail'          =>  \$params->{'mail'},
 847         '-M'              =>  \$params->{'no-mail'},
 848         '--no-mail'       =>  \$params->{'no-mail'},
 849         '-R'              =>  \$params->{'no-download'},
 850         '--no-download'   =>  \$params->{'no-download'},
 851         '-S'              =>  \$params->{'no-sign'},
 852         '--no-sign'       =>  \$params->{'no-sign'},
 853         '--key-file=s@'   =>  \$params->{'key-files'},
 854         )) {
 855         usage(\*STDERR, 1);
 856 };
 857 if ($params->{'help'}) {
 858         usage(\*STDOUT, 0);
 859 };
 860 if ($params->{'version'}) {
 861         version(\*STDOUT);
 862         exit(0);
 863 };
 864 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
 865
 866
 867
 868 if ($params->{'local-user'}) {
 869         $USER = $params->{'local-user'};
 870         $USER =~ s/^0x//i;
 871         unless ($USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
 872                 print STDERR "-u $USER is not a keyid.\n";
 873                 usage(\*STDERR, 1);
 874         };
 875         $USER = uc($USER);
 876 };
 877
 878 for my $keyid (@ARGV) {
 879         $keyid =~ s/^0x//i;
 880         unless ($keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i) {
 881                 if ($keyid =~ /^[A-F0-9]{32}$/) {
 882                         info("Ignoring v3 fingerprint $keyid.  v3 keys are obsolete.");
 883                         next;
 884                 };
 885                 print STDERR "$keyid is not a keyid.\n";
 886                 usage(\*STDERR, 1);
 887         };
 888         push @KEYIDS, uc($keyid);
 889 };
 890
 891 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
 892 $CONFIG{'no-mail'}     = $params->{'no-mail'}     if defined $params->{'no-mail'};
 893 $CONFIG{'mail'}        = $params->{'mail'}        if defined $params->{'mail'};
 894 $CONFIG{'no-sign'}     = $params->{'no-sign'}     if defined $params->{'no-sign'};
 895 push @{$CONFIG{'key-files'}}, @{$params->{'key-files'}} if defined $params->{'key-files'};
 896
 897
 898 #################
 899 # import own keys
 900 #################
 901 for my $keyid (@{$CONFIG{'keyid'}}) {
 902         my $gpg = GnuPG::Interface->new();
 903         $gpg->call( $CONFIG{'gpg'} );
 904         $gpg->options->hash_init(
 905                 'homedir' => $GNUPGHOME,
 906                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --fast-list-mode } ] );
 907         $gpg->options->meta_interactive( 0 );
 908         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 909         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $keyid);
 910         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 911         waitpid $pid, 0;
 912
 913         if ($stdout eq '') {
 914                 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
 915         };
 916         unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 917                 info("Key $keyid not found in caff's home.  Getting it from your normal GnuPGHome.");
 918                 my $key = export_key(undef, $keyid);
 919                 if (!defined $key || $key eq '') {
 920                         warn ("Did not get key $keyid from your normal GnuPGHome\n");
 921                         next;
 922                 };
 923                 my $result = import_key($GNUPGHOME, $key);
 924                 unless ($result) {
 925                         warn ("Could not import $keyid into caff's gnupghome.\n");
 926                         next;
 927                 };
 928         }
 929 }
 930
 931 ########################
 932 # import keys from files
 933 ########################
 934 foreach my $keyfile (@{$CONFIG{'key-files'}}) {
 935     my $gpg = GnuPG::Interface->new();
 936     $gpg->call( $CONFIG{'gpg'} );
 937     $gpg->options->hash_init('homedir' => $GNUPGHOME);
 938     $gpg->options->meta_interactive( 0 );
 939     my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 940     my $pid = $gpg->import_keys(handles => $handles, command_args => $keyfile);
 941     my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 942     info ("Importing keys from $keyfile");
 943     waitpid $pid, 0;
 944     if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 945         warn $stderr;
 946     }
 947 }
 948
 949 #############################
 950 # receive keys from keyserver
 951 #############################
 952 my @keyids_ok;
 953 if ($CONFIG{'no-download'}) {
 954         @keyids_ok = @KEYIDS;
 955 } else {
 956         info ("fetching keys, this will take a while...");
 957
 958         my $gpg = GnuPG::Interface->new();
 959         $gpg->call( $CONFIG{'gpg'} );
 960         $gpg->options->hash_init(
 961                 'homedir' => $GNUPGHOME,
 962                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always }, '--keyserver='.$CONFIG{'keyserver'} ] );
 963         $gpg->options->meta_interactive( 0 );
 964         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 965         my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 966         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 967         waitpid $pid, 0;
 968
 969 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 970 # [GNUPG:] NODATA 1
 971 # [GNUPG:] NODATA 1
 972 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 973         my %local_keyids = map { $_ => 1 } @KEYIDS;
 974         my $had_v3_keys = 0;
 975         for my $line (split /\n/, $status) {
 976                 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 977                         my $imported_key = $1;
 978                         my $whole_fpr = $imported_key;
 979                         my $long_keyid = substr($imported_key, -16);
 980                         my $short_keyid = substr($imported_key, -8);
 981                         my $speced_key;
 982                         for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
 983                                 $speced_key = $spec if $local_keyids{$spec};
 984                         };
 985                         unless ($speced_key) {
 986                             notice ("Imported unexpected key; got: $imported_key\n");
 987                             next;
 988                         };
 989                         debug ("Imported $imported_key for $speced_key");
 990                         delete $local_keyids{$speced_key};
 991                         unshift @keyids_ok, $imported_key;
 992                 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
 993                 } elsif ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/) {
 994                         my $imported_key = $1;
 995                         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.");
 996                         $had_v3_keys = 1;
 997                 } else {
 998                         notice ("got unknown reply from gpg: $line");
 999                 }
1000         };
1001         if (scalar %local_keyids) {
1002                 notice ("Import failed for: ". (join ' ', keys %local_keyids)."." . ($had_v3_keys ? " (Or maybe it's one of those ugly v3 keys?)" :  ""));
1003                 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
1004         }
1005 };
1006
1007 unless (@keyids_ok) {
1008         notice ("No keys to sign found");
1009         exit 0;
1010 }
1011
1012 ###########
1013 # sign keys
1014 ###########
1015 if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
1016         $CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
1017 }
1018
1019 unless ($CONFIG{'no-sign'}) {
1020         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
1021         for my $keyid (@keyids_ok) {
1022                 my @command;
1023                 push @command, $CONFIG{'gpg-sign'};
1024                 push @command, '--local-user', $USER if (defined $USER);
1025                 push @command, "--homedir=$GNUPGHOME";
1026                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
1027                 push @command, '--no-auto-check-trustdb';
1028                 push @command, '--trust-model=always';
1029                 push @command, '--edit', $keyid;
1030                 push @command, 'sign';
1031                 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
1032                 print join(' ', @command),"\n";
1033                 system (@command);
1034         };
1035 };
1036
1037 ##################
1038 # export and prune
1039 ##################
1040 KEYS:
1041 for my $keyid (@keyids_ok) {
1042         # get key listing
1043         #################
1044         my $gpg = GnuPG::Interface->new();
1045         $gpg->call( $CONFIG{'gpg'} );
1046         $gpg->options->hash_init(
1047                 'homedir' => $GNUPGHOME,
1048                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
1049         $gpg->options->meta_interactive( 0 );
1050         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1051         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
1052         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
1053         waitpid $pid, 0;
1054         if ($stdout eq '') {
1055                 warn ("No data from gpg for list-key $keyid\n");
1056                 next;
1057         };
1058         my @publine = grep { /^pub/ } (split /\n/, $stdout);
1059         if (scalar @publine == 0) {
1060                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
1061                 next;
1062         };
1063         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
1064         if (scalar @publine > 0) {
1065                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
1066                 next;
1067         };
1068         unless (defined $longkeyid) {
1069                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
1070                 next;
1071         };
1072         unless (defined $flags) {
1073                 warn ("Didn't find flags in --list-key of key $keyid.\n");
1074                 next;
1075         };
1076         my $can_encrypt = $flags =~ /E/;
1077
1078         # export the key
1079         ################
1080         my $asciikey = export_key($GNUPGHOME, $keyid);
1081         if ($asciikey eq '') {
1082                 warn ("No data from gpg for export $keyid\n");
1083                 next;
1084         };
1085
1086         my @UIDS;
1087         my $uid_number = 0;
1088         while (1) {
1089                 my $this_uid_text = '';
1090                 $uid_number++;
1091                 debug("Doing key $keyid, uid $uid_number");
1092                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
1093
1094                 # import into temporary gpghome
1095                 ###############################
1096                 my $result = import_key($tempdir, $asciikey);
1097                 unless ($result) {
1098                         warn ("Could not import $keyid into temporary gnupg.\n");
1099                         next;
1100                 };
1101
1102                 # prune it
1103                 ##########
1104                 $gpg = GnuPG::Interface->new();
1105                 $gpg->call( $CONFIG{'gpg-delsig'} );
1106                 $gpg->options->hash_init(
1107                         'homedir' => $tempdir,
1108                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --command-fd=0 --no-tty } ] );
1109                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1110                 $pid = $gpg->wrap_call(
1111                         commands     => [ '--edit' ],
1112                         command_args => [ $keyid ],
1113                         handles      => $handles );
1114
1115                 debug("Starting edit session");
1116                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1117
1118                 # delete other uids
1119                 ###################
1120                 my $number_of_subkeys = 0;
1121                 my $i = 1;
1122                 my $have_one = 0;
1123                 my $is_uat = 0;
1124                 my $delete_some = 0;
1125                 debug("Parsing stdout output.");
1126                 for my $line (split /\n/, $stdout) {
1127                         debug("Checking line $line");
1128                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
1129                         if ($type eq 'sub') {
1130                                 $number_of_subkeys++;
1131                         };
1132                         next unless ($type eq 'uid' || $type eq 'uat');
1133                         debug("line is interesting.");
1134                         if ($uid_number != $i) {
1135                                 debug("mark for deletion.");
1136                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1137                                 $delete_some++;
1138                         } else {
1139                                 debug("keep it.");
1140                                 $have_one = 1;
1141                                 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
1142                                 $is_uat = $type eq 'uat';
1143                         };
1144                         $i++;
1145                 };
1146                 debug("Parsing stdout output done.");
1147                 unless ($have_one) {
1148                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
1149                         info("key $keyid done.");
1150                         last;
1151                 };
1152
1153                 my $prune_some_sigs_on_uid;
1154                 my $prune_all_sigs_on_uid;
1155                 if ($is_uat) {
1156                         debug("handling attribute userid of key $keyid.");
1157                         if ($uid_number == 1) {
1158                                 debug(" attribute userid is #1, unmarking #2 for deletion.");
1159                                 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1160                                 $delete_some--;
1161                                 $prune_some_sigs_on_uid = 1;
1162                                 $prune_all_sigs_on_uid = 2;
1163                         } else {
1164                                 debug("attribute userid is not #1, unmarking #1 for deletion.");
1165                                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1166                                 $delete_some--;
1167                                 $prune_some_sigs_on_uid = 2;
1168                                 $prune_all_sigs_on_uid = 1;
1169                         };
1170                 } else {
1171                         $prune_some_sigs_on_uid = 1;
1172                 };
1173
1174                 if ($delete_some) {
1175                         debug("need to delete $delete_some uids.");
1176                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
1177                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1178                 };
1179
1180                 # delete subkeys
1181                 ################
1182                 if ($number_of_subkeys > 0) {
1183                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
1184                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1185                         };
1186                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
1187                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1188                 };
1189
1190                 # delete signatures
1191                 ###################
1192                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1193                 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
1194                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1195                 if (defined $prune_all_sigs_on_uid) {
1196                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1197                         delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
1198                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1199                 };
1200
1201
1202                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1203                 waitpid $pid, 0;
1204
1205                 my $asciikey = export_key($tempdir, $keyid);
1206                 if ($asciikey eq '') {
1207                         warn ("No data from gpg for export $keyid\n");
1208                         next;
1209                 };
1210
1211                 if ($signed_by_me) {
1212                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1213                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1214                                 next unless $write;
1215                         };
1216                         my $keydir = "$KEYSBASE/$DATE_STRING";
1217                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1218
1219                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1220                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1221                         print KEY $asciikey;
1222                         close KEY;
1223
1224                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1225
1226                         info("$longkeyid $uid_number $this_uid_text done.");
1227                 } else {
1228                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1229                 };
1230         };
1231
1232         if (scalar @UIDS == 0) {
1233                 info("found no signed uids for $keyid");
1234         } else {
1235                 next if $CONFIG{'no-mail'}; # do not send mail
1236
1237                 my @attached;
1238                 for my $uid (@UIDS) {
1239                         trace("UID: $uid->{'text'}\n");
1240                         if ($uid->{'is_uat'}) {
1241                                 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1242                                 push @attached, $uid if $attach;
1243                         } elsif ($uid->{'text'} !~ /@/) {
1244                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1245                                 push @attached, $uid if $attach;
1246                         };
1247                 };
1248
1249                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1250                 for my $uid (@UIDS) {
1251                         if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1252                                 my $address = $uid->{'text'};
1253                                 $address =~ s/.*<(.*)>.*/$1/;
1254                                 if (ask("Mail signature for $uid->{'text'} to '$address'?", 1, $CONFIG{'mail'})) {
1255                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1256
1257                                         my $keydir = "$KEYSBASE/$DATE_STRING";
1258                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1259                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1260                                         print KEY $mail;
1261                                         close KEY;
1262                                 };
1263                         };
1264                 };
1265         };
1266
1267 };