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