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