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