caff/caff

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