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