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