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