caff/caff

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