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