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