caff/caff

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