3 # caff -- CA - Fire and Forget
6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
7 # Copyright (c) 2005 Christoph Berg <cb@df7cb.de>
11 # Redistribution and use in source and binary forms, with or without
12 # modification, are permitted provided that the following conditions
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.
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.
37 caff -- CA - Fire and Forget
43 =item B<caff> [-mMR] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
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.
59 =item B<-m>, B<--mail>
61 Send mail after signing. Default is to ask the user for each uid.
63 =item B<-M>, B<--no-mail>
65 Do not send mail after signing. Default is to ask the user for each uid.
67 =item B<-R>, B<--no-download>
69 Do not retrieve the key to be signed from a keyserver.
71 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
73 Select the key that is used for signing, in case you have more than one key.
81 =item $HOME/.caffrc - configuration file
85 =head1 CONFIGURATION FILE OPTIONS
87 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
91 $CONFIG{owner} = q{Peter Palfrader};
92 $CONFIG{email} = q{peter@palfrader.org};
93 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
95 =head2 Required basic settings
99 =item B<owner> [string]
101 Your name. B<REQUIRED>.
103 =item B<email> [string]
105 Your email address, used in From: lines. B<REQUIRED>.
107 =item B<keyid> [list of keyids]
109 A list of your keys. This is used to determine which signatures to keep
110 in the pruning step. If you select a key using B<-u> it has to be in
111 this list. B<REQUIRED>.
113 =head2 General settings
115 =item B<caffhome> [string]
117 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
119 =head2 GnuPG settings
121 =item B<gpg> [string]
123 Path to the GnuPG binary. Default: B<gpg>.
125 =item B<gpg-sign> [string]
127 Path to the GnuPG binary which is used to sign keys. Default: what
130 =item B<gpg-delsig> [string]
132 Path to the GnuPG binary which is used to split off signatures. This was
133 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
136 =item B<secret-keyring> [string]
138 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
140 =item B<also-encrypt-to> [keyid]
142 An additional keyid to encrypt messages to. Default: none.
144 =head2 Keyserver settings
146 =item B<keyserver> [string]
148 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
150 =item B<no-download> [boolean]
152 If true, then skip the step of fetching keys from the keyserver.
155 =head2 Signing settings
157 =item B<no-sign> [boolean]
159 If true, then skip the signing step. Default: B<0>.
161 =item B<export-sig-age> [seconds]
163 Don't export UIDs by default, on which your latest signature is older
164 than this age. Default: B<24*60*60> (i.e. one day).
168 =item B<mail> [boolean]
170 Do not prompt for sending mail, just do it. Default: B<0>.
172 =item B<no-mail> [boolean]
174 Do not prompt for sending mail. The messages are still written to
175 $CONFIG{caffhome}/keys/. Default: B<0>.
177 =item B<mail-template> [string]
179 Email template which is used as the body text for the email sent out
180 instead of the default text if specified. The following perl variables
181 can be used in the template:
185 =item B<{owner}> [string]
187 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
189 =item B<{key}> [string]
191 The keyid of the key you signed.
193 =item B<{@uids}> [array]
195 The UIDs for which signatures are included in the mail.
199 =item B<bcc> [string]
201 Address to send blind carbon copies to when sending mail.
210 =item Peter Palfrader <peter@palfrader.org>
212 =item Christoph Berg <cb@df7cb.de>
218 http://pgp-tools.alioth.debian.org/
226 use File
::Temp
qw{tempdir
};
232 use GnuPG
::Interface
;
235 my $REVISION = '$Rev$';
236 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
237 my $VERSION = "0.0.0.$REVISION_NUMER";
240 my $config = $ENV{'HOME'} . '/.caffrc';
241 -f
$config or die "No file $config present. See caff(1).\n";
242 unless (scalar eval `cat $config`) {
243 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
246 $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
247 die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
248 die ("email is not defined.\n") unless defined $CONFIG{'email'};
249 die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
250 die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
251 for my $keyid (@
{$CONFIG{'keyid'}}) {
252 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
254 @
{$CONFIG{'keyid'}} = map { uc } @
{$CONFIG{'keyid'}};
255 $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
256 $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
257 $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
258 $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
259 $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
260 $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
261 $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
262 $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
263 $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
266 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
267 {foreach $uid (@uids) {
268 $OUT .= "\t".$uid."\n";
269 };} of your key {$key} signed by me.
271 Note that I did not upload your key to any keyservers. If you want this
272 new signature to be available to others, please upload it yourself.
273 With GnuPG this can be done using
274 gpg --keyserver subkeys.pgp.net --send-key {$key}
276 If you have any questions, don't hesitate to ask.
285 print "[NOTICE] $line\n";
289 print "[INFO] $line\n";
293 #print "[DEBUG] $line\n";
297 #print "[trace] $line\n";
301 #print "[trace2] $line\n";
306 stdin
=> IO
::Handle
->new(),
307 stdout
=> IO
::Handle
->new(),
308 stderr
=> IO
::Handle
->new(),
309 status
=> IO
::Handle
->new() );
310 my $handles = GnuPG
::Handles
->new( %fds );
311 return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
314 sub readwrite_gpg
($$$$$%) {
315 my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
317 trace
("Entering readwrite_gpg.");
319 my ($first_line, undef) = split /\n/, $in;
320 debug
("readwrite_gpg sends ".(defined $first_line ?
$first_line : "<nothing>"));
322 local $INPUT_RECORD_SEPARATOR = undef;
323 my $sout = IO
::Select
->new();
324 my $sin = IO
::Select
->new();
327 trace
("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ?
$statusfd : 'undef').".");
329 $inputfd->blocking(0);
330 $stdoutfd->blocking(0);
331 $statusfd->blocking(0) if defined $statusfd;
332 $stderrfd->blocking(0);
333 $sout->add($stdoutfd);
334 $sout->add($stderrfd);
335 $sout->add($statusfd) if defined $statusfd;
338 my ($stdout, $stderr, $status) = ("", "", "");
339 my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
340 trace
("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
342 my $readwrote_stuff_this_time = 0;
343 my $do_not_wait_on_select = 0;
344 my ($readyr, $readyw, $written);
345 while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
346 if (defined $exitwhenstatusmatches) {
347 if ($status =~ /$exitwhenstatusmatches/m) {
348 trace
("readwrite_gpg found match on $exitwhenstatusmatches");
349 if ($readwrote_stuff_this_time) {
350 trace
("read/write some more\n");
351 $do_not_wait_on_select = 1;
353 trace
("that's it in our while loop.\n");
359 $readwrote_stuff_this_time = 0;
360 trace
("select waiting for ".($sout->count())." fds.");
361 ($readyr, $readyw, undef) = IO
::Select
::select($sout, $sin, undef, $do_not_wait_on_select ?
0 : 1);
362 trace
("ready: write: ".(defined $readyw ?
scalar @
$readyw : 0 )."; read: ".(defined $readyr ?
scalar @
$readyr : 0));
363 for my $wfd (@
$readyw) {
364 $readwrote_stuff_this_time = 1;
365 if (length($in) != $offset) {
366 trace
("writing to $wfd.");
367 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
370 if ($offset == length($in)) {
371 trace
("writing to $wfd done.");
372 unless ($options{'nocloseinput'}) {
374 trace
("$wfd closed.");
381 next unless (defined(@
$readyr)); # Wait some more.
383 for my $rfd (@
$readyr) {
384 $readwrote_stuff_this_time = 1;
386 trace
("reading from $rfd done.");
391 trace
("reading from $rfd.");
392 if ($rfd == $stdoutfd) {
394 trace2
("stdout is now $stdout\n================");
397 if (defined $statusfd && $rfd == $statusfd) {
399 trace2
("status is now $status\n================");
402 if ($rfd == $stderrfd) {
404 trace2
("stderr is now $stderr\n================");
409 trace
("readwrite_gpg done.");
410 return ($stdout, $stderr, $status);
414 my ($question, $default) = @_;
417 print $question,' ',($default ?
'[Y/n]' : '[y/N]'), ' ';
420 last if ((defined $answer) && (length $answer <= 1));
424 my $result = $default;
425 $result = 1 if $answer =~ /y/i;
426 $result = 0 if $answer =~ /n/i;
434 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
435 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
436 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
437 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
438 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
441 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.";
443 my $KEYSBASE = $CONFIG{'caffhome'}.'/keys';
444 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
446 -d
$KEYSBASE || mkpath
($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
447 -d
$GNUPGHOME || mkpath
($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
450 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
451 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
456 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.\n";
460 my ($fd, $exitcode) = @_;
462 print $fd "Usage: $PROGRAM_NAME [-mMR] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
463 print $fd "Consult the manual page for more information.\n";
468 # export key $keyid from $gnupghome
471 my ($gnupghome, $keyid) = @_;
473 my $gpg = GnuPG
::Interface
->new();
474 $gpg->call( $CONFIG{'gpg'} );
475 $gpg->options->hash_init(
476 'homedir' => $gnupghome,
478 $gpg->options->meta_interactive( 0 );
479 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
480 my $pid = $gpg->export_keys(handles
=> $handles, command_args
=> [ $keyid ]);
481 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
488 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
491 my ($gnupghome, $asciikey) = @_;
493 my $gpg = GnuPG
::Interface
->new();
494 $gpg->call( $CONFIG{'gpg'} );
495 $gpg->options->hash_init( 'homedir' => $gnupghome );
496 $gpg->options->meta_interactive( 0 );
497 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
498 my $pid = $gpg->import_keys(handles
=> $handles);
499 my ($stdout, $stderr, $status) = readwrite_gpg
($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
502 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
510 # Send an email to $address. If $can_encrypt is true then the mail
511 # will be PGP/MIME encrypted to $longkeyid.
513 # $longkeyid, $uid, and @attached will be used in the email and the template.
515 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
516 sub send_mail
($$$@
) {
517 my ($address, $can_encrypt, $key_id, @keys) = @_;
519 my $template = Text
::Template
->new(TYPE
=> 'STRING', SOURCE
=> $CONFIG{'mail-template'})
520 or die "Error creating template: $Text::Template::ERROR";
523 for my $key (@keys) {
524 push @uids, $key->{'text'};
526 my $message = $template->fill_in(HASH
=> { key
=> $key_id,
528 owner
=> $CONFIG{'owner'}})
529 or die "Error filling template in: $Text::Template::ERROR";
531 my $message_entity = MIME
::Entity
->build(
532 Type
=> "text/plain",
534 Disposition
=> 'inline',
538 for my $key (@keys) {
539 $message_entity->attach(
540 Type
=> "application/pgp-keys",
541 Disposition
=> 'attachment',
543 Description
=> "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
544 Data
=> $key->{'key'},
545 Filename
=> "0x$key_id.".$key->{'serial'}.".asc");
549 my $message = $message_entity->stringify();
551 my $gpg = GnuPG
::Interface
->new();
552 $gpg->call( $CONFIG{'gpg'} );
553 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
554 'extra_args' => '--always-trust',
556 $gpg->options->meta_interactive( 0 );
557 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
558 $gpg->options->push_recipients( $key_id );
559 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
560 my $pid = $gpg->encrypt(handles
=> $handles);
561 my ($stdout, $stderr, $status) = readwrite_gpg
($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
564 warn ("No data from gpg for list-key $key_id\n");
569 $message_entity = MIME
::Entity
->build(
570 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"');
572 $message_entity->attach(
573 Type
=> "application/pgp-encrypted",
574 Disposition
=> 'attachment',
576 Data
=> "Version: 1\n");
578 $message_entity->attach(
579 Type
=> "application/octet-stream",
580 Filename
=> 'msg.asc',
581 Disposition
=> 'inline',
586 $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
587 $message_entity->head->add("To", $address);
588 $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
589 $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
590 $message_entity->head->add("User-Agent", $USER_AGENT);
591 $message_entity->send();
592 $message_entity->stringify();
596 # clean up a UID so that it can be used on the FS.
598 sub sanitize_uid
($) {
602 $good_uid =~ tr
#/:\\#_#;
603 trace2
("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
607 sub delete_signatures
($$$$$$) {
608 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
610 my $signed_by_me = 0;
612 my ($stdout, $stderr, $status) =
613 readwrite_gpg
("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT, nocloseinput
=> 1);
615 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
616 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
617 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
618 $stdout =~ s/\n/\\n/g;
619 notice
("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
620 my $line = pop @sigline;
622 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
623 debug
("[sigremoval] doing line $line.");
624 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
625 if ($signer eq $longkeyid) {
626 debug
("[sigremoval] selfsig ($signer).");
628 } elsif (grep { $signer eq $_ } @
{$keyids}) {
629 debug
("[sigremoval] signed by us ($signer).");
631 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created;
633 debug
("[sigremoval] not interested in that sig ($signer).");
637 debug
("[sigremoval] no sig line here, only got: ".$stdout);
639 ($stdout, $stderr, $status) =
640 readwrite_gpg
($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput
=> 1);
643 return $signed_by_me;
652 Getopt
::Long
::config
('bundling');
654 '-h' => \
$params->{'help'},
655 '--help' => \
$params->{'help'},
656 '--version' => \
$params->{'version'},
657 '-V' => \
$params->{'version'},
658 '-u=s' => \
$params->{'local-user'},
659 '--local-user=s' => \
$params->{'local-user'},
660 '-m' => \
$params->{'mail'},
661 '--mail' => \
$params->{'mail'},
662 '-M' => \
$params->{'no-mail'},
663 '--no-mail' => \
$params->{'no-mail'},
664 '-R' => \
$params->{'no-download'},
665 '--no-download' => \
$params->{'no-download'},
669 if ($params->{'help'}) {
672 if ($params->{'version'}) {
676 usage
(\
*STDERR
, 1) unless scalar @ARGV >= 1;
680 if ($params->{'local-user'}) {
681 $USER = $params->{'local-user'};
683 unless ($USER =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{32}|[A-Z0-9]{40})$/i) {
684 print STDERR
"-u $USER is not a keyid.\n";
690 for my $keyid (@ARGV) {
692 unless ($keyid =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{32}|[A-Z0-9]{40})$/i) {
693 print STDERR
"$keyid is not a keyid.\n";
696 push @KEYIDS, uc($keyid);
699 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
700 $CONFIG{'no-mail'} = $params->{'no-mail'} if defined $params->{'no-mail'};
701 $CONFIG{'mail'} = $params->{'mail'} if defined $params->{'mail'};
707 my $gpg = GnuPG
::Interface
->new();
708 $gpg->call( $CONFIG{'gpg'} );
709 $gpg->options->hash_init(
710 'homedir' => $GNUPGHOME,
711 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
712 $gpg->options->meta_interactive( 0 );
713 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
714 $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
715 my $pid = $gpg->list_public_keys(handles
=> $handles, command_args
=> $CONFIG{'keyid'});
716 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
719 warn ("No data from gpg for list-key\n");
722 foreach my $keyid (@
{$CONFIG{'keyid'}}) {
723 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
724 info
("Importing $keyid");
725 system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
729 #############################
730 # receive keys from keyserver
731 #############################
733 if ($CONFIG{'no-download'}) {
734 @keyids_ok = @KEYIDS;
736 my $gpg = GnuPG
::Interface
->new();
737 $gpg->call( $CONFIG{'gpg'} );
738 $gpg->options->hash_init(
739 'homedir' => $GNUPGHOME,
740 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
741 $gpg->options->meta_interactive( 0 );
742 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
744 my %local_keyids = map { $_ => 1 } @KEYIDS;
745 info
("fetching keys, this will take a while...");
746 my $pid = $gpg->recv_keys(handles
=> $handles, command_args
=> [ @KEYIDS ]);
747 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
750 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
753 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
754 for my $line (split /\n/, $status) {
755 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
756 my $imported_key = $1;
757 if (not exists $local_keyids{$imported_key}) {
758 warn("Imported unexpected key; got: $imported_key.\n");
761 info
("Imported $imported_key");
762 delete $local_keyids{$imported_key};
763 unshift @keyids_ok, $imported_key;
766 notice
("Import failed for: ". (join ' ', keys %local_keyids).".") if scalar %local_keyids;
772 unless ($CONFIG{'no-sign'}) {
773 info
("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
774 for my $keyid (@keyids_ok) {
776 push @command, $CONFIG{'gpg-sign'};
777 push @command, '--local-user', $USER if (defined $USER);
778 push @command, "--homedir=$GNUPGHOME";
779 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
780 push @command, '--edit', $keyid;
781 push @command, 'sign';
782 print join(' ', @command),"\n";
791 for my $keyid (@keyids_ok) {
794 my $gpg = GnuPG
::Interface
->new();
795 $gpg->call( $CONFIG{'gpg'} );
796 $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
797 $gpg->options->meta_interactive( 0 );
798 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
799 $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
800 my $pid = $gpg->list_public_keys(handles
=> $handles, command_args
=> [ $keyid ]);
801 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
804 warn ("No data from gpg for list-key $keyid\n");
807 my @publine = grep { /^pub/ } (split /\n/, $stdout);
808 if (scalar @publine == 0) {
809 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
812 my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
813 if (scalar @publine > 0) {
814 warn ("More than one key matched $keyid. Try to specify the long keyid or fingerprint\n");
817 unless (defined $longkeyid) {
818 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
821 unless (defined $flags) {
822 warn ("Didn't find flags in --list-key of key $keyid.\n");
825 my $can_encrypt = $flags =~ /E/;
829 my $asciikey = export_key
($GNUPGHOME, $keyid);
830 if ($asciikey eq '') {
831 warn ("No data from gpg for export $keyid\n");
838 my $this_uid_text = '';
840 debug
("Doing key $keyid, uid $uid_number");
841 my $tempdir = tempdir
( "caff-$keyid-XXXXX", DIR
=> '/tmp/', CLEANUP
=> 1);
843 # import into temporary gpghome
844 ###############################
845 my $result = import_key
($tempdir, $asciikey);
847 warn ("Could not import $keyid into temporary gnupg.\n");
853 $gpg = GnuPG
::Interface
->new();
854 $gpg->call( $CONFIG{'gpg-delsig'} );
855 $gpg->options->hash_init(
856 'homedir' => $tempdir,
857 'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
858 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
859 $pid = $gpg->wrap_call(
860 commands
=> [ '--edit' ],
861 command_args
=> [ $keyid ],
862 handles
=> $handles );
864 debug
("Starting edit session");
865 ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
869 my $number_of_subkeys = 0;
874 debug
("Parsing stdout output.");
875 for my $line (split /\n/, $stdout) {
876 debug
("Checking line $line");
877 my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
878 if ($type eq 'sub') {
879 $number_of_subkeys++;
881 next unless ($type eq 'uid' || $type eq 'uat');
882 debug
("line is interesting.");
883 if ($uid_number != $i) {
884 debug
("mark for deletion.");
885 readwrite_gpg
("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
890 $this_uid_text = ($type eq 'uid') ?
$uidtext : '[attribute]';
891 $is_uat = $type eq 'uat';
895 debug
("Parsing stdout output done.");
897 debug
("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
898 info
("key $keyid done.");
902 my $prune_some_sigs_on_uid;
903 my $prune_all_sigs_on_uid;
905 debug
("handling attribute userid of key $keyid.");
906 if ($uid_number == 1) {
907 debug
(" attribute userid is #1, unmarking #2 for deletion.");
908 readwrite_gpg
("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
910 $prune_some_sigs_on_uid = 1;
911 $prune_all_sigs_on_uid = 2;
913 debug
("attribute userid is not #1, unmarking #1 for deletion.");
914 readwrite_gpg
("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
916 $prune_some_sigs_on_uid = 2;
917 $prune_all_sigs_on_uid = 1;
920 $prune_some_sigs_on_uid = 1;
924 debug
("need to delete $delete_some uids.");
925 readwrite_gpg
("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT, nocloseinput
=> 1);
926 readwrite_gpg
("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
931 if ($number_of_subkeys > 0) {
932 for (my $i=1; $i<=$number_of_subkeys; $i++) {
933 readwrite_gpg
("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
935 readwrite_gpg
("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput
=> 1);
936 readwrite_gpg
("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
941 readwrite_gpg
("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # mark uid for delsig
942 my $signed_by_me = delete_signatures
($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
943 readwrite_gpg
("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # unmark uid from delsig
944 if (defined $prune_all_sigs_on_uid) {
945 readwrite_gpg
("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # mark uid for delsig
946 delete_signatures
($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
947 readwrite_gpg
("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # unmark uid from delsig
951 readwrite_gpg
("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
954 my $asciikey = export_key
($tempdir, $keyid);
955 if ($asciikey eq '') {
956 warn ("No data from gpg for export $keyid\n");
961 if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
962 my $write = ask
("Signature on $this_uid_text is old. Export?", 0);
965 my $keydir = "$KEYSBASE/$DATE_STRING";
966 -d
$keydir || mkpath
($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
968 my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid
($this_uid_text).".asc";
969 open (KEY
, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
973 push @UIDS, { text
=> $this_uid_text, key
=> $asciikey, serial
=> $uid_number, "is_uat" => $is_uat };
975 info
("$longkeyid $uid_number $this_uid_text done.");
977 info
("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
981 if (scalar @UIDS == 0) {
982 info
("found no signed uids for $keyid");
984 next if $CONFIG{'no-mail'}; # do not send mail
987 for my $uid (@UIDS) {
988 trace
("UID: $uid->{'text'}\n");
989 if ($uid->{'is_uat'}) {
990 my $attach = ask
("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
991 push @attached, $uid if $attach;
992 } elsif ($uid->{'text'} !~ /@/) {
993 my $attach = ask
("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
994 push @attached, $uid if $attach;
998 notice
("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
999 for my $uid (@UIDS) {
1000 if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1001 my $address = $uid->{'text'};
1002 $address =~ s/.*<(.*)>.*/$1/;
1003 if ($CONFIG{'mail'} or ask
("Send mail to '$address' for $uid->{'text'}?", 1)) {
1004 my $mail = send_mail
($address, $can_encrypt, $longkeyid, $uid, @attached);
1006 my $keydir = "$KEYSBASE/$DATE_STRING";
1007 my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid
($uid->{'text'});
1008 open (KEY
, ">$mailfile") or die ("Cannot open $mailfile: $!\n");