caff/caff

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