caff/caff

   1 #!/usr/bin/perl -w
   2
   3 # caff  --  CA - Fire and Forget
   4 # $Id$
   5 #
   6 # Copyright (c) 2004 Peter Palfrader <peter@palfrader.org>
   7 #
   8 # All rights reserved.
   9 #
  10 # Redistribution and use in source and binary forms, with or without
  11 # modification, are permitted provided that the following conditions
  12 # are met:
  13 # 1. Redistributions of source code must retain the above copyright
  14 #    notice, this list of conditions and the following disclaimer.
  15 # 2. Redistributions in binary form must reproduce the above copyright
  16 #    notice, this list of conditions and the following disclaimer in the
  17 #    documentation and/or other materials provided with the distribution.
  18 # 3. The name of the author may not be used to endorse or promote products
  19 #    derived from this software without specific prior written permission.
  20 #
  21 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  22 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  23 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  24 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  25 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  26 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  27 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  28 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  29 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  30 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  31
  32 =pod
  33
  34 =head1 NAME
  35
  36 caff -- CA - Fire and Forget
  37
  38 =head1 SYNOPSIS
  39
  40 =over
  41
  42 =item B<caff> [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
  43
  44 =back
  45
  46 =head1 DESCRIPTION
  47
  48 CA Fire and Forget is a script that helps you in keysigning.  It takes a list
  49 of keyids on the command line, fetches them from a keyserver and calls GnuPG so
  50 that you can sign it.  It then mails each key to all its email addresses - only
  51 including the one UID that we send to in each mail, pruned from all but self
  52 sigs and sigs done by you.
  53
  54 =head1 OPTIONS
  55
  56 =over
  57
  58 =item B<-u> I<yourkeyid>
  59
  60 Select the key that is used for signing, in case you have more than one key.
  61
  62 =back
  63
  64 =head1 FILES
  65
  66 =over
  67
  68 =item $HOME/.caffrc  -  configuration file
  69
  70 =back
  71
  72 =head1 CONFIGURATION FILE OPTIONS
  73
  74 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
  75
  76 Example:
  77
  78         $CONFIG{'owner'}       = 'Peter Palfrader';
  79         $CONFIG{'email'}       = 'peter@palfrader.org';
  80
  81 =head2 Valid keys
  82
  83 =over
  84
  85 =item B<caffhome> [string]
  86
  87 Base directory for the files caff stores.  Default: B<$HOME/.caff/>.
  88
  89 =item B<owner> [string]
  90
  91 Your name.  B<REQUIRED>.
  92
  93 =item B<email> [string]
  94
  95 Your email address, used in From: lines.  B<REQUIRED>.
  96
  97 =item B<keyid> [list of keyids]
  98
  99 A list of your keys.  This is used to determine which signatures to keep
 100 in the pruning step.  If you select a key using B<-u> it has to be in
 101 this list.  B<REQUIRED>.
 102
 103 =item B<export-sig-age> [seconds]
 104
 105 Don't export UIDs by default, on which your latest signature is older
 106 than this age.  Default: B<24*60*60> (i.e. one day).
 107
 108 =item B<keyserver> [string]
 109
 110 Keyserver to download keys from.  Default: B<subkeys.pgp.net>.
 111
 112 =item B<gpg> [string]
 113
 114 Path to the GnuPG binary.  Default: B<gpg>.
 115
 116 =item B<gpg-sign> [string]
 117
 118 Path to the GnuPG binary which is used to sign keys.  Default: what
 119 B<gpg> is set to.
 120
 121 =item B<gpg-delsig> [string]
 122
 123 Path to the GnuPG binary which is used to split off signatures.  This is
 124 needed while the upstream GnuPG is not fixed  (there are 2 bugs in the
 125 Debian Bug Tracking System).  Default: what B<gpg> is set to.
 126
 127 =item B<secret-keyring> [string]
 128
 129 Path to your secret keyring.  Default: B<$HOME/.gnupg/secring.gpg>.
 130
 131 =item B<also-encrypt-to> [keyid]
 132
 133 An additional keyid to encrypt messages to. Default: none.
 134
 135 =item B<no-download> [boolean]
 136
 137 If true, then skip the step of fetching keys from the keyserver.
 138 Default: B<0>.
 139
 140 =item B<no-sign> [boolean]
 141
 142 If true, then skip the signing step. Default: B<0>.
 143
 144 =back
 145
 146 =head1 AUTHOR
 147
 148 Peter Palfrader <peter@palfrader.org>
 149
 150 =cut
 151
 152 use strict;
 153 use IO::Handle;
 154 use English;
 155 use File::Path;
 156 use File::Temp qw{tempdir};
 157 use MIME::Entity;
 158 use Fcntl;
 159 use IO::Select;
 160 use GnuPG::Interface;
 161
 162 my %CONFIG;
 163 my $REVISION = '$Rev$';
 164 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
 165 my $VERSION = "0.0.0.$REVISION_NUMER";
 166
 167 sub load_config() {
 168         my $config = $ENV{'HOME'} . '/.caffrc';
 169         -f $config or die "No file $config present.  See caffrc(5).\n";
 170         unless (scalar eval `cat $config`) {
 171                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 172         };
 173
 174         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 175         die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
 176         die ("email is not defined.\n") unless defined $CONFIG{'email'};
 177         die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
 178         die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 179         for my $keyid (@{$CONFIG{'keyid'}}) {
 180                 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
 181         };
 182         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 183         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 184         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 185         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 186         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 187         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 188         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 189         $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
 190         $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
 191 };
 192
 193 sub notice($) {
 194         my ($line) = @_;
 195         print "[NOTICE] $line\n";
 196 };
 197 sub info($) {
 198         my ($line) = @_;
 199         print "[INFO] $line\n";
 200 };
 201 sub debug($) {
 202         my ($line) = @_;
 203         #print "[DEBUG] $line\n";
 204 };
 205 sub trace($) {
 206         my ($line) = @_;
 207         #print "[trace] $line\n";
 208 };
 209 sub trace2($) {
 210         my ($line) = @_;
 211         #print "[trace2] $line\n";
 212 };
 213
 214 sub make_gpg_fds() {
 215         my %fds = (
 216                 stdin => IO::Handle->new(),
 217                 stdout => IO::Handle->new(),
 218                 stderr => IO::Handle->new(),
 219                 status => IO::Handle->new() );
 220         my $handles = GnuPG::Handles->new( %fds );
 221         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 222 };
 223
 224 sub readwrite_gpg($$$$$%) {
 225         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 226
 227         trace("Entering readwrite_gpg.");
 228
 229         my ($first_line, $dummy) = split /\n/, $in;
 230         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 231
 232         local $INPUT_RECORD_SEPARATOR = undef;
 233         my $sout = IO::Select->new();
 234         my $sin = IO::Select->new();
 235         my $offset = 0;
 236
 237         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 238
 239         $inputfd->blocking(0);
 240         $stdoutfd->blocking(0);
 241         $statusfd->blocking(0) if defined $statusfd;
 242         $stderrfd->blocking(0);
 243         $sout->add($stdoutfd);
 244         $sout->add($stderrfd);
 245         $sout->add($statusfd) if defined $statusfd;
 246         $sin->add($inputfd);
 247
 248         my ($stdout, $stderr, $status) = ("", "", "");
 249         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 250         trace("doign stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 251
 252         my ($readyr, $readyw, $written);
 253         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 254                 if (defined $exitwhenstatusmatches) {
 255                         if ($status =~ /$exitwhenstatusmatches/m) {
 256                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 257                                 last;
 258                         };
 259                 };
 260
 261                 trace("select waiting for ".($sout->count())." fds.");
 262                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 1);
 263                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 264                 for my $wfd (@$readyw) {
 265                         if (length($in) != $offset) {
 266                                 trace("writing to $wfd.");
 267                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 268                                 $offset += $written;
 269                         };
 270                         if ($offset == length($in)) {
 271                                 trace("writing to $wfd done.");
 272                                 unless ($options{'nocloseinput'}) {
 273                                         close $wfd;
 274                                         trace("$wfd closed.");
 275                                 };
 276                                 $sin->remove($wfd);
 277                                 $sin = undef;
 278                         }
 279                 }
 280
 281                 next unless (defined(@$readyr)); # Wait some more.
 282
 283                 for my $rfd (@$readyr) {
 284                         if ($rfd->eof) {
 285                                 trace("reading from $rfd done.");
 286                                 $sout->remove($rfd);
 287                                 close($rfd);
 288                                 next;
 289                         }
 290                         trace("reading from $rfd.");
 291                         if ($rfd == $stdoutfd) {
 292                                 $stdout .= <$rfd>;
 293                                 trace2("stdout is now $stdout\n================");
 294                                 next;
 295                         }
 296                         if (defined $statusfd && $rfd == $statusfd) {
 297                                 $status .= <$rfd>;
 298                                 trace2("status is now $status\n================");
 299                                 next;
 300                         }
 301                         if ($rfd == $stderrfd) {
 302                                 $stderr .= <$rfd>;
 303                                 trace2("stderr is now $stderr\n================");
 304                                 next;
 305                         }
 306                 }
 307         }
 308         trace("readwrite_gpg done.");
 309         return ($stdout, $stderr, $status);
 310 };
 311
 312 sub ask($$) {
 313         my ($question, $default) = @_;
 314         my $answer;
 315         while (1) {
 316                 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
 317                 $answer = <STDIN>;
 318                 chomp $answer;
 319                 last if ((defined $answer) && (length $answer <= 1));
 320                 print "grrrrrr.\n";
 321                 sleep 1;
 322         };
 323         my $result = $default;
 324         $result = 1 if $answer =~ /y/i;
 325         $result = 0 if $answer =~ /n/i;
 326         return $result;
 327 };
 328
 329
 330
 331
 332
 333 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 334 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 335 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 336 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 337 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 338
 339 load_config;
 340 my $USER_AGENT = "caff $VERSION - (c) 2004 Peter Palfrader";
 341
 342 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 343 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 344
 345 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 346 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 347
 348 my $NOW = time;
 349 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 350 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 351
 352
 353 sub usage() {
 354         print STDERR "caff $VERSION - (c) 2004 Peter Palfrader\n";
 355         print STDERR "Usage: $PROGRAM_NAME [-u <yourkeyid] <keyid> [<keyid> ...]\n";
 356         exit 1;
 357 };
 358
 359 sub export_key($$) {
 360         my ($gnupghome, $keyid) = @_;
 361
 362         my $gpg = GnuPG::Interface->new();
 363         $gpg->call( $CONFIG{'gpg'} );
 364         $gpg->options->hash_init(
 365                 'homedir' => $gnupghome,
 366                 'armor' => 1 );
 367         $gpg->options->meta_interactive( 0 );
 368         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 369         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 370         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 371         waitpid $pid, 0;
 372
 373         return $stdout;
 374 };
 375
 376 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 377 sub send_mail($$$@) {
 378         my ($address, $can_encrypt, $key_id, @keys) = @_;
 379
 380         my $message = "Hi,\n\n";
 381
 382         $message .= 'please find attached the user id'.(scalar @keys >= 2 ? 's' : '')."\n";
 383         for my $key (@keys) {
 384                 $message .= "\t".$key->{'text'}."\n";
 385         };
 386         $message .= qq{of your key $key_id signed by me.
 387
 388 Note that I did not upload your key to any keyservers. If you want this
 389 new signature to be available to others, please upload it yourself.
 390 With GnuPG this can be done using
 391         gpg --keyserver subkeys.pgp.net --send-key $key_id
 392
 393 If you have any questions, don't hesitate to ask.
 394
 395 Regards,
 396 $CONFIG{'owner'}
 397 };
 398         my $message_entity = MIME::Entity->build(
 399                 Type        => "text/plain",
 400                 Charset     => "utf-8",
 401                 Disposition => 'inline',
 402                 Data        => $message);
 403
 404         my @key_entities;
 405         for my $key (@keys) {
 406                 $message_entity->attach(
 407                         Type        => "application/pgp-keys",
 408                         Disposition => 'attachment',
 409                         Encoding    => "7bit",
 410                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
 411                         Data        => $key->{'key'},
 412                         Filename    => "0x$key_id.".$key->{'serial'}.".asc");
 413         };
 414
 415         if ($can_encrypt) {
 416                 my $message = $message_entity->stringify();
 417
 418                 my $gpg = GnuPG::Interface->new();
 419                 $gpg->call( $CONFIG{'gpg'} );
 420                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 421                         'extra_args' => '--always-trust',
 422                         'armor' => 1 );
 423                 $gpg->options->meta_interactive( 0 );
 424                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 425                 $gpg->options->push_recipients( $key_id );
 426                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 427                 my $pid = $gpg->encrypt(handles => $handles);
 428                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 429                 waitpid $pid, 0;
 430                 if ($stdout eq '') {
 431                         warn ("No data from gpg for list-key $key_id\n");
 432                         next;
 433                 };
 434                 $message = $stdout;
 435
 436                 $message_entity = MIME::Entity->build(
 437                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 438
 439                 $message_entity->attach(
 440                         Type        => "application/pgp-encrypted",
 441                         Disposition => 'attachment',
 442                         Encoding    => "7bit",
 443                         Data        => "Version: 1\n");
 444
 445                 $message_entity->attach(
 446                         Type        => "application/octet-stream",
 447                         Filename    => 'msg.asc',
 448                         Disposition => 'inline',
 449                         Encoding    => "7bit",
 450                         Data        => $message);
 451         };
 452
 453         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 454         $message_entity->head->add("To", $address);
 455         $message_entity->head->add("From", $CONFIG{'owner'}.' <'.$CONFIG{'email'}.'>');
 456         $message_entity->head->add("User-Agent", $USER_AGENT);
 457         $message_entity->send();
 458         $message_entity->stringify();
 459 };
 460
 461 sub sanitize_uid($) {
 462         my ($uid) = @_;
 463
 464         my $good_uid = $uid;
 465         $good_uid =~ tr#/:\\#_#;
 466         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 467         return $good_uid;
 468 };
 469
 470 my $USER;
 471 my @KEYIDS;
 472
 473 usage() unless scalar @ARGV >= 1;
 474 if ($ARGV[0] eq '-u') {
 475         usage() unless scalar @ARGV >= 3;
 476         shift @ARGV;
 477         $USER = shift @ARGV;
 478         unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
 479                 print STDERR "-u $USER is not a keyid.\n";
 480                 usage();
 481         };
 482         $USER = uc($USER);
 483 };
 484 for my $keyid (@ARGV) {
 485         unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8})?$/) {
 486                 print STDERR "$keyid is not a keyid.\n";
 487                 usage();
 488         };
 489         push @KEYIDS, uc($keyid);
 490 };
 491
 492
 493
 494 #############################
 495 # receive keys from keyserver
 496 #############################
 497 my @keyids_ok;
 498 my @keyids_failed;
 499 if ($CONFIG{'no-download'}) {
 500         @keyids_ok = @KEYIDS;
 501 } else {
 502         my $gpg = GnuPG::Interface->new();
 503         $gpg->call( $CONFIG{'gpg'} );
 504         $gpg->options->hash_init(
 505                 'homedir' => $GNUPGHOME,
 506                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 507         $gpg->options->meta_interactive( 0 );
 508         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 509
 510         my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 511         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 512         waitpid $pid, 0;
 513
 514 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 515 # [GNUPG:] NODATA 1
 516 # [GNUPG:] NODATA 1
 517 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 518         for my $line (split /\n/, $status) {
 519                 if ($line =~ /^\[GNUPG:\] IMPORT_OK/) {
 520                         push @keyids_ok, shift @KEYIDS;
 521                 } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 522                         push @keyids_failed, shift @KEYIDS;
 523                 };
 524         }
 525         die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 526         notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 527 };
 528
 529 ###########
 530 # sign keys
 531 ###########
 532 unless ($CONFIG{'no-sign'}) {
 533         info("Sign the following keys according to your policy...");
 534         for my $keyid (@keyids_ok) {
 535                 my @command;
 536                 push @command, $CONFIG{'gpg-sign'};
 537                 push @command, '--local-user', $USER if (defined $USER);
 538                 push @command, "--homedir=$GNUPGHOME";
 539                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 540                 push @command, '--sign-key', $keyid;
 541                 print join(' ', @command),"\n";
 542                 system (@command);
 543         };
 544 };
 545
 546 ##################
 547 # export and prune
 548 ##################
 549 KEYS:
 550 for my $keyid (@keyids_ok) {
 551         # get key listing
 552         #################
 553         my $gpg = GnuPG::Interface->new();
 554         $gpg->call( $CONFIG{'gpg'} );
 555         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 556         $gpg->options->meta_interactive( 0 );
 557         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 558         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 559         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 560         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 561         waitpid $pid, 0;
 562         if ($stdout eq '') {
 563                 warn ("No data from gpg for list-key $keyid\n");
 564                 next;
 565         };
 566         my $keyinfo = $stdout;
 567         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 568         my ($dummy1, $dummy2, $dummy3, $dummy4, $longkeyid, $dummy6, $dummy7, $dummy8, $dummy9, $dummy10, $dummy11, $flags) = split /:/, pop @publine;
 569         my $can_encrypt = $flags =~ /E/;
 570         unless (defined $longkeyid) {
 571                 warn ("Didn't find public keyid in edit dialog of key $keyid.\n");
 572                 next;
 573         };
 574
 575         # export the key
 576         ################
 577         my $asciikey = export_key($GNUPGHOME, $keyid);
 578         if ($asciikey eq '') {
 579                 warn ("No data from gpg for export $keyid\n");
 580                 next;
 581         };
 582
 583         my @UIDS;
 584         my $uid_number = 0;
 585         while (1) {
 586                 my $this_uid_text = '';
 587                 $uid_number++;
 588                 info("Doing key $keyid, uid $uid_number");
 589
 590                 # import into temporary gpghome
 591                 ###############################
 592                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 593                 my $gpg = GnuPG::Interface->new();
 594                 $gpg->call( $CONFIG{'gpg'} );
 595                 $gpg->options->hash_init( 'homedir' => $tempdir );
 596                 $gpg->options->meta_interactive( 0 );
 597                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 598                 my $pid = $gpg->import_keys(handles => $handles);
 599                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 600                 waitpid $pid, 0;
 601
 602                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 603                         warn ("Could not import $keyid into temporary gnupg.\n");
 604                         next;
 605                 };
 606
 607                 # prune it
 608                 ##########
 609                 $gpg = GnuPG::Interface->new();
 610                 $gpg->call( $CONFIG{'gpg-delsig'} );
 611                 $gpg->options->hash_init(
 612                         'homedir' => $tempdir,
 613                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 614                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 615                 $pid = $gpg->wrap_call(
 616                         commands     => [ '--edit' ],
 617                         command_args => [ $keyid ],
 618                         handles      => $handles );
 619
 620                 debug("Starting edit session");
 621                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 622
 623                 # delete other uids
 624                 ###################
 625                 my $number_of_subkeys = 0;
 626                 my $i = 1;
 627                 my $have_one = 0;
 628                 my $is_uat = 0;
 629                 my $delete_some = 0;
 630                 debug("Parsing stdout output.");
 631                 for my $line (split /\n/, $stdout) {
 632                         debug("Checking line $line");
 633                         my ($type, $dummy2, $dummy3, $dummy4, $dummy5, $dummy6, $dummy7, $dummy8, $dummy9, $uidtext) = split /:/, $line;
 634                         if ($type eq 'sub') {
 635                                 $number_of_subkeys++;
 636                         };
 637                         next unless ($type eq 'uid' || $type eq 'uat');
 638                         debug("line is interesting.");
 639                         if ($uid_number != $i) {
 640                                 debug("mark for deletion.");
 641                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 642                                 $delete_some = 1;
 643                         } else {
 644                                 debug("keep it.");
 645                                 $have_one = 1;
 646                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 647                                 $is_uat = $type eq 'uat';
 648                         };
 649                         $i++;
 650                 };
 651                 debug("Parsing stdout output done.");
 652                 if ($is_uat) {
 653                         notice("Can't handle attribute userid of key $keyid.");
 654                         next;
 655                 };
 656                 unless ($have_one) {
 657                         info("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 658                         info("key $keyid done.");
 659                         last;
 660                 };
 661                 if ($delete_some) {
 662                         debug("need to delete a few uids.");
 663                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 664                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 665                 };
 666
 667                 # delete subkeys
 668                 ################
 669                 if ($number_of_subkeys > 0) {
 670                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 671                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 672                         };
 673                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 674                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 675                 };
 676
 677                 # delete signatures
 678                 ###################
 679                 my $signed_by_me = 0;
 680                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 681                 ($stdout, $stderr, $status) =
 682                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 683
 684                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 685                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 686                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 687                         my $line = pop @sigline;
 688                         my $answer = "no";
 689                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 690                                 my ($dummy1, $dummy2, $dummy3, $dummy4, $signer, $created, $dummy7, $dummy8, $dummy9) = split /:/, $line;
 691                                 if ($signer eq $longkeyid) {
 692                                         $answer = "no";
 693                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 694                                         $answer = "no";
 695                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 696                                 } else {
 697                                         $answer = "yes";
 698                                 };
 699                         };
 700                         ($stdout, $stderr, $status) =
 701                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 702                 };
 703                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 704                 waitpid $pid, 0;
 705
 706                 my $asciikey = export_key($tempdir, $longkeyid);
 707                 if ($asciikey eq '') {
 708                         warn ("No data from gpg for export $longkeyid\n");
 709                         next;
 710                 };
 711
 712                 if ($signed_by_me) {
 713                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 714                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 715                                 next unless $write;
 716                         };
 717                         my $keydir = "$KEYSBASE/$DATE_STRING";
 718                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 719
 720                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 721                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile\n");
 722                         print KEY $asciikey;
 723                         close KEY;
 724
 725                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 726
 727                         info("$longkeyid $uid_number $this_uid_text done.");
 728                 } else {
 729                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 730                 };
 731         };
 732
 733         if (scalar @UIDS == 0) {
 734                 info("found no signed uids for $keyid");
 735         } else {
 736                 my @attached ;
 737                 for my $uid (@UIDS) {
 738                         trace("UID: $uid->{'text'}\n");
 739                         unless ($uid->{'text'} =~ /@/) {
 740                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 741                                 push @attached, $uid if $attach;
 742                         };
 743                 };
 744
 745                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 746                 for my $uid (@UIDS) {
 747                         if ($uid->{'text'} =~ /@/) {
 748                                 my $address = $uid->{'text'};
 749                                 $address =~ s/.*<(.*)>.*/$1/;
 750                                 my $send = ask("Send mail to '$address' for $uid->{'text'}?", 1);
 751                                 if ($send) {
 752                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 753
 754                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 755                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 756                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile\n");
 757                                         print KEY $mail;
 758                                         close KEY;
 759                                 };
 760                         };
 761                 };
 762         };
 763
 764 };
 765
 766
 767
 768
 769 ###############################################################3
 770 #### old fork gpg --edit
 771 =cut
 772                 my ($stdin_read, $stdin_write);
 773                 my ($stdout_read, $stdout_write);
 774                 my ($stderr_read, $stderr_write);
 775                 my ($status_read, $status_write);
 776                 pipe $stdin_read, $stdin_write;
 777                 pipe $stdout_read, $stdout_write;
 778                 pipe $stderr_read, $stderr_write;
 779                 pipe $status_read, $status_write;
 780
 781                 $pid = fork();
 782                 unless ($pid) { # child
 783                         close $stdin_write;
 784                         close $stdout_read;
 785                         close $stderr_read;
 786                         close $status_read;
 787
 788                         my @call;
 789                         push @call, $CONFIG{'gpg-delsig'};
 790                         push @call, "--homedir=$tempdir";
 791                         push @call, '--with-colons';
 792                         push @call, '--fixed-list-mode';
 793                         push @call, '--command-fd=0';
 794                         push @call, "--status-fd=".fileno($status_write);
 795                         push @call, "--no-tty";
 796                         push @call, "--edit";
 797                         push @call, $keyid;
 798
 799                         close STDIN;
 800                         close STDOUT;
 801                         close STDERR;
 802                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 803                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 804                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 805
 806                         fcntl $status_write, F_SETFD, 0;
 807
 808                         exec (@call);
 809                         exit;
 810                 };
 811                 close $stdin_read;
 812                 close $stdout_write;
 813                 close $stderr_write;
 814                 close $status_write;
 815
 816                 $inputfd = $stdin_write;
 817                 $stdoutfd = $stdout_read;
 818                 $stderrfd = $stderr_read;
 819                 $statusfd = $status_read;
 820 =cut