]>
git.sthu.org Git - pgp-tools.git/blob - caff/caff
014b8387e0176502583e93bda60964e0ba1dd350
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> [-eEmMRS] [-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<-e>, B<--export-old>
61 Export old signatures. Default is to ask the user for each old signature.
63 =item B<-E>, B<--no-export-old>
65 Do not export old signatures. Default is to ask the user for each old
68 =item B<-m>, B<--mail>
70 Send mail after signing. Default is to ask the user for each uid.
72 =item B<-M>, B<--no-mail>
74 Do not send mail after signing. Default is to ask the user for each uid.
76 =item B<-R>, B<--no-download>
78 Do not retrieve the key to be signed from a keyserver.
80 =item B<-S>, B<--no-sign>
84 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
86 Select the key that is used for signing, in case you have more than one key.
94 =item $HOME/.caffrc - configuration file
98 =head1 CONFIGURATION FILE OPTIONS
100 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
104 $CONFIG{owner} = q{Peter Palfrader};
105 $CONFIG{email} = q{peter@palfrader.org};
106 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
108 =head2 Required basic settings
112 =item B<owner> [string]
114 Your name. B<REQUIRED>.
116 =item B<email> [string]
118 Your email address, used in From: lines. B<REQUIRED>.
120 =item B<keyid> [list of keyids]
122 A list of your keys. This is used to determine which signatures to keep
123 in the pruning step. If you select a key using B<-u> it has to be in
124 this list. B<REQUIRED>.
126 =head2 General settings
128 =item B<caffhome> [string]
130 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
132 =head2 GnuPG settings
134 =item B<gpg> [string]
136 Path to the GnuPG binary. Default: B<gpg>.
138 =item B<gpg-sign> [string]
140 Path to the GnuPG binary which is used to sign keys. Default: what
143 =item B<gpg-delsig> [string]
145 Path to the GnuPG binary which is used to split off signatures. This was
146 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
149 =item B<secret-keyring> [string]
151 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
153 =item B<also-encrypt-to> [keyid]
155 An additional keyid to encrypt messages to. Default: none.
157 =item B<gpg-sign-args> [string]
159 Additional arguments to pass to gpg. Default: none.
161 =head2 Keyserver settings
163 =item B<keyserver> [string]
165 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
167 =item B<no-download> [boolean]
169 If true, then skip the step of fetching keys from the keyserver.
172 =head2 Signing settings
174 =item B<no-sign> [boolean]
176 If true, then skip the signing step. Default: B<0>.
178 =item B<ask-sign> [boolean]
180 If true, then pause before continuing to the signing step.
181 This is useful for offline signing. Default: B<0>.
183 =item B<export-sig-age> [seconds]
185 Don't export UIDs by default, on which your latest signature is older
186 than this age. Default: B<24*60*60> (i.e. one day).
190 =item B<mail> [boolean]
192 Do not prompt for sending mail, just do it. Default: B<0>.
194 =item B<no-mail> [boolean]
196 Do not prompt for sending mail. The messages are still written to
197 $CONFIG{caffhome}/keys/. Default: B<0>.
199 =item B<mail-template> [string]
201 Email template which is used as the body text for the email sent out
202 instead of the default text if specified. The following perl variables
203 can be used in the template:
207 =item B<{owner}> [string]
209 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
211 =item B<{key}> [string]
213 The keyid of the key you signed.
215 =item B<{@uids}> [array]
217 The UIDs for which signatures are included in the mail.
221 =item B<bcc> [string]
223 Address to send blind carbon copies to when sending mail.
232 =item Peter Palfrader <peter@palfrader.org>
234 =item Christoph Berg <cb@df7cb.de>
240 http://pgp-tools.alioth.debian.org/
248 use File
:: Temp
qw{ tempdir
};
254 use GnuPG
:: Interface
;
257 my $REVISION = ' $Rev $' ;
258 my ( $REVISION_NUMER ) = $REVISION =~ /(\d+)/ ;
259 my $VERSION = "0.0.0. $REVISION_NUMER " ;
262 my $config = $ENV { 'HOME' } . '/.caffrc' ;
263 - f
$config or die "No file $config present. See caff(1). \n " ;
264 unless ( scalar eval `cat $config ` ) {
265 die "Couldn't parse $config : $EVAL_ERROR \n " if $EVAL_ERROR ;
268 $CONFIG { 'caffhome' }= $ENV { 'HOME' }. '/.caff' unless defined $CONFIG { 'caffhome' };
269 die ( "owner is not defined. \n " ) unless defined $CONFIG { 'owner' };
270 die ( "email is not defined. \n " ) unless defined $CONFIG { 'email' };
271 die ( "keyid is not defined. \n " ) unless defined $CONFIG { 'keyid' };
272 die ( "keyid is not an array ref \n " ) unless ( ref $CONFIG { 'keyid' } eq 'ARRAY' );
273 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
274 $keyid =~ /^[A-F0-9]{16}$/i or die ( "key $keyid is not a long (16 digit) keyid. \n " );
276 @
{ $CONFIG { 'keyid' }} = map { uc } @
{ $CONFIG { 'keyid' }};
277 $CONFIG { 'export-sig-age' }= 24 * 60 * 60 unless defined $CONFIG { 'export-sig-age' };
278 $CONFIG { 'keyserver' } = 'subkeys.pgp.net' unless defined $CONFIG { 'keyserver' };
279 $CONFIG { 'gpg' } = 'gpg' unless defined $CONFIG { 'gpg' };
280 $CONFIG { 'gpg-sign' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-sign' };
281 $CONFIG { 'gpg-delsig' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-delsig' };
282 $CONFIG { 'secret-keyring' } = $ENV { 'HOME' }. '/.gnupg/secring.gpg' unless defined $CONFIG { 'secret-keyring' };
283 $CONFIG { 'no-download' } = 0 unless defined $CONFIG { 'no-download' };
284 $CONFIG { 'no-sign' } = 0 unless defined $CONFIG { 'no-sign' };
285 $CONFIG { 'mail-template' } = <<'EOM' unless defined $CONFIG {'mail-template'};
288 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
289 {foreach $uid ( @uids ) {
290 $OUT .= " \t ". $uid ." \n ";
291 };} of your key { $key } signed by me.
293 Note that I did not upload your key to any keyservers.
294 If you have multiple user ids, I sent the signature for each user id
295 separately to that user id's associated email address. You can import
296 the signatures by running each through `gpg --import`.
298 If you want this new signature to be available to others, please upload
299 it yourself. With GnuPG this can be done using
300 gpg --keyserver subkeys.pgp.net --send-key { $key }
302 If you have any questions, don't hesitate to ask.
311 print "[NOTICE] $line \n " ;
315 print "[INFO] $line \n " ;
319 #print "[DEBUG] $line\n";
323 #print "[trace] $line\n";
327 #print "[trace2] $line\n";
332 stdin
=> IO
:: Handle
-> new (),
333 stdout
=> IO
:: Handle
-> new (),
334 stderr
=> IO
:: Handle
-> new (),
335 status
=> IO
:: Handle
-> new () );
336 my $handles = GnuPG
:: Handles
-> new ( %fds );
337 return ( $fds { 'stdin' }, $fds { 'stdout' }, $fds { 'stderr' }, $fds { 'status' }, $handles );
340 sub readwrite_gpg
($$$$$%) {
341 my ( $in , $inputfd , $stdoutfd , $stderrfd , $statusfd , %options ) = @_ ;
343 trace
( "Entering readwrite_gpg." );
345 my ( $first_line , undef ) = split /\n/ , $in ;
346 debug
( "readwrite_gpg sends " .( defined $first_line ?
$first_line : "<nothing>" ));
348 local $INPUT_RECORD_SEPARATOR = undef ;
349 my $sout = IO
:: Select
-> new ();
350 my $sin = IO
:: Select
-> new ();
353 trace
( "input is $inputfd ; output is $stdoutfd ; err is $stderrfd ; status is " .( defined $statusfd ?
$statusfd : 'undef' ). "." );
355 $inputfd -> blocking ( 0 );
356 $stdoutfd -> blocking ( 0 );
357 $statusfd -> blocking ( 0 ) if defined $statusfd ;
358 $stderrfd -> blocking ( 0 );
359 $sout -> add ( $stdoutfd );
360 $sout -> add ( $stderrfd );
361 $sout -> add ( $statusfd ) if defined $statusfd ;
364 my ( $stdout , $stderr , $status ) = ( "" , "" , "" );
365 my $exitwhenstatusmatches = $options { 'exitwhenstatusmatches' };
366 trace
( "doing stuff until we find $exitwhenstatusmatches " ) if defined $exitwhenstatusmatches ;
368 my $readwrote_stuff_this_time = 0 ;
369 my $do_not_wait_on_select = 0 ;
370 my ( $readyr , $readyw , $written );
371 while ( $sout -> count () > 0 || ( defined ( $sin ) && ( $sin -> count () > 0 ))) {
372 if ( defined $exitwhenstatusmatches ) {
373 if ( $status =~ /$exitwhenstatusmatches/m ) {
374 trace
( "readwrite_gpg found match on $exitwhenstatusmatches " );
375 if ( $readwrote_stuff_this_time ) {
376 trace
( "read/write some more \n " );
377 $do_not_wait_on_select = 1 ;
379 trace
( "that's it in our while loop. \n " );
385 $readwrote_stuff_this_time = 0 ;
386 trace
( "select waiting for " .( $sout -> count ()). " fds." );
387 ( $readyr , $readyw , undef ) = IO
:: Select
:: select ( $sout , $sin , undef , $do_not_wait_on_select ?
0 : 1 );
388 trace
( "ready: write: " .( defined $readyw ?
scalar @
$readyw : 0 ). "; read: " .( defined $readyr ?
scalar @
$readyr : 0 ));
389 for my $wfd ( @
$readyw ) {
390 $readwrote_stuff_this_time = 1 ;
391 if ( length ( $in ) != $offset ) {
392 trace
( "writing to $wfd ." );
393 $written = $wfd -> syswrite ( $in , length ( $in ) - $offset , $offset );
396 if ( $offset == length ( $in )) {
397 trace
( "writing to $wfd done." );
398 unless ( $options { 'nocloseinput' }) {
400 trace
( " $wfd closed." );
407 next unless ( defined ( @
$readyr )); # Wait some more.
409 for my $rfd ( @
$readyr ) {
410 $readwrote_stuff_this_time = 1 ;
412 trace
( "reading from $rfd done." );
417 trace
( "reading from $rfd ." );
418 if ( $rfd == $stdoutfd ) {
420 trace2
( "stdout is now $stdout \n ================" );
423 if ( defined $statusfd && $rfd == $statusfd ) {
425 trace2
( "status is now $status \n ================" );
428 if ( $rfd == $stderrfd ) {
430 trace2
( "stderr is now $stderr \n ================" );
435 trace
( "readwrite_gpg done." );
436 return ( $stdout , $stderr , $status );
440 my ( $question , $default , $forceyes , $forceno ) = @_ ;
441 return $default if $forceyes and $forceno ;
442 return 1 if $forceyes ;
443 return 0 if $forceno ;
446 print $question , ' ' ,( $default ?
'[Y/n]' : '[y/N]' ), ' ' ;
449 last if (( defined $answer ) && ( length $answer <= 1 ));
453 my $result = $default ;
454 $result = 1 if $answer =~ /y/i ;
455 $result = 0 if $answer =~ /n/i ;
463 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt' ;
464 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay' ;
465 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig' ;
466 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)' ;
467 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey' ;
470 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
472 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
473 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
475 - d
$KEYSBASE || mkpath
( $KEYSBASE , 0 , 0700 ) or die ( "Cannot create $KEYSBASE : $! \n " );
476 - d
$GNUPGHOME || mkpath
( $GNUPGHOME , 0 , 0700 ) or die ( "Cannot create $GNUPGHOME : $! \n " );
479 my ( $sec , $min , $hour , $mday , $mon , $year , $wday , $yday , $isdst ) = localtime ( $NOW );
480 my $DATE_STRING = sprintf ( " %04d - %02d - %02d " , $year + 1900 , $mon + 1 , $mday );
485 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
489 my ( $fd , $exitcode ) = @_ ;
491 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
492 print $fd "Consult the manual page for more information. \n " ;
497 # export key $keyid from $gnupghome
500 my ( $gnupghome , $keyid ) = @_ ;
502 my $gpg = GnuPG
:: Interface
-> new ();
503 $gpg -> call ( $CONFIG { 'gpg' } );
504 if ( defined $gnupghome ) {
505 $gpg -> options -> hash_init (
506 'homedir' => $gnupghome ,
507 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
510 $gpg -> options -> hash_init (
511 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
514 $gpg -> options -> meta_interactive ( 0 );
515 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
516 my $pid = $gpg -> export_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
517 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
524 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
527 my ( $gnupghome , $asciikey ) = @_ ;
529 my $gpg = GnuPG
:: Interface
-> new ();
530 $gpg -> call ( $CONFIG { 'gpg' } );
531 $gpg -> options -> hash_init (
532 'homedir' => $gnupghome ,
533 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ] );
534 $gpg -> options -> meta_interactive ( 0 );
535 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
536 my $pid = $gpg -> import_keys ( handles
=> $handles );
537 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $asciikey , $inputfd , $stdoutfd , $stderrfd , $statusfd );
540 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
548 # Send an email to $address. If $can_encrypt is true then the mail
549 # will be PGP/MIME encrypted to $longkeyid.
551 # $longkeyid, $uid, and @attached will be used in the email and the template.
553 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
554 sub send_mail
($$$ @
) {
555 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
557 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
558 or die "Error creating template: $Text ::Template::ERROR" ;
561 for my $key ( @keys ) {
562 push @uids , $key ->{ 'text' };
564 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
566 owner
=> $CONFIG { 'owner' }})
567 or die "Error filling template in: $Text ::Template::ERROR" ;
569 my $message_entity = MIME
:: Entity
-> build (
570 Type
=> "text/plain" ,
572 Disposition
=> 'inline' ,
576 for my $key ( @keys ) {
577 $message_entity -> attach (
578 Type
=> "application/pgp-keys" ,
579 Disposition
=> 'attachment' ,
581 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). ')' ,
582 Data
=> $key ->{ 'key' },
583 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".asc" );
587 my $message = $message_entity -> stringify ();
589 my $gpg = GnuPG
:: Interface
-> new ();
590 $gpg -> call ( $CONFIG { 'gpg' } );
591 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
592 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
594 $gpg -> options -> meta_interactive ( 0 );
595 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
596 $gpg -> options -> push_recipients ( $key_id );
597 $gpg -> options -> push_recipients ( $CONFIG { 'also-encrypt-to' } ) if defined $CONFIG { 'also-encrypt-to' };
598 my $pid = $gpg -> encrypt ( handles
=> $handles );
599 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $message , $inputfd , $stdoutfd , $stderrfd , $statusfd );
602 warn ( "No data from gpg for list-key $key_id \n " );
607 $message_entity = MIME
:: Entity
-> build (
608 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
610 $message_entity -> attach (
611 Type
=> "application/pgp-encrypted" ,
612 Disposition
=> 'attachment' ,
614 Data
=> "Version: 1 \n " );
616 $message_entity -> attach (
617 Type
=> "application/octet-stream" ,
618 Filename
=> 'msg.asc' ,
619 Disposition
=> 'inline' ,
624 $message_entity -> head -> add ( "Subject" , "Your signed PGP key 0x $key_id " );
625 $message_entity -> head -> add ( "To" , $address );
626 $message_entity -> head -> add ( "From" , '"' . $CONFIG { 'owner' }. '" <' . $CONFIG { 'email' }. '>' );
627 $message_entity -> head -> add ( "Bcc" , $CONFIG { 'bcc' }) if defined $CONFIG { 'bcc' };
628 $message_entity -> head -> add ( "User-Agent" , $USER_AGENT );
629 $message_entity -> send ();
630 $message_entity -> stringify ();
634 # clean up a UID so that it can be used on the FS.
636 sub sanitize_uid
($) {
640 $good_uid =~ tr
#/:\\#_#;
641 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
645 sub delete_signatures
($$$$$$) {
646 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
648 my $signed_by_me = 0 ;
650 my ( $stdout , $stderr , $status ) =
651 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
653 while ( $status =~ /$KEYEDIT_DELSIG_PROMPT/m ) {
654 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
655 my @sigline = grep { /^sig/ } ( split /\n/ , $stdout );
656 $stdout =~ s/\n/\\n/g ;
657 notice
( "[sigremoval] why are there " .( scalar @sigline ). " siglines in that part of the dialog!? got: $stdout " ) if scalar @sigline >= 2 ; # XXX
658 my $line = pop @sigline ;
660 if ( defined $line ) { # only if we found a sig here - we never remove revocation packets for instance
661 debug
( "[sigremoval] doing line $line ." );
662 my ( undef , undef , undef , undef , $signer , $created , undef , undef , undef ) = split /:/ , $line ;
663 if ( $signer eq $longkeyid ) {
664 debug
( "[sigremoval] selfsig ( $signer )." );
666 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
667 debug
( "[sigremoval] signed by us ( $signer )." );
669 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
671 debug
( "[sigremoval] not interested in that sig ( $signer )." );
675 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
677 ( $stdout , $stderr , $status ) =
678 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
681 return $signed_by_me ;
690 Getopt
:: Long
:: config
( 'bundling' );
692 '-h' => \
$params ->{ 'help' },
693 '--help' => \
$params ->{ 'help' },
694 '--version' => \
$params ->{ 'version' },
695 '-V' => \
$params ->{ 'version' },
696 '-u=s' => \
$params ->{ 'local-user' },
697 '--local-user=s' => \
$params ->{ 'local-user' },
698 '-e' => \
$params ->{ 'export-old' },
699 '--export-old' => \
$params ->{ 'export-old' },
700 '-E' => \
$params ->{ 'no-export-old' },
701 '--no-export-old' => \
$params ->{ 'no-export-old' },
702 '-m' => \
$params ->{ 'mail' },
703 '--mail' => \
$params ->{ 'mail' },
704 '-M' => \
$params ->{ 'no-mail' },
705 '--no-mail' => \
$params ->{ 'no-mail' },
706 '-R' => \
$params ->{ 'no-download' },
707 '--no-download' => \
$params ->{ 'no-download' },
708 '-S' => \
$params ->{ 'no-sign' },
709 '--no-sign' => \
$params ->{ 'no-sign' },
713 if ( $params ->{ 'help' }) {
716 if ( $params ->{ 'version' }) {
720 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
724 if ( $params ->{ 'local-user' }) {
725 $USER = $params ->{ 'local-user' };
727 unless ( $USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i ) {
728 print STDERR
"-u $USER is not a keyid. \n " ;
734 for my $keyid ( @ARGV ) {
736 unless ( $keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i ) {
737 print STDERR
" $keyid is not a keyid. \n " ;
740 push @KEYIDS , uc ( $keyid );
743 $CONFIG { 'no-download' } = $params ->{ 'no-download' } if defined $params ->{ 'no-download' };
744 $CONFIG { 'no-mail' } = $params ->{ 'no-mail' } if defined $params ->{ 'no-mail' };
745 $CONFIG { 'mail' } = $params ->{ 'mail' } if defined $params ->{ 'mail' };
746 $CONFIG { 'no-sign' } = $params ->{ 'no-sign' } if defined $params ->{ 'no-sign' };
752 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
753 my $gpg = GnuPG
:: Interface
-> new ();
754 $gpg -> call ( $CONFIG { 'gpg' } );
755 $gpg -> options -> hash_init (
756 'homedir' => $GNUPGHOME ,
757 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- fast
- list
- mode
} ] );
758 $gpg -> options -> meta_interactive ( 0 );
759 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
760 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> $keyid );
761 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
765 warn ( "No data from gpg for list-key \n " ); # There should be at least 'tru:' everywhere.
767 unless ( $stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m ) {
768 info
( "Key $keyid not found in caff's home. Getting it from your normal GnuPGHome." );
769 my $key = export_key
( undef , $keyid );
770 if (! defined $key || $key eq '' ) {
771 warn ( "Did not get key $keyid from your normal GnuPGHome \n " );
774 my $result = import_key
( $GNUPGHOME , $key );
776 warn ( "Could not import $keyid into caff's gnupghome. \n " );
782 #############################
783 # receive keys from keyserver
784 #############################
786 if ( $CONFIG { 'no-download' }) {
787 @keyids_ok = @KEYIDS ;
789 info
( "fetching keys, this will take a while..." );
791 my $gpg = GnuPG
:: Interface
-> new ();
792 $gpg -> call ( $CONFIG { 'gpg' } );
793 $gpg -> options -> hash_init (
794 'homedir' => $GNUPGHOME ,
795 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
}, '--keyserver=' . $CONFIG { 'keyserver' } ] );
796 $gpg -> options -> meta_interactive ( 0 );
797 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
798 my $pid = $gpg -> recv_keys ( handles
=> $handles , command_args
=> [ @KEYIDS ]);
799 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
802 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
805 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
806 my %local_keyids = map { $_ => 1 } @KEYIDS ;
807 for my $line ( split /\n/ , $status ) {
808 if ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/ ) {
809 my $imported_key = $1 ;
810 my $whole_fpr = $imported_key ;
811 my $long_keyid = substr ( $imported_key , - 16 );
812 my $short_keyid = substr ( $imported_key , - 8 );
814 for my $spec (( $whole_fpr , $long_keyid , $short_keyid )) {
815 $speced_key = $spec if $local_keyids { $spec };
817 unless ( $speced_key ) {
818 notice
( "Imported unexpected key; got: $imported_key \n " );
821 debug
( "Imported $imported_key for $speced_key " );
822 delete $local_keyids { $speced_key };
823 unshift @keyids_ok , $imported_key ;
824 } elsif ( $line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) / ) {
826 notice
( "got unknown reply from gpg: $line " );
829 if ( scalar %local_keyids ) {
830 notice
( "Import failed for: " . ( join ' ' , keys %local_keyids ). "." );
831 exit 1 unless ask
( "Some keys could not be imported - continue anyway?" , 0 );
835 unless ( @keyids_ok ) {
836 notice
( "No keys to sign found" );
843 if ( $CONFIG { 'ask-sign' } && ! $CONFIG { 'no-sign' }) {
844 $CONFIG { 'no-sign' } = ! ask
( "Continue with signing?" , 1 );
847 unless ( $CONFIG { 'no-sign' }) {
848 info
( "Sign the following keys according to your policy, then exit gpg with 'save' after signing each key" );
849 for my $keyid ( @keyids_ok ) {
851 push @command , $CONFIG { 'gpg-sign' };
852 push @command , '--local-user' , $USER if ( defined $USER );
853 push @command , "--homedir= $GNUPGHOME " ;
854 push @command , '--secret-keyring' , $CONFIG { 'secret-keyring' };
855 push @command , '--no-auto-check-trustdb' ;
856 push @command , '--trust-model=always' ;
857 push @command , '--edit' , $keyid ;
858 push @command , 'sign' ;
859 push @command , split ' ' , $CONFIG { 'gpg-sign-args' } || "" ;
860 print join ( ' ' , @command ), " \n " ;
869 for my $keyid ( @keyids_ok ) {
872 my $gpg = GnuPG
:: Interface
-> new ();
873 $gpg -> call ( $CONFIG { 'gpg' } );
874 $gpg -> options -> hash_init (
875 'homedir' => $GNUPGHOME ,
876 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
877 $gpg -> options -> meta_interactive ( 0 );
878 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
879 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
880 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
883 warn ( "No data from gpg for list-key $keyid \n " );
886 my @publine = grep { /^pub/ } ( split /\n/ , $stdout );
887 if ( scalar @publine == 0 ) {
888 warn ( "No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME ). \n " );
891 my ( undef , undef , undef , undef , $longkeyid , undef , undef , undef , undef , undef , undef , $flags ) = split /:/ , pop @publine ;
892 if ( scalar @publine > 0 ) {
893 warn ( "More than one key matched $keyid . Try to specify the long keyid or fingerprint \n " );
896 unless ( defined $longkeyid ) {
897 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
900 unless ( defined $flags ) {
901 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
904 my $can_encrypt = $flags =~ /E/ ;
908 my $asciikey = export_key
( $GNUPGHOME , $keyid );
909 if ( $asciikey eq '' ) {
910 warn ( "No data from gpg for export $keyid \n " );
917 my $this_uid_text = '' ;
919 debug
( "Doing key $keyid , uid $uid_number " );
920 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
922 # import into temporary gpghome
923 ###############################
924 my $result = import_key
( $tempdir , $asciikey );
926 warn ( "Could not import $keyid into temporary gnupg. \n " );
932 $gpg = GnuPG
:: Interface
-> new ();
933 $gpg -> call ( $CONFIG { 'gpg-delsig' } );
934 $gpg -> options -> hash_init (
935 'homedir' => $tempdir ,
936 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- command
- fd
= 0 -- no - tty
} ] );
937 ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
938 $pid = $gpg -> wrap_call (
939 commands
=> [ '--edit' ],
940 command_args
=> [ $keyid ],
941 handles
=> $handles );
943 debug
( "Starting edit session" );
944 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
948 my $number_of_subkeys = 0 ;
953 debug
( "Parsing stdout output." );
954 for my $line ( split /\n/ , $stdout ) {
955 debug
( "Checking line $line " );
956 my ( $type , undef , undef , undef , undef , undef , undef , undef , undef , $uidtext ) = split /:/ , $line ;
957 if ( $type eq 'sub' ) {
958 $number_of_subkeys ++;
960 next unless ( $type eq 'uid' || $type eq 'uat' );
961 debug
( "line is interesting." );
962 if ( $uid_number != $i ) {
963 debug
( "mark for deletion." );
964 readwrite_gpg
( " $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
969 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
970 $is_uat = $type eq 'uat' ;
974 debug
( "Parsing stdout output done." );
976 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
977 info
( "key $keyid done." );
981 my $prune_some_sigs_on_uid ;
982 my $prune_all_sigs_on_uid ;
984 debug
( "handling attribute userid of key $keyid ." );
985 if ( $uid_number == 1 ) {
986 debug
( " attribute userid is #1, unmarking #2 for deletion." );
987 readwrite_gpg
( "2 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
989 $prune_some_sigs_on_uid = 1 ;
990 $prune_all_sigs_on_uid = 2 ;
992 debug
( "attribute userid is not #1, unmarking #1 for deletion." );
993 readwrite_gpg
( "1 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
995 $prune_some_sigs_on_uid = 2 ;
996 $prune_all_sigs_on_uid = 1 ;
999 $prune_some_sigs_on_uid = 1 ;
1003 debug
( "need to delete $delete_some uids." );
1004 readwrite_gpg
( "deluid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT , nocloseinput
=> 1 );
1005 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1010 if ( $number_of_subkeys > 0 ) {
1011 for ( my $i = 1 ; $i <= $number_of_subkeys ; $i ++) {
1012 readwrite_gpg
( "key $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1014 readwrite_gpg
( "delkey \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT , nocloseinput
=> 1 );
1015 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1020 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1021 my $signed_by_me = delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $CONFIG { 'keyid' });
1022 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1023 if ( defined $prune_all_sigs_on_uid ) {
1024 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1025 delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , []);
1026 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1030 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1033 my $asciikey = export_key
( $tempdir , $keyid );
1034 if ( $asciikey eq '' ) {
1035 warn ( "No data from gpg for export $keyid \n " );
1039 if ( $signed_by_me ) {
1040 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
1041 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 , $params ->{ 'export-old' }, $params ->{ 'no-export-old' });
1044 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1045 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
1047 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
1048 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
1049 print KEY
$asciikey ;
1052 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
1054 info
( " $longkeyid $uid_number $this_uid_text done." );
1056 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
1060 if ( scalar @UIDS == 0 ) {
1061 info
( "found no signed uids for $keyid " );
1063 next if $CONFIG { 'no-mail' }; # do not send mail
1066 for my $uid ( @UIDS ) {
1067 trace
( "UID: $uid ->{'text'} \n " );
1068 if ( $uid ->{ 'is_uat' }) {
1069 my $attach = ask
( "UID $uid ->{'text'} is an attribute UID, attach it to every email sent?" , 1 );
1070 push @attached , $uid if $attach ;
1071 } elsif ( $uid ->{ 'text' } !~ /@/ ) {
1072 my $attach = ask
( "UID $uid ->{'text'} is no email address, attach it to every email sent?" , 1 );
1073 push @attached , $uid if $attach ;
1077 notice
( "Key has no encryption capabilities, mail will be sent unencrypted" ) unless $can_encrypt ;
1078 for my $uid ( @UIDS ) {
1079 if (! $uid ->{ 'is_uat' } && ( $uid ->{ 'text' } =~ /@/ )) {
1080 my $address = $uid ->{ 'text' };
1081 $address =~ s/.*<(.*)>.*/$1/ ;
1082 if ( ask
( "Send mail to ' $address ' for $uid ->{'text'}?" , 1 , $CONFIG { 'mail' })) {
1083 my $mail = send_mail
( $address , $can_encrypt , $longkeyid , $uid , @attached );
1085 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1086 my $mailfile = " $keydir / $longkeyid .mail." . $uid ->{ 'serial' }. "." . sanitize_uid
( $uid ->{ 'text' });
1087 open ( KEY
, "> $mailfile " ) or die ( "Cannot open $mailfile : $! \n " );