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