]>
git.sthu.org Git - pgp-tools.git/blob - caff/caff
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<export-sig-age> [seconds]
180 Don't export UIDs by default, on which your latest signature is older
181 than this age. Default: B<24*60*60> (i.e. one day).
185 =item B<mail> [boolean]
187 Do not prompt for sending mail, just do it. Default: B<0>.
189 =item B<no-mail> [boolean]
191 Do not prompt for sending mail. The messages are still written to
192 $CONFIG{caffhome}/keys/. Default: B<0>.
194 =item B<mail-template> [string]
196 Email template which is used as the body text for the email sent out
197 instead of the default text if specified. The following perl variables
198 can be used in the template:
202 =item B<{owner}> [string]
204 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
206 =item B<{key}> [string]
208 The keyid of the key you signed.
210 =item B<{@uids}> [array]
212 The UIDs for which signatures are included in the mail.
216 =item B<bcc> [string]
218 Address to send blind carbon copies to when sending mail.
227 =item Peter Palfrader <peter@palfrader.org>
229 =item Christoph Berg <cb@df7cb.de>
235 http://pgp-tools.alioth.debian.org/
243 use File
:: Temp
qw{ tempdir
};
249 use GnuPG
:: Interface
;
252 my $REVISION = ' $Rev $' ;
253 my ( $REVISION_NUMER ) = $REVISION =~ /(\d+)/ ;
254 my $VERSION = "0.0.0. $REVISION_NUMER " ;
257 my $config = $ENV { 'HOME' } . '/.caffrc' ;
258 - f
$config or die "No file $config present. See caff(1). \n " ;
259 unless ( scalar eval `cat $config ` ) {
260 die "Couldn't parse $config : $EVAL_ERROR \n " if $EVAL_ERROR ;
263 $CONFIG { 'caffhome' }= $ENV { 'HOME' }. '/.caff' unless defined $CONFIG { 'caffhome' };
264 die ( "owner is not defined. \n " ) unless defined $CONFIG { 'owner' };
265 die ( "email is not defined. \n " ) unless defined $CONFIG { 'email' };
266 die ( "keyid is not defined. \n " ) unless defined $CONFIG { 'keyid' };
267 die ( "keyid is not an array ref \n " ) unless ( ref $CONFIG { 'keyid' } eq 'ARRAY' );
268 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
269 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ( "key $keyid is not a long (16 digit) keyid. \n " );
271 @
{ $CONFIG { 'keyid' }} = map { uc } @
{ $CONFIG { 'keyid' }};
272 $CONFIG { 'export-sig-age' }= 24 * 60 * 60 unless defined $CONFIG { 'export-sig-age' };
273 $CONFIG { 'keyserver' } = 'subkeys.pgp.net' unless defined $CONFIG { 'keyserver' };
274 $CONFIG { 'gpg' } = 'gpg' unless defined $CONFIG { 'gpg' };
275 $CONFIG { 'gpg-sign' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-sign' };
276 $CONFIG { 'gpg-delsig' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-delsig' };
277 $CONFIG { 'secret-keyring' } = $ENV { 'HOME' }. '/.gnupg/secring.gpg' unless defined $CONFIG { 'secret-keyring' };
278 $CONFIG { 'no-download' } = 0 unless defined $CONFIG { 'no-download' };
279 $CONFIG { 'no-sign' } = 0 unless defined $CONFIG { 'no-sign' };
280 $CONFIG { 'mail-template' } = <<'EOM' unless defined $CONFIG {'mail-template'};
283 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
284 {foreach $uid ( @uids ) {
285 $OUT .= " \t ". $uid ." \n ";
286 };} of your key { $key } signed by me.
288 Note that I did not upload your key to any keyservers. If you want this
289 new signature to be available to others, please upload it yourself.
290 With GnuPG this can be done using
291 gpg --keyserver subkeys.pgp.net --send-key { $key }
293 If you have any questions, don't hesitate to ask.
302 print "[NOTICE] $line \n " ;
306 print "[INFO] $line \n " ;
310 #print "[DEBUG] $line\n";
314 #print "[trace] $line\n";
318 #print "[trace2] $line\n";
323 stdin
=> IO
:: Handle
-> new (),
324 stdout
=> IO
:: Handle
-> new (),
325 stderr
=> IO
:: Handle
-> new (),
326 status
=> IO
:: Handle
-> new () );
327 my $handles = GnuPG
:: Handles
-> new ( %fds );
328 return ( $fds { 'stdin' }, $fds { 'stdout' }, $fds { 'stderr' }, $fds { 'status' }, $handles );
331 sub readwrite_gpg
($$$$$%) {
332 my ( $in , $inputfd , $stdoutfd , $stderrfd , $statusfd , %options ) = @_ ;
334 trace
( "Entering readwrite_gpg." );
336 my ( $first_line , undef ) = split /\n/ , $in ;
337 debug
( "readwrite_gpg sends " .( defined $first_line ?
$first_line : "<nothing>" ));
339 local $INPUT_RECORD_SEPARATOR = undef ;
340 my $sout = IO
:: Select
-> new ();
341 my $sin = IO
:: Select
-> new ();
344 trace
( "input is $inputfd ; output is $stdoutfd ; err is $stderrfd ; status is " .( defined $statusfd ?
$statusfd : 'undef' ). "." );
346 $inputfd -> blocking ( 0 );
347 $stdoutfd -> blocking ( 0 );
348 $statusfd -> blocking ( 0 ) if defined $statusfd ;
349 $stderrfd -> blocking ( 0 );
350 $sout -> add ( $stdoutfd );
351 $sout -> add ( $stderrfd );
352 $sout -> add ( $statusfd ) if defined $statusfd ;
355 my ( $stdout , $stderr , $status ) = ( "" , "" , "" );
356 my $exitwhenstatusmatches = $options { 'exitwhenstatusmatches' };
357 trace
( "doing stuff until we find $exitwhenstatusmatches " ) if defined $exitwhenstatusmatches ;
359 my $readwrote_stuff_this_time = 0 ;
360 my $do_not_wait_on_select = 0 ;
361 my ( $readyr , $readyw , $written );
362 while ( $sout -> count () > 0 || ( defined ( $sin ) && ( $sin -> count () > 0 ))) {
363 if ( defined $exitwhenstatusmatches ) {
364 if ( $status =~ /$exitwhenstatusmatches/m ) {
365 trace
( "readwrite_gpg found match on $exitwhenstatusmatches " );
366 if ( $readwrote_stuff_this_time ) {
367 trace
( "read/write some more \n " );
368 $do_not_wait_on_select = 1 ;
370 trace
( "that's it in our while loop. \n " );
376 $readwrote_stuff_this_time = 0 ;
377 trace
( "select waiting for " .( $sout -> count ()). " fds." );
378 ( $readyr , $readyw , undef ) = IO
:: Select
:: select ( $sout , $sin , undef , $do_not_wait_on_select ?
0 : 1 );
379 trace
( "ready: write: " .( defined $readyw ?
scalar @
$readyw : 0 ). "; read: " .( defined $readyr ?
scalar @
$readyr : 0 ));
380 for my $wfd ( @
$readyw ) {
381 $readwrote_stuff_this_time = 1 ;
382 if ( length ( $in ) != $offset ) {
383 trace
( "writing to $wfd ." );
384 $written = $wfd -> syswrite ( $in , length ( $in ) - $offset , $offset );
387 if ( $offset == length ( $in )) {
388 trace
( "writing to $wfd done." );
389 unless ( $options { 'nocloseinput' }) {
391 trace
( " $wfd closed." );
398 next unless ( defined ( @
$readyr )); # Wait some more.
400 for my $rfd ( @
$readyr ) {
401 $readwrote_stuff_this_time = 1 ;
403 trace
( "reading from $rfd done." );
408 trace
( "reading from $rfd ." );
409 if ( $rfd == $stdoutfd ) {
411 trace2
( "stdout is now $stdout \n ================" );
414 if ( defined $statusfd && $rfd == $statusfd ) {
416 trace2
( "status is now $status \n ================" );
419 if ( $rfd == $stderrfd ) {
421 trace2
( "stderr is now $stderr \n ================" );
426 trace
( "readwrite_gpg done." );
427 return ( $stdout , $stderr , $status );
431 my ( $question , $default , $forceyes , $forceno ) = @_ ;
432 return $default if $forceyes and $forceno ;
433 return 1 if $forceyes ;
434 return 0 if $forceno ;
437 print $question , ' ' ,( $default ?
'[Y/n]' : '[y/N]' ), ' ' ;
440 last if (( defined $answer ) && ( length $answer <= 1 ));
444 my $result = $default ;
445 $result = 1 if $answer =~ /y/i ;
446 $result = 0 if $answer =~ /n/i ;
454 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt' ;
455 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay' ;
456 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig' ;
457 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)' ;
458 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey' ;
461 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
463 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
464 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
466 - d
$KEYSBASE || mkpath
( $KEYSBASE , 0 , 0700 ) or die ( "Cannot create $KEYSBASE : $! \n " );
467 - d
$GNUPGHOME || mkpath
( $GNUPGHOME , 0 , 0700 ) or die ( "Cannot create $GNUPGHOME : $! \n " );
470 my ( $sec , $min , $hour , $mday , $mon , $year , $wday , $yday , $isdst ) = localtime ( $NOW );
471 my $DATE_STRING = sprintf ( " %04d - %02d - %02d " , $year + 1900 , $mon + 1 , $mday );
476 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
480 my ( $fd , $exitcode ) = @_ ;
482 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
483 print $fd "Consult the manual page for more information. \n " ;
488 # export key $keyid from $gnupghome
491 my ( $gnupghome , $keyid ) = @_ ;
493 my $gpg = GnuPG
:: Interface
-> new ();
494 $gpg -> call ( $CONFIG { 'gpg' } );
495 $gpg -> options -> hash_init (
496 'homedir' => $gnupghome ,
498 $gpg -> options -> meta_interactive ( 0 );
499 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
500 my $pid = $gpg -> export_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
501 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
508 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
511 my ( $gnupghome , $asciikey ) = @_ ;
513 my $gpg = GnuPG
:: Interface
-> new ();
514 $gpg -> call ( $CONFIG { 'gpg' } );
515 $gpg -> options -> hash_init ( 'homedir' => $gnupghome );
516 $gpg -> options -> meta_interactive ( 0 );
517 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
518 my $pid = $gpg -> import_keys ( handles
=> $handles );
519 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $asciikey , $inputfd , $stdoutfd , $stderrfd , $statusfd );
522 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
530 # Send an email to $address. If $can_encrypt is true then the mail
531 # will be PGP/MIME encrypted to $longkeyid.
533 # $longkeyid, $uid, and @attached will be used in the email and the template.
535 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
536 sub send_mail
($$$ @
) {
537 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
539 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
540 or die "Error creating template: $Text ::Template::ERROR" ;
543 for my $key ( @keys ) {
544 push @uids , $key ->{ 'text' };
546 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
548 owner
=> $CONFIG { 'owner' }})
549 or die "Error filling template in: $Text ::Template::ERROR" ;
551 my $message_entity = MIME
:: Entity
-> build (
552 Type
=> "text/plain" ,
554 Disposition
=> 'inline' ,
558 for my $key ( @keys ) {
559 $message_entity -> attach (
560 Type
=> "application/pgp-keys" ,
561 Disposition
=> 'attachment' ,
563 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). ')' ,
564 Data
=> $key ->{ 'key' },
565 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".asc" );
569 my $message = $message_entity -> stringify ();
571 my $gpg = GnuPG
:: Interface
-> new ();
572 $gpg -> call ( $CONFIG { 'gpg' } );
573 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
574 'extra_args' => '--always-trust' ,
576 $gpg -> options -> meta_interactive ( 0 );
577 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
578 $gpg -> options -> push_recipients ( $key_id );
579 $gpg -> options -> push_recipients ( $CONFIG { 'also-encrypt-to' } ) if defined $CONFIG { 'also-encrypt-to' };
580 my $pid = $gpg -> encrypt ( handles
=> $handles );
581 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $message , $inputfd , $stdoutfd , $stderrfd , $statusfd );
584 warn ( "No data from gpg for list-key $key_id \n " );
589 $message_entity = MIME
:: Entity
-> build (
590 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
592 $message_entity -> attach (
593 Type
=> "application/pgp-encrypted" ,
594 Disposition
=> 'attachment' ,
596 Data
=> "Version: 1 \n " );
598 $message_entity -> attach (
599 Type
=> "application/octet-stream" ,
600 Filename
=> 'msg.asc' ,
601 Disposition
=> 'inline' ,
606 $message_entity -> head -> add ( "Subject" , "Your signed PGP key 0x $key_id " );
607 $message_entity -> head -> add ( "To" , $address );
608 $message_entity -> head -> add ( "From" , '"' . $CONFIG { 'owner' }. '" <' . $CONFIG { 'email' }. '>' );
609 $message_entity -> head -> add ( "Bcc" , $CONFIG { 'bcc' }) if defined $CONFIG { 'bcc' };
610 $message_entity -> head -> add ( "User-Agent" , $USER_AGENT );
611 $message_entity -> send ();
612 $message_entity -> stringify ();
616 # clean up a UID so that it can be used on the FS.
618 sub sanitize_uid
($) {
622 $good_uid =~ tr
#/:\\#_#;
623 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
627 sub delete_signatures
($$$$$$) {
628 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
630 my $signed_by_me = 0 ;
632 my ( $stdout , $stderr , $status ) =
633 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
635 while ( $status =~ /$KEYEDIT_DELSIG_PROMPT/m ) {
636 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
637 my @sigline = grep { /^sig/ } ( split /\n/ , $stdout );
638 $stdout =~ s/\n/\\n/g ;
639 notice
( "[sigremoval] why are there " .( scalar @sigline ). " siglines in that part of the dialog!? got: $stdout " ) if scalar @sigline >= 2 ; # XXX
640 my $line = pop @sigline ;
642 if ( defined $line ) { # only if we found a sig here - we never remove revocation packets for instance
643 debug
( "[sigremoval] doing line $line ." );
644 my ( undef , undef , undef , undef , $signer , $created , undef , undef , undef ) = split /:/ , $line ;
645 if ( $signer eq $longkeyid ) {
646 debug
( "[sigremoval] selfsig ( $signer )." );
648 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
649 debug
( "[sigremoval] signed by us ( $signer )." );
651 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
653 debug
( "[sigremoval] not interested in that sig ( $signer )." );
657 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
659 ( $stdout , $stderr , $status ) =
660 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
663 return $signed_by_me ;
672 Getopt
:: Long
:: config
( 'bundling' );
674 '-h' => \
$params ->{ 'help' },
675 '--help' => \
$params ->{ 'help' },
676 '--version' => \
$params ->{ 'version' },
677 '-V' => \
$params ->{ 'version' },
678 '-u=s' => \
$params ->{ 'local-user' },
679 '--local-user=s' => \
$params ->{ 'local-user' },
680 '-e' => \
$params ->{ 'export-old' },
681 '--export-old' => \
$params ->{ 'export-old' },
682 '-E' => \
$params ->{ 'no-export-old' },
683 '--no-export-old' => \
$params ->{ 'no-export-old' },
684 '-m' => \
$params ->{ 'mail' },
685 '--mail' => \
$params ->{ 'mail' },
686 '-M' => \
$params ->{ 'no-mail' },
687 '--no-mail' => \
$params ->{ 'no-mail' },
688 '-R' => \
$params ->{ 'no-download' },
689 '--no-download' => \
$params ->{ 'no-download' },
690 '-S' => \
$params ->{ 'no-sign' },
691 '--no-sign' => \
$params ->{ 'no-sign' },
695 if ( $params ->{ 'help' }) {
698 if ( $params ->{ 'version' }) {
702 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
706 if ( $params ->{ 'local-user' }) {
707 $USER = $params ->{ 'local-user' };
709 unless ( $USER =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{40})$/i ) {
710 print STDERR
"-u $USER is not a keyid. \n " ;
716 for my $keyid ( @ARGV ) {
718 unless ( $keyid =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}||[A-Z0-9]{40})$/i ) {
719 print STDERR
" $keyid is not a keyid. \n " ;
722 push @KEYIDS , uc ( $keyid );
725 $CONFIG { 'no-download' } = $params ->{ 'no-download' } if defined $params ->{ 'no-download' };
726 $CONFIG { 'no-mail' } = $params ->{ 'no-mail' } if defined $params ->{ 'no-mail' };
727 $CONFIG { 'mail' } = $params ->{ 'mail' } if defined $params ->{ 'mail' };
728 $CONFIG { 'no-sign' } = $params ->{ 'no-sign' } if defined $params ->{ 'no-sign' };
734 my $gpg = GnuPG
:: Interface
-> new ();
735 $gpg -> call ( $CONFIG { 'gpg' } );
736 $gpg -> options -> hash_init (
737 'homedir' => $GNUPGHOME ,
738 'extra_args' => '--keyserver=' . $CONFIG { 'keyserver' } );
739 $gpg -> options -> meta_interactive ( 0 );
740 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
741 $gpg -> options -> hash_init ( 'extra_args' => [ '--with-colons' , '--fixed-list-mode' ] );
742 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> $CONFIG { 'keyid' });
743 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
746 warn ( "No data from gpg for list-key \n " );
749 foreach my $keyid ( @
{ $CONFIG { 'keyid' }}) {
750 unless ( $stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m ) {
751 info
( "Importing $keyid " );
752 system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME " ;
756 #############################
757 # receive keys from keyserver
758 #############################
760 if ( $CONFIG { 'no-download' }) {
761 @keyids_ok = @KEYIDS ;
763 info
( "fetching keys, this will take a while..." );
765 my $gpg = GnuPG
:: Interface
-> new ();
766 $gpg -> call ( $CONFIG { 'gpg' } );
767 $gpg -> options -> hash_init (
768 'homedir' => $GNUPGHOME ,
769 'extra_args' => '--keyserver=' . $CONFIG { 'keyserver' } );
770 $gpg -> options -> meta_interactive ( 0 );
771 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
772 my $pid = $gpg -> recv_keys ( handles
=> $handles , command_args
=> [ @KEYIDS ]);
773 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
776 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
779 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
780 my %local_keyids = map { $_ => 1 } @KEYIDS ;
781 for my $line ( split /\n/ , $status ) {
782 if ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/ ) {
783 my $imported_key = $1 ;
784 my $whole_fpr = $imported_key ;
785 my $long_keyid = substr ( $imported_key , - 16 );
786 my $short_keyid = substr ( $imported_key , - 8 );
788 for my $spec (( $whole_fpr , $long_keyid , $short_keyid )) {
789 $speced_key = $spec if $local_keyids { $spec };
791 unless ( $speced_key ) {
792 notice
( "Imported unexpected key; got: $imported_key \n " );
795 debug
( "Imported $imported_key for $speced_key " );
796 delete $local_keyids { $speced_key };
797 unshift @keyids_ok , $imported_key ;
798 } elsif ( $line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) / ) {
800 notice
( "got unknown reply from gpg: $line " );
803 if ( scalar %local_keyids ) {
804 notice
( "Import failed for: " . ( join ' ' , keys %local_keyids ). "." );
805 exit 1 unless ask
( "Some keys could not be imported - continue anyway?" , 0 );
809 unless ( @keyids_ok ) {
810 notice
( "No keys to sign found" );
817 unless ( $CONFIG { 'no-sign' }) {
818 info
( "Sign the following keys according to your policy, then exit gpg with 'save' after signing each key" );
819 for my $keyid ( @keyids_ok ) {
821 push @command , $CONFIG { 'gpg-sign' };
822 push @command , '--local-user' , $USER if ( defined $USER );
823 push @command , "--homedir= $GNUPGHOME " ;
824 push @command , '--secret-keyring' , $CONFIG { 'secret-keyring' };
825 push @command , '--edit' , $keyid ;
826 push @command , 'sign' ;
827 push @command , split ' ' , $CONFIG { 'gpg-sign-args' } || "" ;
828 print join ( ' ' , @command ), " \n " ;
837 for my $keyid ( @keyids_ok ) {
840 my $gpg = GnuPG
:: Interface
-> new ();
841 $gpg -> call ( $CONFIG { 'gpg' } );
842 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME );
843 $gpg -> options -> meta_interactive ( 0 );
844 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
845 $gpg -> options -> hash_init ( 'extra_args' => [ '--with-colons' , '--fixed-list-mode' ] );
846 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
847 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
850 warn ( "No data from gpg for list-key $keyid \n " );
853 my @publine = grep { /^pub/ } ( split /\n/ , $stdout );
854 if ( scalar @publine == 0 ) {
855 warn ( "No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME ). \n " );
858 my ( undef , undef , undef , undef , $longkeyid , undef , undef , undef , undef , undef , undef , $flags ) = split /:/ , pop @publine ;
859 if ( scalar @publine > 0 ) {
860 warn ( "More than one key matched $keyid . Try to specify the long keyid or fingerprint \n " );
863 unless ( defined $longkeyid ) {
864 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
867 unless ( defined $flags ) {
868 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
871 my $can_encrypt = $flags =~ /E/ ;
875 my $asciikey = export_key
( $GNUPGHOME , $keyid );
876 if ( $asciikey eq '' ) {
877 warn ( "No data from gpg for export $keyid \n " );
884 my $this_uid_text = '' ;
886 debug
( "Doing key $keyid , uid $uid_number " );
887 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
889 # import into temporary gpghome
890 ###############################
891 my $result = import_key
( $tempdir , $asciikey );
893 warn ( "Could not import $keyid into temporary gnupg. \n " );
899 $gpg = GnuPG
:: Interface
-> new ();
900 $gpg -> call ( $CONFIG { 'gpg-delsig' } );
901 $gpg -> options -> hash_init (
902 'homedir' => $tempdir ,
903 'extra_args' => [ '--with-colons' , '--fixed-list-mode' , '--command-fd=0' , '--no-tty' ] );
904 ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
905 $pid = $gpg -> wrap_call (
906 commands
=> [ '--edit' ],
907 command_args
=> [ $keyid ],
908 handles
=> $handles );
910 debug
( "Starting edit session" );
911 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
915 my $number_of_subkeys = 0 ;
920 debug
( "Parsing stdout output." );
921 for my $line ( split /\n/ , $stdout ) {
922 debug
( "Checking line $line " );
923 my ( $type , undef , undef , undef , undef , undef , undef , undef , undef , $uidtext ) = split /:/ , $line ;
924 if ( $type eq 'sub' ) {
925 $number_of_subkeys ++;
927 next unless ( $type eq 'uid' || $type eq 'uat' );
928 debug
( "line is interesting." );
929 if ( $uid_number != $i ) {
930 debug
( "mark for deletion." );
931 readwrite_gpg
( " $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
936 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
937 $is_uat = $type eq 'uat' ;
941 debug
( "Parsing stdout output done." );
943 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
944 info
( "key $keyid done." );
948 my $prune_some_sigs_on_uid ;
949 my $prune_all_sigs_on_uid ;
951 debug
( "handling attribute userid of key $keyid ." );
952 if ( $uid_number == 1 ) {
953 debug
( " attribute userid is #1, unmarking #2 for deletion." );
954 readwrite_gpg
( "2 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
956 $prune_some_sigs_on_uid = 1 ;
957 $prune_all_sigs_on_uid = 2 ;
959 debug
( "attribute userid is not #1, unmarking #1 for deletion." );
960 readwrite_gpg
( "1 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
962 $prune_some_sigs_on_uid = 2 ;
963 $prune_all_sigs_on_uid = 1 ;
966 $prune_some_sigs_on_uid = 1 ;
970 debug
( "need to delete $delete_some uids." );
971 readwrite_gpg
( "deluid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT , nocloseinput
=> 1 );
972 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
977 if ( $number_of_subkeys > 0 ) {
978 for ( my $i = 1 ; $i <= $number_of_subkeys ; $i ++) {
979 readwrite_gpg
( "key $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
981 readwrite_gpg
( "delkey \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT , nocloseinput
=> 1 );
982 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
987 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
988 my $signed_by_me = delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $CONFIG { 'keyid' });
989 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
990 if ( defined $prune_all_sigs_on_uid ) {
991 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
992 delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , []);
993 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
997 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1000 my $asciikey = export_key
( $tempdir , $keyid );
1001 if ( $asciikey eq '' ) {
1002 warn ( "No data from gpg for export $keyid \n " );
1006 if ( $signed_by_me ) {
1007 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
1008 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 , $params ->{ 'export-old' }, $params ->{ 'no-export-old' });
1011 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1012 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
1014 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
1015 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
1016 print KEY
$asciikey ;
1019 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
1021 info
( " $longkeyid $uid_number $this_uid_text done." );
1023 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
1027 if ( scalar @UIDS == 0 ) {
1028 info
( "found no signed uids for $keyid " );
1030 next if $CONFIG { 'no-mail' }; # do not send mail
1033 for my $uid ( @UIDS ) {
1034 trace
( "UID: $uid ->{'text'} \n " );
1035 if ( $uid ->{ 'is_uat' }) {
1036 my $attach = ask
( "UID $uid ->{'text'} is an attribute UID, attach it to every email sent?" , 1 );
1037 push @attached , $uid if $attach ;
1038 } elsif ( $uid ->{ 'text' } !~ /@/ ) {
1039 my $attach = ask
( "UID $uid ->{'text'} is no email address, attach it to every email sent?" , 1 );
1040 push @attached , $uid if $attach ;
1044 notice
( "Key has no encryption capabilities, mail will be sent unencrypted" ) unless $can_encrypt ;
1045 for my $uid ( @UIDS ) {
1046 if (! $uid ->{ 'is_uat' } && ( $uid ->{ 'text' } =~ /@/ )) {
1047 my $address = $uid ->{ 'text' };
1048 $address =~ s/.*<(.*)>.*/$1/ ;
1049 if ( ask
( "Send mail to ' $address ' for $uid ->{'text'}?" , 1 , $CONFIG { 'mail' })) {
1050 my $mail = send_mail
( $address , $can_encrypt , $longkeyid , $uid , @attached );
1052 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1053 my $mailfile = " $keydir / $longkeyid .mail." . $uid ->{ 'serial' }. "." . sanitize_uid
( $uid ->{ 'text' });
1054 open ( KEY
, "> $mailfile " ) or die ( "Cannot open $mailfile : $! \n " );