caff/caff

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