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