caff/caff

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