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