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/examples/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         if (defined $gecos) {
 318                 $gecos =~ s/,.*//;
 319
 320                 my $gpg = GnuPG::Interface->new();
 321                 $gpg->call( 'gpg' );
 322                 $gpg->options->hash_init(
 323                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
 324                 $gpg->options->meta_interactive( 0 );
 325                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 326                 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $gecos ]);
 327                 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 328                 waitpid $pid, 0;
 329
 330                 if ($stdout eq '') {
 331                         warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
 332                 };
 333
 334                 @keys = ($stdout =~ /^pub:[^r:]*:(?:[^:]*:){2,2}([^:]+):/mg);
 335                 unless (scalar @keys) {
 336                         info("Error: No keys were found using \"gpg --list-public-keys '$gecos'\".");
 337                         @keys = qw{0123456789abcdef 89abcdef76543210}
 338                 }
 339                 ($email) =  ($stdout =~ /^uid:.*<(.+?@.+?)>.*:/m);
 340                 unless (defined $email) {
 341                         info("Error: No email address was found using \"gpg --list-public-keys '$gecos'\".");
 342                         $email = $ENV{'LOGNAME'}.'@'.$hostname;
 343                 }
 344         } else {
 345                 $gecos = 'Unknown Caff User';
 346                 $email = $ENV{'LOGNAME'}.'@'.$hostname;
 347                 @keys = qw{0123456789abcdef 89abcdef76543210}
 348         };
 349
 350         return <<EOT;
 351 # .caffrc -- vim:syntax=perl:
 352 # This file is in perl(1) format - see caff(1) for details.
 353
 354 \$CONFIG{'owner'}       = '$gecos';
 355 \$CONFIG{'email'}       = '$email';
 356
 357 # you can get your long keyid from
 358 #   gpg --with-colons --list-key <yourkeyid|name|emailaddress..>
 359 #
 360 # if you have a v4 key, it will simply be the last 16 digits of
 361 # your fingerprint.
 362 #
 363 # Example:
 364 #   \$CONFIG{'keyid'}       = [ qw{FEDCBA9876543210} ];
 365 #  or, if you have more than one key:
 366 #   \$CONFIG{'keyid'}       = [ qw{0123456789ABCDEF 89ABCDEF76543210} ];
 367
 368 \$CONFIG{'keyid'}       = [ qw{@keys} ];
 369 EOT
 370 };
 371
 372 sub load_config() {
 373         my $config = $ENV{'HOME'} . '/.caffrc';
 374         unless (-f $config) {
 375                 print "No configfile $config present, I will use this template:\n";
 376                 my $template = generate_config();
 377                 print "$template\nPlease edit $config and run caff again.\n";
 378                 open F, ">$config" or die "$config: $!";
 379                 print F $template;
 380                 close F;
 381                 exit(1);
 382         }
 383         unless (scalar eval `cat $config`) {
 384                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 385         };
 386
 387         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 388         die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
 389         die ("email is not defined.\n") unless defined $CONFIG{'email'};
 390         die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
 391         die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 392         for my $keyid (@{$CONFIG{'keyid'}}) {
 393                 $keyid =~ /^[A-F0-9]{16}$/i or die ("key $keyid is not a long (16 digit) keyid.\n");
 394         };
 395         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 396         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 397         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 398         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 399         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 400         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 401         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 402         $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
 403         $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
 404         $CONFIG{'key-files'} = () unless defined $CONFIG{'key-files'};
 405         $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
 406 Hi,
 407
 408 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
 409 {foreach $uid (@uids) {
 410     $OUT .= "\t".$uid."\n";
 411 };} of your key {$key} signed by me.
 412
 413 Note that I did not upload your key to any keyservers.
 414 If you have multiple user ids, I sent the signature for each user id
 415 separately to that user id's associated email address. You can import
 416 the signatures by running each through `gpg --import`.
 417
 418 If you want this new signature to be available to others, please upload
 419 it yourself. With GnuPG this can be done using
 420         gpg --keyserver subkeys.pgp.net --send-key {$key}
 421
 422 If you have any questions, don't hesitate to ask.
 423
 424 Regards,
 425 {$owner}
 426 EOM
 427 };
 428
 429 sub make_gpg_fds() {
 430         my %fds = (
 431                 stdin => IO::Handle->new(),
 432                 stdout => IO::Handle->new(),
 433                 stderr => IO::Handle->new(),
 434                 status => IO::Handle->new() );
 435         my $handles = GnuPG::Handles->new( %fds );
 436         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 437 };
 438
 439 sub readwrite_gpg($$$$$%) {
 440         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 441
 442         trace("Entering readwrite_gpg.");
 443
 444         my ($first_line, undef) = split /\n/, $in;
 445         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 446
 447         local $INPUT_RECORD_SEPARATOR = undef;
 448         my $sout = IO::Select->new();
 449         my $sin = IO::Select->new();
 450         my $offset = 0;
 451
 452         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 453
 454         $inputfd->blocking(0);
 455         $stdoutfd->blocking(0);
 456         $statusfd->blocking(0) if defined $statusfd;
 457         $stderrfd->blocking(0);
 458         $sout->add($stdoutfd);
 459         $sout->add($stderrfd);
 460         $sout->add($statusfd) if defined $statusfd;
 461         $sin->add($inputfd);
 462
 463         my ($stdout, $stderr, $status) = ("", "", "");
 464         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 465         trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 466
 467         my $readwrote_stuff_this_time = 0;
 468         my $do_not_wait_on_select = 0;
 469         my ($readyr, $readyw, $written);
 470         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 471                 if (defined $exitwhenstatusmatches) {
 472                         if ($status =~ /$exitwhenstatusmatches/m) {
 473                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 474                                 if ($readwrote_stuff_this_time) {
 475                                         trace("read/write some more\n");
 476                                         $do_not_wait_on_select = 1;
 477                                 } else {
 478                                         trace("that's it in our while loop.\n");
 479                                         last;
 480                                 }
 481                         };
 482                 };
 483
 484                 $readwrote_stuff_this_time = 0;
 485                 trace("select waiting for ".($sout->count())." fds.");
 486                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
 487                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 488                 for my $wfd (@$readyw) {
 489                         $readwrote_stuff_this_time = 1;
 490                         if (length($in) != $offset) {
 491                                 trace("writing to $wfd.");
 492                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 493                                 $offset += $written;
 494                         };
 495                         if ($offset == length($in)) {
 496                                 trace("writing to $wfd done.");
 497                                 unless ($options{'nocloseinput'}) {
 498                                         close $wfd;
 499                                         trace("$wfd closed.");
 500                                 };
 501                                 $sin->remove($wfd);
 502                                 $sin = undef;
 503                         }
 504                 }
 505
 506                 next unless (defined(@$readyr)); # Wait some more.
 507
 508                 for my $rfd (@$readyr) {
 509                         $readwrote_stuff_this_time = 1;
 510                         if ($rfd->eof) {
 511                                 trace("reading from $rfd done.");
 512                                 $sout->remove($rfd);
 513                                 close($rfd);
 514                                 next;
 515                         }
 516                         trace("reading from $rfd.");
 517                         if ($rfd == $stdoutfd) {
 518                                 $stdout .= <$rfd>;
 519                                 trace2("stdout is now $stdout\n================");
 520                                 next;
 521                         }
 522                         if (defined $statusfd && $rfd == $statusfd) {
 523                                 $status .= <$rfd>;
 524                                 trace2("status is now $status\n================");
 525                                 next;
 526                         }
 527                         if ($rfd == $stderrfd) {
 528                                 $stderr .= <$rfd>;
 529                                 trace2("stderr is now $stderr\n================");
 530                                 next;
 531                         }
 532                 }
 533         }
 534         trace("readwrite_gpg done.");
 535         return ($stdout, $stderr, $status);
 536 };
 537
 538 sub ask($$;$$) {
 539         my ($question, $default, $forceyes, $forceno) = @_;
 540         my $answer;
 541         my $yn = $default ? '[Y/n]' : '[y/N]';
 542         while (1) {
 543                 print $question,' ',$yn, ' ';
 544                 if ($forceyes && $forceno) {
 545                         print "$default (from config/command line)\n";
 546                         return $default;
 547                 };
 548                 if ($forceyes) {
 549                         print "YES (from config/command line)\n";
 550                         return 1;
 551                 };
 552                 if ($forceno) {
 553                         print "NO (from config/command line)\n";
 554                         return 0;
 555                 };
 556
 557                 $answer = <STDIN>;
 558                 if (!defined $answer) {
 559                         $OUTPUT_AUTOFLUSH = 1;
 560                         die "\n\n".
 561                             "End of STDIN reached.  Are you using xargs?  Caff wants to read from STDIN,\n".
 562                             "so you can't really use it with xargs.  A patch against caff to read from\n".
 563                             "the terminal would be appreciated.\n".
 564                             "For now instead of   cat keys | xargs caff  do  caff `cat keys`\n";
 565                 };
 566                 chomp $answer;
 567                 last if ((length $answer == 0) || ($answer =~ m/^[yYnN]$/) );
 568                 print "What about $yn is so hard to understand?\nAnswer with either 'n' or 'y' or just press enter for the default.\n";
 569                 sleep 1;
 570         };
 571         my $result = $default;
 572         $result = 1 if $answer =~ /y/i;
 573         $result = 0 if $answer =~ /n/i;
 574         return $result;
 575 };
 576
 577
 578
 579
 580
 581 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 582 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 583 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 584 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 585 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 586
 587 load_config;
 588 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.";
 589
 590 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 591 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 592
 593 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 594 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 595
 596 my $NOW = time;
 597 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 598 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 599
 600
 601 sub version($) {
 602         my ($fd) = @_;
 603         print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.\n";
 604 };
 605
 606 sub usage($$) {
 607         my ($fd, $exitcode) = @_;
 608         version($fd);
 609         print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
 610         print $fd "Consult the manual page for more information.\n";
 611         exit $exitcode;
 612 };
 613
 614 ######
 615 # export key $keyid from $gnupghome
 616 ######
 617 sub export_key($$) {
 618         my ($gnupghome, $keyid) = @_;
 619
 620         my $gpg = GnuPG::Interface->new();
 621         $gpg->call( $CONFIG{'gpg'} );
 622         if (defined $gnupghome) {
 623                 $gpg->options->hash_init(
 624                         'homedir' => $gnupghome,
 625                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
 626                         'armor' => 1 );
 627         } else {
 628                 $gpg->options->hash_init(
 629                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
 630                         'armor' => 1 );
 631         };
 632         $gpg->options->meta_interactive( 0 );
 633         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 634         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 635         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 636         waitpid $pid, 0;
 637
 638         return $stdout;
 639 };
 640
 641 ######
 642 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
 643 ######
 644 sub import_key($$) {
 645         my ($gnupghome, $asciikey) = @_;
 646
 647         my $gpg = GnuPG::Interface->new();
 648         $gpg->call( $CONFIG{'gpg'} );
 649         $gpg->options->hash_init(
 650                 'homedir' => $gnupghome,
 651                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ] );
 652         $gpg->options->meta_interactive( 0 );
 653         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 654         my $pid = $gpg->import_keys(handles => $handles);
 655         my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 656         waitpid $pid, 0;
 657
 658         if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 659                 return undef;
 660         };
 661         return 1;
 662 };
 663
 664
 665 ######
 666 # Send an email to $address.  If $can_encrypt is true then the mail
 667 # will be PGP/MIME encrypted to $longkeyid.
 668 #
 669 # $longkeyid, $uid, and @attached will be used in the email and the template.
 670 ######
 671 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 672 sub send_mail($$$@) {
 673         my ($address, $can_encrypt, $key_id, @keys) = @_;
 674
 675         my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
 676             or die "Error creating template: $Text::Template::ERROR";
 677
 678         my @uids;
 679         for my $key (@keys) {
 680             push @uids, $key->{'text'};
 681         };
 682         my $message = $template->fill_in(HASH => { key => $key_id,
 683                                                    uids => \@uids,
 684                                                    owner => $CONFIG{'owner'}})
 685             or die "Error filling template in: $Text::Template::ERROR";
 686
 687         my $message_entity = MIME::Entity->build(
 688                 Type        => "text/plain",
 689                 Charset     => "utf-8",
 690                 Disposition => 'inline',
 691                 Data        => $message);
 692
 693         my @key_entities;
 694         for my $key (@keys) {
 695                 $message_entity->attach(
 696                         Type        => "application/pgp-keys",
 697                         Disposition => 'attachment',
 698                         Encoding    => "7bit",
 699                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).'), signed by 0x'.$CONFIG{'keyid'}[0],
 700                         Data        => $key->{'key'},
 701                         Filename    => "0x$key_id.".$key->{'serial'}.".signed-by-0x".$CONFIG{'keyid'}[0].".asc");
 702         };
 703
 704         if ($can_encrypt) {
 705                 my $message = $message_entity->stringify();
 706
 707                 my $gpg = GnuPG::Interface->new();
 708                 $gpg->call( $CONFIG{'gpg'} );
 709                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 710                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
 711                         'armor' => 1 );
 712                 $gpg->options->meta_interactive( 0 );
 713                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 714                 $gpg->options->push_recipients( $key_id );
 715                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 716                 my $pid = $gpg->encrypt(handles => $handles);
 717                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 718                 waitpid $pid, 0;
 719                 if ($stdout eq '') {
 720                         warn ("No data from gpg for list-key $key_id\n");
 721                         next;
 722                 };
 723                 $message = $stdout;
 724
 725                 $message_entity = MIME::Entity->build(
 726                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 727
 728                 $message_entity->attach(
 729                         Type        => "application/pgp-encrypted",
 730                         Disposition => 'attachment',
 731                         Encoding    => "7bit",
 732                         Data        => "Version: 1\n");
 733
 734                 $message_entity->attach(
 735                         Type        => "application/octet-stream",
 736                         Filename    => 'msg.asc',
 737                         Disposition => 'inline',
 738                         Encoding    => "7bit",
 739                         Data        => $message);
 740         };
 741
 742         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 743         $message_entity->head->add("To", $address);
 744         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 745         $message_entity->head->add("Reply-To", $CONFIG{'reply-to'}) if defined $CONFIG{'reply-to'};
 746         $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
 747         $message_entity->head->add("User-Agent", $USER_AGENT);
 748         $message_entity->send();
 749         $message_entity->stringify();
 750 };
 751
 752 ######
 753 # clean up a UID so that it can be used on the FS.
 754 ######
 755 sub sanitize_uid($) {
 756         my ($uid) = @_;
 757
 758         my $good_uid = $uid;
 759         $good_uid =~ tr#/:\\#_#;
 760         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 761         return $good_uid;
 762 };
 763
 764 sub delete_signatures($$$$$$) {
 765         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
 766
 767         my $signed_by_me = 0;
 768
 769         my ($stdout, $stderr, $status) =
 770                 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 771
 772         while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 773                 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 774                 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 775                 $stdout =~ s/\n/\\n/g;
 776                 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 777                 my $line = pop @sigline;
 778                 my $answer = "no";
 779                 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 780                         debug("[sigremoval] doing line $line.");
 781                         my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 782                         if ($signer eq $longkeyid) {
 783                                 debug("[sigremoval] selfsig ($signer).");
 784                                 $answer = "no";
 785                         } elsif (grep { $signer eq $_ } @{$keyids}) {
 786                                 debug("[sigremoval] signed by us ($signer).");
 787                                 $answer = "no";
 788                                 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 789                         } else {
 790                                 debug("[sigremoval] not interested in that sig ($signer).");
 791                                 $answer = "yes";
 792                         };
 793                 } else {
 794                         debug("[sigremoval] no sig line here, only got: ".$stdout);
 795                 };
 796                 ($stdout, $stderr, $status) =
 797                         readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 798         };
 799
 800         return $signed_by_me;
 801 };
 802
 803
 804
 805 my $USER;
 806 my @KEYIDS;
 807 my $params;
 808
 809 Getopt::Long::config('bundling');
 810 if (!GetOptions (
 811         '-h'              =>  \$params->{'help'},
 812         '--help'          =>  \$params->{'help'},
 813         '--version'       =>  \$params->{'version'},
 814         '-V'              =>  \$params->{'version'},
 815         '-u=s'            =>  \$params->{'local-user'},
 816         '--local-user=s'  =>  \$params->{'local-user'},
 817         '-e'              =>  \$params->{'export-old'},
 818         '--export-old'    =>  \$params->{'export-old'},
 819         '-E'              =>  \$params->{'no-export-old'},
 820         '--no-export-old' =>  \$params->{'no-export-old'},
 821         '-m'              =>  \$params->{'mail'},
 822         '--mail'          =>  \$params->{'mail'},
 823         '-M'              =>  \$params->{'no-mail'},
 824         '--no-mail'       =>  \$params->{'no-mail'},
 825         '-R'              =>  \$params->{'no-download'},
 826         '--no-download'   =>  \$params->{'no-download'},
 827         '-S'              =>  \$params->{'no-sign'},
 828         '--no-sign'       =>  \$params->{'no-sign'},
 829         '--key-file=s@'   =>  \$params->{'key-files'},
 830         )) {
 831         usage(\*STDERR, 1);
 832 };
 833 if ($params->{'help'}) {
 834         usage(\*STDOUT, 0);
 835 };
 836 if ($params->{'version'}) {
 837         version(\*STDOUT);
 838         exit(0);
 839 };
 840 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
 841
 842
 843
 844 if ($params->{'local-user'}) {
 845         $USER = $params->{'local-user'};
 846         $USER =~ s/^0x//i;
 847         unless ($USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
 848                 print STDERR "-u $USER is not a keyid.\n";
 849                 usage(\*STDERR, 1);
 850         };
 851         $USER = uc($USER);
 852 };
 853
 854 for my $keyid (@ARGV) {
 855         $keyid =~ s/^0x//i;
 856         unless ($keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i) {
 857                 if ($keyid =~ /^[A-F0-9]{32}$/) {
 858                         info("Ignoring v3 fingerprint $keyid.  v3 keys are obsolete.");
 859                         next;
 860                 };
 861                 print STDERR "$keyid is not a keyid.\n";
 862                 usage(\*STDERR, 1);
 863         };
 864         push @KEYIDS, uc($keyid);
 865 };
 866
 867 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
 868 $CONFIG{'no-mail'}     = $params->{'no-mail'}     if defined $params->{'no-mail'};
 869 $CONFIG{'mail'}        = $params->{'mail'}        if defined $params->{'mail'};
 870 $CONFIG{'no-sign'}     = $params->{'no-sign'}     if defined $params->{'no-sign'};
 871 push @{$CONFIG{'key-files'}}, @{$params->{'key-files'}} if defined $params->{'key-files'};
 872
 873
 874 #################
 875 # import own keys
 876 #################
 877 for my $keyid (@{$CONFIG{'keyid'}}) {
 878         my $gpg = GnuPG::Interface->new();
 879         $gpg->call( $CONFIG{'gpg'} );
 880         $gpg->options->hash_init(
 881                 'homedir' => $GNUPGHOME,
 882                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --fast-list-mode } ] );
 883         $gpg->options->meta_interactive( 0 );
 884         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 885         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $keyid);
 886         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 887         waitpid $pid, 0;
 888
 889         if ($stdout eq '') {
 890                 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
 891         };
 892         unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 893                 info("Key $keyid not found in caff's home.  Getting it from your normal GnuPGHome.");
 894                 my $key = export_key(undef, $keyid);
 895                 if (!defined $key || $key eq '') {
 896                         warn ("Did not get key $keyid from your normal GnuPGHome\n");
 897                         next;
 898                 };
 899                 my $result = import_key($GNUPGHOME, $key);
 900                 unless ($result) {
 901                         warn ("Could not import $keyid into caff's gnupghome.\n");
 902                         next;
 903                 };
 904         }
 905 }
 906
 907 ########################
 908 # import keys from files
 909 ########################
 910 foreach my $keyfile (@{$CONFIG{'key-files'}}) {
 911     my $gpg = GnuPG::Interface->new();
 912     $gpg->call( $CONFIG{'gpg'} );
 913     $gpg->options->hash_init('homedir' => $GNUPGHOME);
 914     $gpg->options->meta_interactive( 0 );
 915     my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 916     my $pid = $gpg->import_keys(handles => $handles, command_args => $keyfile);
 917     my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 918     info ("Importing keys from $keyfile");
 919     waitpid $pid, 0;
 920     if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 921         warn $stderr;
 922     }
 923 }
 924
 925 #############################
 926 # receive keys from keyserver
 927 #############################
 928 my @keyids_ok;
 929 if ($CONFIG{'no-download'}) {
 930         @keyids_ok = @KEYIDS;
 931 } else {
 932         info ("fetching keys, this will take a while...");
 933
 934         my $gpg = GnuPG::Interface->new();
 935         $gpg->call( $CONFIG{'gpg'} );
 936         $gpg->options->hash_init(
 937                 'homedir' => $GNUPGHOME,
 938                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always }, '--keyserver='.$CONFIG{'keyserver'} ] );
 939         $gpg->options->meta_interactive( 0 );
 940         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 941         my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 942         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 943         waitpid $pid, 0;
 944
 945 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 946 # [GNUPG:] NODATA 1
 947 # [GNUPG:] NODATA 1
 948 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 949         my %local_keyids = map { $_ => 1 } @KEYIDS;
 950         my $had_v3_keys = 0;
 951         for my $line (split /\n/, $status) {
 952                 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 953                         my $imported_key = $1;
 954                         my $whole_fpr = $imported_key;
 955                         my $long_keyid = substr($imported_key, -16);
 956                         my $short_keyid = substr($imported_key, -8);
 957                         my $speced_key;
 958                         for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
 959                                 $speced_key = $spec if $local_keyids{$spec};
 960                         };
 961                         unless ($speced_key) {
 962                             notice ("Imported unexpected key; got: $imported_key\n");
 963                             next;
 964                         };
 965                         debug ("Imported $imported_key for $speced_key");
 966                         delete $local_keyids{$speced_key};
 967                         unshift @keyids_ok, $imported_key;
 968                 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
 969                 } elsif ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/) {
 970                         my $imported_key = $1;
 971                         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.");
 972                         $had_v3_keys = 1;
 973                 } else {
 974                         notice ("got unknown reply from gpg: $line");
 975                 }
 976         };
 977         if (scalar %local_keyids) {
 978                 notice ("Import failed for: ". (join ' ', keys %local_keyids)."." . ($had_v3_keys ? " (Or maybe it's one of those ugly v3 keys?)" :  ""));
 979                 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
 980         }
 981 };
 982
 983 unless (@keyids_ok) {
 984         notice ("No keys to sign found");
 985         exit 0;
 986 }
 987
 988 ###########
 989 # sign keys
 990 ###########
 991 if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
 992         $CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
 993 }
 994
 995 unless ($CONFIG{'no-sign'}) {
 996         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 997         for my $keyid (@keyids_ok) {
 998                 my @command;
 999                 push @command, $CONFIG{'gpg-sign'};
1000                 push @command, '--local-user', $USER if (defined $USER);
1001                 push @command, "--homedir=$GNUPGHOME";
1002                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
1003                 push @command, '--no-auto-check-trustdb';
1004                 push @command, '--trust-model=always';
1005                 push @command, '--edit', $keyid;
1006                 push @command, 'sign';
1007                 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
1008                 print join(' ', @command),"\n";
1009                 system (@command);
1010         };
1011 };
1012
1013 ##################
1014 # export and prune
1015 ##################
1016 KEYS:
1017 for my $keyid (@keyids_ok) {
1018         # get key listing
1019         #################
1020         my $gpg = GnuPG::Interface->new();
1021         $gpg->call( $CONFIG{'gpg'} );
1022         $gpg->options->hash_init(
1023                 'homedir' => $GNUPGHOME,
1024                 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
1025         $gpg->options->meta_interactive( 0 );
1026         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1027         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
1028         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
1029         waitpid $pid, 0;
1030         if ($stdout eq '') {
1031                 warn ("No data from gpg for list-key $keyid\n");
1032                 next;
1033         };
1034         my @publine = grep { /^pub/ } (split /\n/, $stdout);
1035         if (scalar @publine == 0) {
1036                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
1037                 next;
1038         };
1039         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
1040         if (scalar @publine > 0) {
1041                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
1042                 next;
1043         };
1044         unless (defined $longkeyid) {
1045                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
1046                 next;
1047         };
1048         unless (defined $flags) {
1049                 warn ("Didn't find flags in --list-key of key $keyid.\n");
1050                 next;
1051         };
1052         my $can_encrypt = $flags =~ /E/;
1053
1054         # export the key
1055         ################
1056         my $asciikey = export_key($GNUPGHOME, $keyid);
1057         if ($asciikey eq '') {
1058                 warn ("No data from gpg for export $keyid\n");
1059                 next;
1060         };
1061
1062         my @UIDS;
1063         my $uid_number = 0;
1064         while (1) {
1065                 my $this_uid_text = '';
1066                 $uid_number++;
1067                 debug("Doing key $keyid, uid $uid_number");
1068                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
1069
1070                 # import into temporary gpghome
1071                 ###############################
1072                 my $result = import_key($tempdir, $asciikey);
1073                 unless ($result) {
1074                         warn ("Could not import $keyid into temporary gnupg.\n");
1075                         next;
1076                 };
1077
1078                 # prune it
1079                 ##########
1080                 $gpg = GnuPG::Interface->new();
1081                 $gpg->call( $CONFIG{'gpg-delsig'} );
1082                 $gpg->options->hash_init(
1083                         'homedir' => $tempdir,
1084                         'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --command-fd=0 --no-tty } ] );
1085                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1086                 $pid = $gpg->wrap_call(
1087                         commands     => [ '--edit' ],
1088                         command_args => [ $keyid ],
1089                         handles      => $handles );
1090
1091                 debug("Starting edit session");
1092                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1093
1094                 # delete other uids
1095                 ###################
1096                 my $number_of_subkeys = 0;
1097                 my $i = 1;
1098                 my $have_one = 0;
1099                 my $is_uat = 0;
1100                 my $delete_some = 0;
1101                 debug("Parsing stdout output.");
1102                 for my $line (split /\n/, $stdout) {
1103                         debug("Checking line $line");
1104                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
1105                         if ($type eq 'sub') {
1106                                 $number_of_subkeys++;
1107                         };
1108                         next unless ($type eq 'uid' || $type eq 'uat');
1109                         debug("line is interesting.");
1110                         if ($uid_number != $i) {
1111                                 debug("mark for deletion.");
1112                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1113                                 $delete_some++;
1114                         } else {
1115                                 debug("keep it.");
1116                                 $have_one = 1;
1117                                 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
1118                                 $is_uat = $type eq 'uat';
1119                         };
1120                         $i++;
1121                 };
1122                 debug("Parsing stdout output done.");
1123                 unless ($have_one) {
1124                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
1125                         info("key $keyid done.");
1126                         last;
1127                 };
1128
1129                 my $prune_some_sigs_on_uid;
1130                 my $prune_all_sigs_on_uid;
1131                 if ($is_uat) {
1132                         debug("handling attribute userid of key $keyid.");
1133                         if ($uid_number == 1) {
1134                                 debug(" attribute userid is #1, unmarking #2 for deletion.");
1135                                 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1136                                 $delete_some--;
1137                                 $prune_some_sigs_on_uid = 1;
1138                                 $prune_all_sigs_on_uid = 2;
1139                         } else {
1140                                 debug("attribute userid is not #1, unmarking #1 for deletion.");
1141                                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1142                                 $delete_some--;
1143                                 $prune_some_sigs_on_uid = 2;
1144                                 $prune_all_sigs_on_uid = 1;
1145                         };
1146                 } else {
1147                         $prune_some_sigs_on_uid = 1;
1148                 };
1149
1150                 if ($delete_some) {
1151                         debug("need to delete $delete_some uids.");
1152                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
1153                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1154                 };
1155
1156                 # delete subkeys
1157                 ################
1158                 if ($number_of_subkeys > 0) {
1159                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
1160                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1161                         };
1162                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
1163                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1164                 };
1165
1166                 # delete signatures
1167                 ###################
1168                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1169                 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
1170                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1171                 if (defined $prune_all_sigs_on_uid) {
1172                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1173                         delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
1174                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1175                 };
1176
1177
1178                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1179                 waitpid $pid, 0;
1180
1181                 my $asciikey = export_key($tempdir, $keyid);
1182                 if ($asciikey eq '') {
1183                         warn ("No data from gpg for export $keyid\n");
1184                         next;
1185                 };
1186
1187                 if ($signed_by_me) {
1188                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1189                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1190                                 next unless $write;
1191                         };
1192                         my $keydir = "$KEYSBASE/$DATE_STRING";
1193                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1194
1195                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1196                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1197                         print KEY $asciikey;
1198                         close KEY;
1199
1200                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1201
1202                         info("$longkeyid $uid_number $this_uid_text done.");
1203                 } else {
1204                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1205                 };
1206         };
1207
1208         if (scalar @UIDS == 0) {
1209                 info("found no signed uids for $keyid");
1210         } else {
1211                 next if $CONFIG{'no-mail'}; # do not send mail
1212
1213                 my @attached;
1214                 for my $uid (@UIDS) {
1215                         trace("UID: $uid->{'text'}\n");
1216                         if ($uid->{'is_uat'}) {
1217                                 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1218                                 push @attached, $uid if $attach;
1219                         } elsif ($uid->{'text'} !~ /@/) {
1220                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1221                                 push @attached, $uid if $attach;
1222                         };
1223                 };
1224
1225                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1226                 for my $uid (@UIDS) {
1227                         if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1228                                 my $address = $uid->{'text'};
1229                                 $address =~ s/.*<(.*)>.*/$1/;
1230                                 if (ask("Mail signature for $uid->{'text'} to '$address'?", 1, $CONFIG{'mail'})) {
1231                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1232
1233                                         my $keydir = "$KEYSBASE/$DATE_STRING";
1234                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1235                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1236                                         print KEY $mail;
1237                                         close KEY;
1238                                 };
1239                         };
1240                 };
1241         };
1242
1243 };