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