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
 751                 $message_entity->attach(
 752                         Type        => "application/pgp-encrypted",
 753                         Disposition => 'attachment',
 754                         Encoding    => "7bit",
 755                         Data        => "Version: 1\n");
 756
 757                 $message_entity->attach(
 758                         Type        => "application/octet-stream",
 759                         Filename    => 'msg.asc',
 760                         Disposition => 'inline',
 761                         Encoding    => "7bit",
 762                         Data        => $message);
 763         };
 764
 765         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 766         $message_entity->head->add("To", $address);
 767         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 768         $message_entity->head->add("Reply-To", $CONFIG{'reply-to'}) if defined $CONFIG{'reply-to'};
 769         $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
 770         $message_entity->head->add("User-Agent", $USER_AGENT);
 771         $message_entity->send();
 772         $message_entity->stringify();
 773 };
 774
 775 ######
 776 # clean up a UID so that it can be used on the FS.
 777 ######
 778 sub sanitize_uid($) {
 779         my ($uid) = @_;
 780
 781         my $good_uid = $uid;
 782         $good_uid =~ tr#/:\\#_#;
 783         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 784         return $good_uid;
 785 };
 786
 787 sub delete_signatures($$$$$$) {
 788         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
 789
 790         my $signed_by_me = 0;
 791
 792         my ($stdout, $stderr, $status) =
 793                 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 794
 795         while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 796                 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 797                 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 798                 $stdout =~ s/\n/\\n/g;
 799                 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 800                 my $line = pop @sigline;
 801                 my $answer = "no";
 802                 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 803                         debug("[sigremoval] doing line $line.");
 804                         my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 805                         if ($signer eq $longkeyid) {
 806                                 debug("[sigremoval] selfsig ($signer).");
 807                                 $answer = "no";
 808                         } elsif (grep { $signer eq $_ } @{$keyids}) {
 809                                 debug("[sigremoval] signed by us ($signer).");
 810                                 $answer = "no";
 811                                 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 812                         } else {
 813                                 debug("[sigremoval] not interested in that sig ($signer).");
 814                                 $answer = "yes";
 815                         };
 816                 } else {
 817                         debug("[sigremoval] no sig line here, only got: ".$stdout);
 818                 };
 819                 ($stdout, $stderr, $status) =
 820                         readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 821         };
 822
 823         return $signed_by_me;
 824 };
 825
 826
 827
 828 my $USER;
 829 my @KEYIDS;
 830 my $params;
 831
 832 Getopt::Long::config('bundling');
 833 if (!GetOptions (
 834         '-h'              =>  \$params->{'help'},
 835         '--help'          =>  \$params->{'help'},
 836         '--version'       =>  \$params->{'version'},
 837         '-V'              =>  \$params->{'version'},
 838         '-u=s'            =>  \$params->{'local-user'},
 839         '--local-user=s'  =>  \$params->{'local-user'},
 840         '-e'              =>  \$params->{'export-old'},
 841         '--export-old'    =>  \$params->{'export-old'},
 842         '-E'              =>  \$params->{'no-export-old'},
 843         '--no-export-old' =>  \$params->{'no-export-old'},
 844         '-m'              =>  \$params->{'mail'},
 845         '--mail'          =>  \$params->{'mail'},
 846         '-M'              =>  \$params->{'no-mail'},
 847         '--no-mail'       =>  \$params->{'no-mail'},
 848         '-R'              =>  \$params->{'no-download'},
 849         '--no-download'   =>  \$params->{'no-download'},
 850         '-S'              =>  \$params->{'no-sign'},
 851         '--no-sign'       =>  \$params->{'no-sign'},
 852         '--key-file=s@'   =>  \$params->{'key-files'},
 853         )) {
 854         usage(\*STDERR, 1);
 855 };
 856 if ($params->{'help'}) {
 857         usage(\*STDOUT, 0);
 858 };
 859 if ($params->{'version'}) {
 860         version(\*STDOUT);
 861         exit(0);
 862 };
 863 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
 864
 865
 866
 867 if ($params->{'local-user'}) {
 868         $USER = $params->{'local-user'};
 869         $USER =~ s/^0x//i;
 870         unless ($USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
 871                 print STDERR "-u $USER is not a keyid.\n";
 872                 usage(\*STDERR, 1);
 873         };
 874         $USER = uc($USER);
 875 };
 876
 877 for my $keyid (@ARGV) {
 878         $keyid =~ s/^0x//i;
 879         unless ($keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i) {
 880                 if ($keyid =~ /^[A-F0-9]{32}$/) {
 881                         info("Ignoring v3 fingerprint $keyid.  v3 keys are obsolete.");
 882                         next;
 883                 };
 884                 print STDERR "$keyid is not a keyid.\n";
 885                 usage(\*STDERR, 1);
 886         };
 887         push @KEYIDS, uc($keyid);
 888 };
 889
 890 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
 891 $CONFIG{'no-mail'}     = $params->{'no-mail'}     if defined $params->{'no-mail'};
 892 $CONFIG{'mail'}        = $params->{'mail'}        if defined $params->{'mail'};
 893 $CONFIG{'no-sign'}     = $params->{'no-sign'}     if defined $params->{'no-sign'};
 894 push @{$CONFIG{'key-files'}}, @{$params->{'key-files'}} if defined $params->{'key-files'};
 895
 896
 897 #################
 898 # import own keys
 899 #################
 900 for my $keyid (@{$CONFIG{'keyid'}}) {
 901         my $gpg = GnuPG::Interface->new();
 902         $gpg->call( $CONFIG{'gpg'} );
 903         $gpg->options->hash_init(
 904                 'homedir' => $GNUPGHOME,
 905                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --fast-list-mode } ] );
 906         $gpg->options->meta_interactive( 0 );
 907         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 908         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $keyid);
 909         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 910         waitpid $pid, 0;
 911
 912         if ($stdout eq '') {
 913                 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
 914         };
 915         unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 916                 info("Key $keyid not found in caff's home.  Getting it from your normal GnuPGHome.");
 917                 my $key = export_key(undef, $keyid);
 918                 if (!defined $key || $key eq '') {
 919                         warn ("Did not get key $keyid from your normal GnuPGHome\n");
 920                         next;
 921                 };
 922                 my $result = import_key($GNUPGHOME, $key);
 923                 unless ($result) {
 924                         warn ("Could not import $keyid into caff's gnupghome.\n");
 925                         next;
 926                 };
 927         }
 928 }
 929
 930 ########################
 931 # import keys from files
 932 ########################
 933 foreach my $keyfile (@{$CONFIG{'key-files'}}) {
 934     my $gpg = GnuPG::Interface->new();
 935     $gpg->call( $CONFIG{'gpg'} );
 936     $gpg->options->hash_init('homedir' => $GNUPGHOME);
 937     $gpg->options->meta_interactive( 0 );
 938     my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 939     my $pid = $gpg->import_keys(handles => $handles, command_args => $keyfile);
 940     my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 941     info ("Importing keys from $keyfile");
 942     waitpid $pid, 0;
 943     if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 944         warn $stderr;
 945     }
 946 }
 947
 948 #############################
 949 # receive keys from keyserver
 950 #############################
 951 my @keyids_ok;
 952 if ($CONFIG{'no-download'}) {
 953         @keyids_ok = @KEYIDS;
 954 } else {
 955         info ("fetching keys, this will take a while...");
 956
 957         my $gpg = GnuPG::Interface->new();
 958         $gpg->call( $CONFIG{'gpg'} );
 959         $gpg->options->hash_init(
 960                 'homedir' => $GNUPGHOME,
 961                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always }, '--keyserver='.$CONFIG{'keyserver'} ] );
 962         $gpg->options->meta_interactive( 0 );
 963         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 964         my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 965         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 966         waitpid $pid, 0;
 967
 968 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 969 # [GNUPG:] NODATA 1
 970 # [GNUPG:] NODATA 1
 971 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 972         my %local_keyids = map { $_ => 1 } @KEYIDS;
 973         my $had_v3_keys = 0;
 974         for my $line (split /\n/, $status) {
 975                 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 976                         my $imported_key = $1;
 977                         my $whole_fpr = $imported_key;
 978                         my $long_keyid = substr($imported_key, -16);
 979                         my $short_keyid = substr($imported_key, -8);
 980                         my $speced_key;
 981                         for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
 982                                 $speced_key = $spec if $local_keyids{$spec};
 983                         };
 984                         unless ($speced_key) {
 985                             notice ("Imported unexpected key; got: $imported_key\n");
 986                             next;
 987                         };
 988                         debug ("Imported $imported_key for $speced_key");
 989                         delete $local_keyids{$speced_key};
 990                         unshift @keyids_ok, $imported_key;
 991                 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
 992                 } elsif ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/) {
 993                         my $imported_key = $1;
 994                         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.");
 995                         $had_v3_keys = 1;
 996                 } else {
 997                         notice ("got unknown reply from gpg: $line");
 998                 }
 999         };
1000         if (scalar %local_keyids) {
1001                 notice ("Import failed for: ". (join ' ', keys %local_keyids)."." . ($had_v3_keys ? " (Or maybe it's one of those ugly v3 keys?)" :  ""));
1002                 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
1003         }
1004 };
1005
1006 unless (@keyids_ok) {
1007         notice ("No keys to sign found");
1008         exit 0;
1009 }
1010
1011 ###########
1012 # sign keys
1013 ###########
1014 if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
1015         $CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
1016 }
1017
1018 unless ($CONFIG{'no-sign'}) {
1019         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
1020         for my $keyid (@keyids_ok) {
1021                 my @command;
1022                 push @command, $CONFIG{'gpg-sign'};
1023                 push @command, '--local-user', $USER if (defined $USER);
1024                 push @command, "--homedir=$GNUPGHOME";
1025                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
1026                 push @command, '--no-auto-check-trustdb';
1027                 push @command, '--trust-model=always';
1028                 push @command, '--edit', $keyid;
1029                 push @command, 'sign';
1030                 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
1031                 print join(' ', @command),"\n";
1032                 system (@command);
1033         };
1034 };
1035
1036 ##################
1037 # export and prune
1038 ##################
1039 KEYS:
1040 for my $keyid (@keyids_ok) {
1041         # get key listing
1042         #################
1043         my $gpg = GnuPG::Interface->new();
1044         $gpg->call( $CONFIG{'gpg'} );
1045         $gpg->options->hash_init(
1046                 'homedir' => $GNUPGHOME,
1047                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
1048         $gpg->options->meta_interactive( 0 );
1049         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1050         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
1051         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
1052         waitpid $pid, 0;
1053         if ($stdout eq '') {
1054                 warn ("No data from gpg for list-key $keyid\n");
1055                 next;
1056         };
1057         my @publine = grep { /^pub/ } (split /\n/, $stdout);
1058         if (scalar @publine == 0) {
1059                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
1060                 next;
1061         };
1062         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
1063         if (scalar @publine > 0) {
1064                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
1065                 next;
1066         };
1067         unless (defined $longkeyid) {
1068                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
1069                 next;
1070         };
1071         unless (defined $flags) {
1072                 warn ("Didn't find flags in --list-key of key $keyid.\n");
1073                 next;
1074         };
1075         my $can_encrypt = $flags =~ /E/;
1076
1077         # export the key
1078         ################
1079         my $asciikey = export_key($GNUPGHOME, $keyid);
1080         if ($asciikey eq '') {
1081                 warn ("No data from gpg for export $keyid\n");
1082                 next;
1083         };
1084
1085         my @UIDS;
1086         my $uid_number = 0;
1087         while (1) {
1088                 my $this_uid_text = '';
1089                 $uid_number++;
1090                 debug("Doing key $keyid, uid $uid_number");
1091                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
1092
1093                 # import into temporary gpghome
1094                 ###############################
1095                 my $result = import_key($tempdir, $asciikey);
1096                 unless ($result) {
1097                         warn ("Could not import $keyid into temporary gnupg.\n");
1098                         next;
1099                 };
1100
1101                 # prune it
1102                 ##########
1103                 $gpg = GnuPG::Interface->new();
1104                 $gpg->call( $CONFIG{'gpg-delsig'} );
1105                 $gpg->options->hash_init(
1106                         'homedir' => $tempdir,
1107                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --command-fd=0 --no-tty } ] );
1108                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1109                 $pid = $gpg->wrap_call(
1110                         commands     => [ '--edit' ],
1111                         command_args => [ $keyid ],
1112                         handles      => $handles );
1113
1114                 debug("Starting edit session");
1115                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1116
1117                 # delete other uids
1118                 ###################
1119                 my $number_of_subkeys = 0;
1120                 my $i = 1;
1121                 my $have_one = 0;
1122                 my $is_uat = 0;
1123                 my $delete_some = 0;
1124                 debug("Parsing stdout output.");
1125                 for my $line (split /\n/, $stdout) {
1126                         debug("Checking line $line");
1127                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
1128                         if ($type eq 'sub') {
1129                                 $number_of_subkeys++;
1130                         };
1131                         next unless ($type eq 'uid' || $type eq 'uat');
1132                         debug("line is interesting.");
1133                         if ($uid_number != $i) {
1134                                 debug("mark for deletion.");
1135                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1136                                 $delete_some++;
1137                         } else {
1138                                 debug("keep it.");
1139                                 $have_one = 1;
1140                                 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
1141                                 $is_uat = $type eq 'uat';
1142                         };
1143                         $i++;
1144                 };
1145                 debug("Parsing stdout output done.");
1146                 unless ($have_one) {
1147                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
1148                         info("key $keyid done.");
1149                         last;
1150                 };
1151
1152                 my $prune_some_sigs_on_uid;
1153                 my $prune_all_sigs_on_uid;
1154                 if ($is_uat) {
1155                         debug("handling attribute userid of key $keyid.");
1156                         if ($uid_number == 1) {
1157                                 debug(" attribute userid is #1, unmarking #2 for deletion.");
1158                                 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1159                                 $delete_some--;
1160                                 $prune_some_sigs_on_uid = 1;
1161                                 $prune_all_sigs_on_uid = 2;
1162                         } else {
1163                                 debug("attribute userid is not #1, unmarking #1 for deletion.");
1164                                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1165                                 $delete_some--;
1166                                 $prune_some_sigs_on_uid = 2;
1167                                 $prune_all_sigs_on_uid = 1;
1168                         };
1169                 } else {
1170                         $prune_some_sigs_on_uid = 1;
1171                 };
1172
1173                 if ($delete_some) {
1174                         debug("need to delete $delete_some uids.");
1175                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
1176                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1177                 };
1178
1179                 # delete subkeys
1180                 ################
1181                 if ($number_of_subkeys > 0) {
1182                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
1183                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1184                         };
1185                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
1186                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1187                 };
1188
1189                 # delete signatures
1190                 ###################
1191                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1192                 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
1193                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1194                 if (defined $prune_all_sigs_on_uid) {
1195                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1196                         delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
1197                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1198                 };
1199
1200
1201                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1202                 waitpid $pid, 0;
1203
1204                 my $asciikey = export_key($tempdir, $keyid);
1205                 if ($asciikey eq '') {
1206                         warn ("No data from gpg for export $keyid\n");
1207                         next;
1208                 };
1209
1210                 if ($signed_by_me) {
1211                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1212                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1213                                 next unless $write;
1214                         };
1215                         my $keydir = "$KEYSBASE/$DATE_STRING";
1216                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1217
1218                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1219                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1220                         print KEY $asciikey;
1221                         close KEY;
1222
1223                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1224
1225                         info("$longkeyid $uid_number $this_uid_text done.");
1226                 } else {
1227                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1228                 };
1229         };
1230
1231         if (scalar @UIDS == 0) {
1232                 info("found no signed uids for $keyid");
1233         } else {
1234                 next if $CONFIG{'no-mail'}; # do not send mail
1235
1236                 my @attached;
1237                 for my $uid (@UIDS) {
1238                         trace("UID: $uid->{'text'}\n");
1239                         if ($uid->{'is_uat'}) {
1240                                 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1241                                 push @attached, $uid if $attach;
1242                         } elsif ($uid->{'text'} !~ /@/) {
1243                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1244                                 push @attached, $uid if $attach;
1245                         };
1246                 };
1247
1248                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1249                 for my $uid (@UIDS) {
1250                         if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1251                                 my $address = $uid->{'text'};
1252                                 $address =~ s/.*<(.*)>.*/$1/;
1253                                 if (ask("Mail signature for $uid->{'text'} to '$address'?", 1, $CONFIG{'mail'})) {
1254                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1255
1256                                         my $keydir = "$KEYSBASE/$DATE_STRING";
1257                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1258                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1259                                         print KEY $mail;
1260                                         close KEY;
1261                                 };
1262                         };
1263                 };
1264         };
1265
1266 };