caff/caff

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