File Coverage

blib/lib/Mail/GnuPG.pm
Criterion Covered Total %
statement 276 394 70.0
branch 71 172 41.2
condition 13 33 39.3
subroutine 26 31 83.8
pod 13 14 92.8
total 399 644 61.9


line stmt bran cond sub pod time code
1             package Mail::GnuPG;
2              
3             =head1 NAME
4              
5             Mail::GnuPG - Process email with GPG.
6              
7             =head1 SYNOPSIS
8              
9             use Mail::GnuPG;
10             my $mg = new Mail::GnuPG( key => 'ABCDEFGH' );
11             $ret = $mg->mime_sign( $MIMEObj, 'you@my.dom' );
12              
13             =head1 DESCRIPTION
14              
15             Use GnuPG::Interface to process or create PGP signed or encrypted
16             email.
17              
18             =cut
19              
20 8     8   109697 use 5.006;
  8         18  
21 8     8   22 use strict;
  8         7  
  8         121  
22 8     8   22 use warnings;
  8         6  
  8         295  
23              
24             our $VERSION = '0.22';
25             my $DEBUG = 0;
26              
27 8     8   3888 use GnuPG::Interface;
  8         1467694  
  8         201  
28 8     8   46 use File::Spec;
  8         9  
  8         141  
29 8     8   3743 use File::Temp;
  8         43237  
  8         467  
30 8     8   32 use IO::Handle;
  8         9  
  8         202  
31 8     8   4635 use MIME::Entity;
  8         454084  
  8         221  
32 8     8   4396 use MIME::Parser;
  8         67616  
  8         215  
33 8     8   78 use Mail::Address;
  8         8  
  8         120  
34 8     8   22 use IO::Select;
  8         7  
  8         588  
35 8     8   25 use Errno qw(EPIPE);
  8         10  
  8         30274  
36              
37             =head2 new
38              
39             Create a new Mail::GnuPG instance.
40              
41             Arguments:
42             Paramhash...
43              
44             key => gpg key id
45             keydir => gpg configuration/key directory
46             passphrase => primary key password
47             use_agent => use gpg-agent if non-zero
48             always_trust => always trust a public key
49             # FIXME: we need more things here, maybe primary key id.
50              
51              
52             =cut
53              
54             sub new {
55 5     5 1 9042683 my $proto = shift;
56 5   33     87 my $class = ref($proto) || $proto;
57 5         82 my $self = {
58             key => undef,
59             keydir => undef,
60             passphrase => "",
61             gpg_path => "gpg",
62             use_agent => 0,
63             @_
64             };
65 5         24 $self->{last_message} = [];
66 5         24 $self->{plaintext} = [];
67 5         15 bless ($self, $class);
68 5         22 return $self;
69             }
70              
71             sub _set_options {
72 11     11   22 my ($self,$gnupg) = @_;
73 11         144 $gnupg->options->meta_interactive( 0 );
74             $gnupg->options->hash_init( armor => 1,
75             ( defined $self->{keydir} ?
76             (homedir => $self->{keydir}) : () ),
77             ( defined $self->{key} ?
78 11 50       44227 ( default_key => $self->{key} ) : () ),
    100          
79             # ( defined $self->{passphrase} ?
80             # ( passphrase => $self->{passphrase} ) : () ),
81             );
82 11 50       6003 if ($self->{use_agent}) {
83 0         0 push @{$gnupg->options->extra_args}, '--use-agent';
  0         0  
84             }
85              
86 11 50       33 if (defined $self->{always_trust}) {
87             $gnupg->options->always_trust($self->{always_trust})
88 0         0 }
89 11 50       195 $gnupg->call( $self->{gpg_path} ) if defined $self->{gpg_path};
90             }
91              
92              
93             =head2 decrypt
94              
95             Decrypt an encrypted message
96              
97             Input:
98             MIME::Entity containing email message to decrypt.
99              
100             The message can either be in RFC compliant-ish multipart/encrypted
101             format, or just a single part ascii armored message.
102              
103             Output:
104             On Failure:
105             Exit code of gpg. (0 on success)
106              
107             On Success: (just encrypted)
108             (0, undef, undef)
109              
110             On success: (signed and encrypted)
111             ( 0,
112             keyid, # ABCDDCBA
113             emailaddress # Foo Bar
114             )
115              
116             where the keyid is the key that signed it, and emailaddress is full
117             name and email address of the primary uid
118              
119              
120             $self->{last_message} => any errors from gpg
121             $self->{plaintext} => plaintext output from gpg
122             $self->{decrypted} => parsed output as MIME::Entity
123              
124             =cut
125              
126             sub decrypt {
127 2     2 1 735 my ($self, $message) = @_;
128 2         7 my $ciphertext = "";
129              
130 2         9 $self->{last_message} = [];
131              
132 2 50 33     36 unless (ref $message && $message->isa("MIME::Entity")) {
133 0         0 die "decrypt only knows about MIME::Entitys right now";
134 0         0 return 255;
135             }
136              
137 2         3 my $armor_message = 0;
138 2 50       14 if ($message->effective_type =~ m!multipart/encrypted!) {
    50          
139 0 0       0 die "multipart/encrypted with more than two parts"
140             if ($message->parts != 2);
141 0 0       0 die "Content-Type not pgp-encrypted"
142             unless $message->parts(0)->effective_type =~
143             m!application/pgp-encrypted!;
144 0         0 $ciphertext = $message->parts(1)->stringify_body;
145             }
146             elsif ($message->bodyhandle->as_string
147             =~ m!^-----BEGIN PGP MESSAGE-----!m ) {
148 2         336 $ciphertext = $message->bodyhandle->as_string;
149 2         13 $armor_message = 1;
150             }
151             else {
152 0         0 die "Unknown Content-Type or no PGP message in body"
153             }
154              
155 2         45 my $gnupg = GnuPG::Interface->new();
156 2         3778 $self->_set_options($gnupg);
157             # how we create some handles to interact with GnuPG
158             # This time we'll catch the standard error for our perusing
159             # as well as passing in the passphrase manually
160             # as well as the status information given by GnuPG
161 2         53 my ( $input, $output, $error, $passphrase_fh, $status_fh )
162             = ( new IO::Handle, new IO::Handle,new IO::Handle,
163             new IO::Handle,new IO::Handle,);
164              
165             my $handles = GnuPG::Handles->new( stdin => $input,
166             stdout => $output,
167             stderr => $error,
168 2 50       165 $self->{use_agent} ? () : (passphrase => $passphrase_fh),
169             status => $status_fh,
170             );
171              
172             # this sets up the communication
173 2         6202 my $pid = $gnupg->decrypt( handles => $handles );
174              
175 2 50       7929 die "NO PASSPHRASE" unless defined $passphrase_fh;
176             my $read = _communicate([$output, $error, $status_fh],
177             [$input, $self->{use_agent} ? () : $passphrase_fh],
178             { $input => $ciphertext,
179 2 50       134 $self->{use_agent} ? () : ($passphrase_fh => $self->{passphrase})}
    50          
180             );
181              
182 2         12307 my @plaintext = split(/^/m, $read->{$output});
183 2         22 my @error_output = split(/^/m, $read->{$error});
184 2         15 my @status_info = split(/^/m, $read->{$status_fh});
185              
186 2         68 waitpid $pid, 0;
187 2         15 my $return = $?;
188 2 50       10 $return = 0 if $return == -1;
189              
190 2         6 my $exit_value = $return >> 8;
191            
192              
193              
194 2         10 $self->{last_message} = \@error_output;
195 2         8 $self->{plaintext} = \@plaintext;
196              
197 2         46 my $parser = new MIME::Parser;
198 2         412 $parser->output_to_core(1);
199              
200             # for armor message (which usually contain no MIME entity)
201             # and if the first line seems to be no header, add an empty
202             # line at the top, otherwise the first line of a text message
203             # will be removed by the parser.
204 2 50 33     52 if ( $armor_message and $plaintext[0] and $plaintext[0] !~ /^[\w-]+:/ ) {
      33        
205 2         904 unshift @plaintext, "\n";
206             }
207              
208 2         22 my $entity = $parser->parse_data(\@plaintext);
209 2         8616 $self->{decrypted} = $entity;
210              
211 2 50       31 return $exit_value if $exit_value; # failure
212              
213             # if the message was signed and encrypted, extract the signature
214             # information and return it. In some theory or another, you can't
215             # trust an unsigned encrypted message is from who it says signed it.
216             # (Although I think it would have to go hand in hand at some point.)
217              
218 2         12 my $result = join "", @error_output;
219 2         13 my ($keyid, $pemail) = key_and_uid_from_status(@status_info);
220              
221 2         157 return ($exit_value,$keyid,$pemail);
222              
223             }
224              
225             =head2 get_decrypt_key
226              
227             determines the decryption key (and corresponding mail) of a message
228              
229             Input:
230             MIME::Entity containing email message to analyze.
231              
232             The message can either be in RFC compliant-ish multipart/signed
233             format, or just a single part ascii armored message.
234              
235             Output:
236             $key -- decryption key
237             $mail -- corresponding mail address
238              
239             =cut
240              
241             sub get_decrypt_key {
242 0     0 1 0 my ($self, $message) = @_;
243              
244 0 0 0     0 unless (ref $message && $message->isa("MIME::Entity")) {
245 0         0 die "decrypt only knows about MIME::Entitys right now";
246             }
247              
248 0         0 my $ciphertext;
249              
250 0 0       0 if ($message->effective_type =~ m!multipart/encrypted!) {
    0          
251 0 0       0 die "multipart/encrypted with more than two parts"
252             if ($message->parts != 2);
253 0 0       0 die "Content-Type not pgp-encrypted"
254             unless $message->parts(0)->effective_type =~
255             m!application/pgp-encrypted!;
256 0         0 $ciphertext = $message->parts(1)->stringify_body;
257             }
258             elsif ($message->bodyhandle->as_string
259             =~ m!^-----BEGIN PGP MESSAGE-----!m ) {
260 0         0 $ciphertext = $message->bodyhandle->as_string;
261             }
262             else {
263 0         0 die "Unknown Content-Type or no PGP message in body"
264             }
265              
266 0         0 my $gnupg = GnuPG::Interface->new();
267 0         0 $gnupg->options->batch(1);
268 0         0 $gnupg->options->status_fd(1);
269 0         0 push @{$gnupg->options->extra_args}, '--list-only';
  0         0  
270              
271             # how we create some handles to interact with GnuPG
272             # This time we'll catch the standard error for our perusing
273             # as well as passing in the passphrase manually
274             # as well as the status information given by GnuPG
275 0         0 my ( $input, $output, $stderr )
276             = ( new IO::Handle, new IO::Handle, new IO::Handle );
277              
278 0         0 my $handles = GnuPG::Handles->new( stdin => $input,
279             stdout => $output,
280             stderr => $stderr,
281             );
282              
283             # this sets up the communication
284 0         0 my $pid = $gnupg->wrap_call(
285             handles => $handles,
286             commands => [ "--decrypt" ],
287             command_args => [ ],
288             );
289              
290 0         0 my $read = _communicate([$output], [$input], { $input => $ciphertext });
291              
292             # reading the output
293 0         0 my @result = split(/^/m, $read->{$output});
294              
295             # clean up the finished GnuPG process
296 0         0 waitpid $pid, 0;
297 0         0 my $return = $?;
298 0 0       0 $return = 0 if $return == -1;
299              
300 0         0 my $exit_value = $return >> 8;
301            
302              
303              
304             # set last_message
305 0         0 $self->{last_message} = \@result;
306              
307             # grep ENC_TO and NO_SECKEY items
308 0         0 my (@enc_to_keys, %no_sec_keys);
309 0         0 for ( @result ) {
310 0 0       0 push @enc_to_keys, $1 if /ENC_TO\s+([^\s]+)/;
311 0 0       0 $no_sec_keys{$1} = 1 if /NO_SECKEY\s+([^\s]+)/;
312             }
313              
314             # find first key we have the secret portion of
315 0         0 my $key;
316 0         0 foreach my $k ( @enc_to_keys ) {
317 0 0       0 if ( not exists $no_sec_keys{$k} ) {
318 0         0 $key = $k;
319 0         0 last;
320             }
321             }
322              
323 0 0       0 return if not $key;
324              
325             # get mail address of this key
326 0 0       0 die "Invalid Key Format: $key" unless $key =~ /^[0-9A-F]+$/i;
327 0         0 my $cmd = $self->{gpg_path} . " --with-colons --list-keys $key 2>&1";
328 0         0 my $gpg_out = qx[ $cmd ];
329             ## FIXME: this should probably use open| instead.
330 0 0 0     0 die "Couldn't find key $key in keyring" if $gpg_out !~ /\S/ or $?;
331 0         0 my $mail = (split(":", $gpg_out))[9];
332              
333 0         0 return ($mail, $key);
334             }
335              
336             =head2 verify
337              
338             verify a signed message
339              
340             Input:
341             MIME::Entity containing email message to verify.
342              
343             The message can either be in RFC compliant-ish multipart/signed
344             format, or just a single part ascii armored message.
345              
346             Note that MIME-encoded data should be supplied unmodified inside
347             the MIME::Entity input message, otherwise the signature will be
348             broken. Since MIME-tools version 5.419, this can be achieved with
349             the C method of MIME::Parser. See the MIME::Parser
350             documentation for more information.
351              
352             Output:
353             On error:
354             Exit code of gpg. (0 on success)
355             On success
356             ( 0,
357             keyid, # ABCDDCBA
358             emailaddress # Foo Bar
359             )
360              
361             where the keyid is the key that signed it, and emailaddress is full
362             name and email address of the primary uid. The email/uid is UTF8
363             encoded, as output by GPG.
364              
365             $self->{last_message} => any errors from gpg
366              
367             =cut
368              
369             # Verify RFC2015/RFC3156 email
370             sub verify {
371 4     4 1 623 my ($self, $message) = @_;
372              
373 4         10 my $ciphertext = "";
374 4         10 my $sigtext = "";
375              
376 4         14 $self->{last_message} = [];
377              
378 4 50 33     57 unless (ref $message && $message->isa("MIME::Entity")) {
379 0         0 die "VerifyMessage only knows about MIME::Entitys right now";
380 0         0 return 255;
381             }
382              
383 4 100 33     19 if ($message->effective_type =~ m!multipart/signed!) {
    50          
384 2 50       237 die "multipart/signed with more than two parts"
385             if ($message->parts != 2);
386 2 50       19 die "Content-Type not pgp-signed"
387             unless $message->parts(1)->effective_type =~
388             m!application/pgp-signature!;
389 2         154 $ciphertext = $message->parts(0)->as_string;
390 2         1062 $sigtext = $message->parts(1)->stringify_body;
391             }
392             elsif ( $message->bodyhandle and $message->bodyhandle->as_string
393             =~ m!^-----BEGIN PGP SIGNED MESSAGE-----!m ) {
394             # don't use not $message->body_as_string here, because
395             # the body isn't decoded in this case!!!
396             # (which is evil for quoted-printable transfer encoding)
397             # also the headers and stuff are not needed here
398 2         308 $ciphertext = undef;
399 2         8 $sigtext = $message->bodyhandle->as_string; # well, actually both
400             }
401             else {
402 0         0 die "Unknown Content-Type or no PGP message in body"
403             }
404              
405 4         2303 my $gnupg = GnuPG::Interface->new();
406 4         6419 $self->_set_options($gnupg);
407             # how we create some handles to interact with GnuPG
408 4         60 my $input = IO::Handle->new();
409 4         60 my $error = IO::Handle->new();
410 4         40 my $status_fh = IO::Handle->new();
411              
412 4         95 my $handles = GnuPG::Handles->new( stderr => $error,
413             stdin => $input,
414             status => $status_fh );
415              
416 4         10091 my ($sigfh, $sigfile)
417             = File::Temp::tempfile('mgsXXXXXXXX',
418             DIR => File::Spec->tmpdir,
419             UNLINK => 1,
420             );
421 4         2092 print $sigfh $sigtext;
422 4         105 close($sigfh);
423              
424 4         55 my ($datafh, $datafile) =
425             File::Temp::tempfile('mgdXXXXXX',
426             DIR => File::Spec->tmpdir,
427             UNLINK => 1,
428             );
429              
430             # according to RFC3156 all line endings MUST be CR/LF
431 4 100       961 if ( defined $ciphertext ) {
432 2         8131 $ciphertext =~ s/\x0A/\x0D\x0A/g;
433 2         24346 $ciphertext =~ s/\x0D+/\x0D/g;
434             }
435              
436             # Read the (unencoded) body data:
437             # as_string includes the header portion
438 4 100       662 print $datafh $ciphertext if $ciphertext;
439 4         61 close($datafh);
440              
441 4 100       34 my $pid = $gnupg->verify( handles => $handles,
442             command_args => ( $ciphertext ?
443             ["$sigfile", "$datafile"] :
444             "$sigfile" ),
445             );
446              
447 4         15235 my $read = _communicate([$error,$status_fh], [$input], {$input => ''});
448              
449 4         50 my @result = split(/^/m, $read->{$error});
450 4         25 my @status_info = split(/^/m, $read->{$status_fh});
451              
452 4         589 unlink $sigfile, $datafile;
453              
454 4         56 waitpid $pid, 0;
455 4         22 my $return = $?;
456 4 50       20 $return = 0 if $return == -1;
457              
458 4         8 my $exit_value = $return >> 8;
459              
460 4         20 $self->{last_message} = [@result];
461              
462 4 50       17 return $exit_value if $exit_value; # failure
463              
464 4         14 my $result = join "", @result;
465              
466 4         19 my ($keyid, $pemail) = key_and_uid_from_status(@status_info);
467              
468 4         215 return ($exit_value,$keyid,$pemail);
469              
470             }
471              
472             sub key_and_uid_from_status {
473              
474 6     6 0 29 my @status_info = @_;
475              
476 6         29 chomp(@status_info);
477              
478 6         15 my ($keyid) = grep { s/^\[GNUPG:\] VALIDSIG \S+(\S{8}) .*$/$1/; } @status_info;
  69         105  
479              
480             # FIXME: we should really distinguish between GOOD and the others
481             # but this will change the existing behaviour
482              
483 6         12 my ($pemail) = grep { s/^\[GNUPG:\] (GOODSIG|EXPKEYSIG|REVKEYSIG) \S+ (.*)$/$2/; } @status_info;
  69         108  
484              
485 6         19 return ($keyid,$pemail);
486             }
487              
488             # Should this go elsewhere? The Key handling stuff doesn't seem to
489             # make sense in a Mail:: module.
490             my %key_cache;
491             my $key_cache_age = 0;
492             my $key_cache_expire = 60*60*30; # 30 minutes
493              
494             sub _rebuild_key_cache {
495 2     2   3 my $self = shift;
496 2         5 local $_;
497 2         5 %key_cache = ();
498 2         43 my $gnupg = GnuPG::Interface->new();
499 2         3626 $self->_set_options($gnupg);
500 2         33 my @keys = $gnupg->get_public_keys();
501 2         465117 foreach my $key (@keys) {
502 2         15 foreach my $uid ($key->user_ids) {
503             # M::A may not parse the gpg stuff properly. Cross fingers
504 2         47 my ($a) = Mail::Address->parse($uid->as_string); # list context, please
505 2 50       887 $key_cache{$a->address}=1 if ref $a;
506             }
507             }
508             }
509              
510             =head2 has_public_key
511              
512             Does the keyring have a public key for the specified email address?
513              
514             FIXME: document better. talk about caching. maybe put a better
515             interface in.
516              
517             =cut
518              
519              
520             sub has_public_key {
521 2     2 1 533 my ($self,$address) = @_;
522              
523             # cache aging is disabled until someone has enough time to test this
524 2         2 if (0) {
525             $self->_rebuild_key_cache() unless ($key_cache_age);
526              
527             if ( $key_cache_age && ( time() - $key_cache_expire > $key_cache_age )) {
528             $self->_rebuild_key_cache();
529             }
530             }
531              
532 2         9 $self->_rebuild_key_cache();
533              
534 2 100       117 return 1 if exists $key_cache{$address};
535 1         15 return 0;
536              
537             }
538              
539             =head2 mime_sign
540              
541             sign an email message
542              
543             Input:
544             MIME::Entity containing email message to sign
545              
546             Output:
547             Exit code of gpg. (0 on success)
548              
549             $self->{last_message} => any errors from gpg
550              
551             The provided $entity will be signed. (i.e. it _will_ be modified.)
552              
553             =cut
554              
555              
556             sub mime_sign {
557 1     1 1 2730 my ($self,$entity) = @_;
558              
559 1 50       12 die "Not a mime entity"
560             unless $entity->isa("MIME::Entity");
561              
562 1         5 $entity->make_multipart;
563 1         1016 my $workingentity = $entity;
564 1 50       5 if ($entity->parts > 1) {
565 0         0 $workingentity = MIME::Entity->build(Type => $entity->head->mime_attr("Content-Type"));
566 0         0 $workingentity->add_part($_) for ($entity->parts);
567 0         0 $entity->parts([]);
568 0         0 $entity->add_part($workingentity);
569             }
570              
571 1         25 my $gnupg = GnuPG::Interface->new();
572 1         3437 $self->_set_options( $gnupg );
573 1         22 my ( $input, $output, $error, $passphrase_fh, $status_fh )
574             = ( new IO::Handle, new IO::Handle,new IO::Handle,
575             new IO::Handle,new IO::Handle,);
576             my $handles = GnuPG::Handles->new( stdin => $input,
577             stdout => $output,
578             stderr => $error,
579 1 50       62 $self->{use_agent} ? () : (passphrase => $passphrase_fh),
580             status => $status_fh,
581             );
582 1         5461 my $pid = $gnupg->detach_sign( handles => $handles );
583 1 50       4317 die "NO PASSPHRASE" unless defined $passphrase_fh;
584              
585             # this passes in the plaintext
586 1         4 my $plaintext;
587 1 50       10 if ($workingentity eq $entity) {
588 1         22 $plaintext = $entity->parts(0)->as_string;
589             } else {
590 0         0 $plaintext = $workingentity->as_string;
591             }
592              
593             # according to RFC3156 all line endings MUST be CR/LF
594 1         11295 $plaintext =~ s/\x0A/\x0D\x0A/g;
595 1         24239 $plaintext =~ s/\x0D+/\x0D/g;
596              
597             # DEBUG:
598             # print "SIGNING THIS STRING ----->\n";
599             # $plaintext =~ s/\n/-\n/gs;
600             # warn("SIGNING:\n$plaintext<<<");
601             # warn($entity->as_string);
602             # print STDERR $plaintext;
603             # print "<----\n";
604             my $read = _communicate([$output, $error, $status_fh],
605             [$input, $self->{use_agent} ? () : ($passphrase_fh)],
606             { $input => $plaintext,
607 1 50       188 $self->{use_agent} ? () : ($passphrase_fh => $self->{passphrase})}
    50          
608             );
609              
610 1         43 my @signature = split(/^/m, $read->{$output});
611 1         3 my @error_output = split(/^/m, $read->{$error});
612 1         3 my @status_info = split(/^/m, $read->{$status_fh});
613              
614 1         14 waitpid $pid, 0;
615 1         4 my $return = $?;
616 1 50       3 $return = 0 if $return == -1;
617              
618 1         2 my $exit_value = $return >> 8;
619              
620              
621 1         3 $self->{last_message} = \@error_output;
622              
623 1         10 $entity->attach( Type => "application/pgp-signature",
624             Disposition => "inline",
625             Data => [@signature],
626             Encoding => "7bit");
627              
628 1         980 $entity->head->mime_attr("Content-Type","multipart/signed");
629 1         178 $entity->head->mime_attr("Content-Type.protocol","application/pgp-signature");
630             # $entity->head->mime_attr("Content-Type.micalg","pgp-md5");
631             # Richard Hirner notes that Thunderbird/Enigmail really wants a micalg
632             # of pgp-sha1 (which will be GPG version dependent.. older versions
633             # used md5. For now, until we can detect which type was used, the end
634             # user should read the source code, notice this comment, and insert
635             # the appropriate value themselves.
636              
637 1         331 return $exit_value;
638             }
639              
640             =head2 clear_sign
641              
642             clearsign the body of an email message
643              
644             Input:
645             MIME::Entity containing email message to sign.
646             This entity MUST have a body.
647              
648             Output:
649             Exit code of gpg. (0 on success)
650              
651             $self->{last_message} => any errors from gpg
652              
653             The provided $entity will be signed. (i.e. it _will_ be modified.)
654              
655             =cut
656              
657             sub clear_sign {
658 1     1 1 315 my ($self, $entity) = @_;
659            
660 1 50       7 die "Not a mime entity"
661             unless $entity->isa("MIME::Entity");
662              
663 1         3 my $body = $entity->bodyhandle;
664            
665 1 50       5 die "Message has no body"
666             unless defined $body;
667              
668 1         30 my $gnupg = GnuPG::Interface->new();
669 1         136 $self->_set_options( $gnupg );
670 1         29 $gnupg->passphrase ( $self->{passphrase} );
671              
672 1         21 my ( $input, $output, $error )
673             = ( new IO::Handle, new IO::Handle, new IO::Handle);
674              
675 1         47 my $handles = GnuPG::Handles->new(
676             stdin => $input,
677             stdout => $output,
678             stderr => $error,
679             );
680              
681 1         323 my $pid = $gnupg->clearsign ( handles => $handles );
682              
683 1         3565 my $plaintext = $body->as_string;
684              
685 1         8456 $plaintext =~ s/\x0A/\x0D\x0A/g;
686 1         24945 $plaintext =~ s/\x0D+/\x0D/g;
687              
688 1         80 my $read = _communicate([$output, $error], [$input], { $input => $plaintext });
689            
690 1         11804 my @ciphertext = split(/^/m, $read->{$output});
691 1         10 my @error_output = split(/^/m, $read->{$error});
692            
693 1         17 waitpid $pid, 0;
694 1         6 my $return = $?;
695 1 50       6 $return = 0 if $return == -1;
696              
697 1         3 my $exit_value = $return >> 8;
698            
699 1         3 $self->{last_message} = [@error_output];
700              
701 1 50       13 my $io = $body->open ("w") or die "can't open entity body";
702 1         2960 $io->print (join('',@ciphertext));
703 1         195 $io->close;
704              
705 1         4057 return $exit_value;
706             }
707              
708              
709             =head2 ascii_encrypt
710              
711             encrypt an email message body using ascii armor
712              
713             Input:
714             MIME::Entity containing email message to encrypt.
715             This entity MUST have a body.
716              
717             list of recipients
718              
719             Output:
720             Exit code of gpg. (0 on success)
721              
722             $self->{last_message} => any errors from gpg
723              
724             The provided $entity will be encrypted. (i.e. it _will_ be modified.)
725              
726             =head2 ascii_signencrypt
727              
728             encrypt and sign an email message body using ascii armor
729              
730             Input:
731             MIME::Entity containing email message to encrypt.
732             This entity MUST have a body.
733              
734             list of recipients
735              
736             Output:
737             Exit code of gpg. (0 on success)
738              
739             $self->{last_message} => any errors from gpg
740              
741             The provided $entity will be encrypted. (i.e. it _will_ be modified.)
742              
743             =cut
744              
745             sub ascii_encrypt {
746 1     1 1 580 my ($self, $entity, @recipients) = @_;
747 1         6 $self->_ascii_encrypt($entity, 0, @recipients);
748             }
749              
750             sub ascii_signencrypt {
751 0     0 1 0 my ($self, $entity, @recipients) = @_;
752 0         0 $self->_ascii_encrypt($entity, 1, @recipients);
753             }
754              
755             sub _ascii_encrypt {
756 1     1   4 my ($self, $entity, $sign, @recipients) = @_;
757            
758 1 50       6 die "Not a mime entity"
759             unless $entity->isa("MIME::Entity");
760              
761 1         3 my $body = $entity->bodyhandle;
762            
763 1 50       6 die "Message has no body"
764             unless defined $body;
765              
766 1         5 my $plaintext = $body->as_string;
767              
768 1         31 my $gnupg = GnuPG::Interface->new();
769 1         103 $self->_set_options( $gnupg );
770 1         30 $gnupg->passphrase ( $self->{passphrase} );
771 1         32 $gnupg->options->push_recipients( $_ ) for @recipients;
772              
773 1         884 my ( $input, $output, $error )
774             = ( new IO::Handle, new IO::Handle, new IO::Handle);
775              
776 1         79 my $handles = GnuPG::Handles->new(
777             stdin => $input,
778             stdout => $output,
779             stderr => $error,
780             );
781              
782 1         387 my $pid = do {
783 1 50       4 if ( $sign ) {
784 0         0 $gnupg->sign_and_encrypt ( handles => $handles );
785             } else {
786 1         8 $gnupg->encrypt ( handles => $handles );
787             }
788             };
789              
790 1         2982 my $read = _communicate([$output, $error], [$input], { $input => $plaintext });
791            
792 1         24 my @ciphertext = split(/^/m, $read->{$output});
793 1         5 my @error_output = split(/^/m, $read->{$error});
794            
795 1         15 waitpid $pid, 0;
796 1         8 my $return = $?;
797 1 50       6 $return = 0 if $return == -1;
798              
799 1         3 my $exit_value = $return >> 8;
800            
801              
802 1         4 $self->{last_message} = [@error_output];
803              
804 1 50       14 my $io = $body->open ("w") or die "can't open entity body";
805 1         118 $io->print (join('',@ciphertext));
806 1         12 $io->close;
807              
808 1         59 return $exit_value;
809             }
810              
811             =head2 mime_encrypt
812              
813             encrypt an email message
814              
815             Input:
816             MIME::Entity containing email message to encrypt
817             list of email addresses to sign to
818              
819             Output:
820             Exit code of gpg. (0 on success)
821              
822             $self->{last_message} => any errors from gpg
823              
824             The provided $entity will be encrypted. (i.e. it _will_ be modified.)
825              
826             =head2 mime_signencrypt
827              
828             sign and encrypt an email message
829              
830             Input:
831             MIME::Entity containing email message to sign encrypt
832             list of email addresses to sign to
833              
834             Output:
835             Exit code of gpg. (0 on success)
836              
837             $self->{last_message} => any errors from gpg
838              
839             The provided $entity will be encrypted. (i.e. it _will_ be modified.)
840              
841             =cut
842              
843             sub mime_encrypt {
844 0     0 1 0 my $self = shift;
845 0         0 $self->_mime_encrypt(0,@_);
846             }
847              
848             sub mime_signencrypt {
849 0     0 1 0 my $self = shift;
850 0         0 $self->_mime_encrypt(1,@_);
851             }
852              
853             sub _mime_encrypt {
854 0     0   0 my ($self,$sign,$entity,@recipients) = @_;
855              
856 0 0       0 die "Not a mime entity"
857             unless $entity->isa("MIME::Entity");
858              
859 0         0 my $workingentity = $entity;
860 0         0 $entity->make_multipart;
861 0 0       0 if ($entity->parts > 1) {
862 0         0 $workingentity = MIME::Entity->build(Type => $entity->head->mime_attr("Content-Type"));
863 0         0 $workingentity->add_part($_) for ($entity->parts);
864 0         0 $entity->parts([]);
865 0         0 $entity->add_part($workingentity);
866             }
867              
868 0         0 my $gnupg = GnuPG::Interface->new();
869              
870 0         0 $gnupg->options->push_recipients( $_ ) for @recipients;
871 0         0 $self->_set_options($gnupg);
872 0         0 my ( $input, $output, $error, $passphrase_fh, $status_fh )
873             = ( new IO::Handle, new IO::Handle,new IO::Handle,
874             new IO::Handle,new IO::Handle,);
875             my $handles = GnuPG::Handles->new( stdin => $input,
876             stdout => $output,
877             stderr => $error,
878 0 0       0 $self->{use_agent} ? () : (passphrase => $passphrase_fh),
879             status => $status_fh,
880             );
881              
882 0         0 my $pid = do {
883 0 0       0 if ($sign) {
884 0         0 $gnupg->sign_and_encrypt( handles => $handles );
885             } else {
886 0         0 $gnupg->encrypt( handles => $handles );
887             }
888             };
889              
890             # this passes in the plaintext
891 0         0 my $plaintext;
892 0 0       0 if ($workingentity eq $entity) {
893 0         0 $plaintext= $entity->parts(0)->as_string;
894             } else {
895 0         0 $plaintext=$workingentity->as_string;
896             }
897              
898             # no need to mangle line endings for encryption (RFC3156)
899             # $plaintext =~ s/\n/\x0D\x0A/sg;
900             # should we store this back into the body?
901              
902             # DEBUG:
903             #print "ENCRYPTING THIS STRING ----->\n";
904             # print $plaintext;
905             # print "<----\n";
906              
907 0 0       0 die "NO PASSPHRASE" unless defined $passphrase_fh;
908             my $read = _communicate([$output, $error, $status_fh],
909             [$input, $self->{use_agent} ? () : ($passphrase_fh)],
910             { $input => $plaintext,
911 0 0       0 $self->{use_agent} ? () : ($passphrase_fh => $self->{passphrase})}
    0          
912             );
913              
914 0         0 my @plaintext = split(/^/m, $read->{$output});
915 0         0 my @ciphertext = split(/^/m, $read->{$output});
916 0         0 my @error_output = split(/^/m, $read->{$error});
917 0         0 my @status_info = split(/^/m, $read->{$status_fh});
918              
919 0         0 waitpid $pid, 0;
920 0         0 my $return = $?;
921 0 0       0 $return = 0 if $return == -1;
922              
923 0         0 my $exit_value = $return >> 8;
924            
925              
926            
927            
928 0         0 $self->{last_message} = [@error_output];
929              
930              
931 0         0 $entity->parts([]); # eliminate all parts
932              
933 0         0 $entity->attach(Type => "application/pgp-encrypted",
934             Disposition => "inline",
935             Filename => "msg.asc",
936             Data => ["Version: 1",""],
937             Encoding => "7bit");
938 0         0 $entity->attach(Type => "application/octet-stream",
939             Disposition => "inline",
940             Data => [@ciphertext],
941             Encoding => "7bit");
942              
943 0         0 $entity->head->mime_attr("Content-Type","multipart/encrypted");
944 0         0 $entity->head->mime_attr("Content-Type.protocol","application/pgp-encrypted");
945              
946 0         0 $exit_value;
947             }
948              
949             =head2 is_signed
950              
951             best guess as to whether a message is signed or not (by looking at
952             the mime type and message content)
953              
954             Input:
955             MIME::Entity containing email message to test
956              
957             Output:
958             True or False value
959              
960             =head2 is_encrypted
961              
962             best guess as to whether a message is signed or not (by looking at
963             the mime type and message content)
964              
965             Input:
966             MIME::Entity containing email message to test
967              
968             Output:
969             True or False value
970              
971             =cut
972              
973             sub is_signed {
974 3     3 1 2395 my ($self,$entity) = @_;
975 3 100 100     22 return 1
976             if (($entity->effective_type =~ m!multipart/signed!)
977             ||
978             ($entity->as_string =~ m!^-----BEGIN PGP SIGNED MESSAGE-----!m));
979 1         922 return 0;
980             }
981              
982             sub is_encrypted {
983 3     3 1 7 my ($self,$entity) = @_;
984 3 100 66     10 return 1
985             if (($entity->effective_type =~ m!multipart/encrypted!)
986             ||
987             ($entity->as_string =~ m!^-----BEGIN PGP MESSAGE-----!m));
988 2         3365 return 0;
989             }
990              
991             # interleave reads and writes
992             # input parameters:
993             # $rhandles - array ref with a list of file handles for reading
994             # $whandles - array ref with a list of file handles for writing
995             # $wbuf_of - hash ref indexed by the stringified handles
996             # containing the data to write
997             # return value:
998             # $rbuf_of - hash ref indexed by the stringified handles
999             # containing the data that has been read
1000             #
1001             # read and write errors due to EPIPE (gpg exit) are skipped silently on the
1002             # assumption that gpg will explain the problem on the error handle
1003             #
1004             # other errors cause a non-fatal warning, processing continues on the rest
1005             # of the file handles
1006             #
1007             # NOTE: all the handles get closed inside this function
1008              
1009             sub _communicate {
1010 9     9   33 my $blocksize = 2048;
1011 9         39 my ($rhandles, $whandles, $wbuf_of) = @_;
1012 9         29 my $rbuf_of = {};
1013              
1014             # the current write offsets, again indexed by the stringified handle
1015 9         24 my $woffset_of;
1016              
1017 9         227 my $reader = IO::Select->new;
1018 9         149 for (@$rhandles) {
1019 21         85 $reader->add($_);
1020 21         831 $rbuf_of->{$_} = '';
1021             }
1022              
1023 9         34 my $writer = IO::Select->new;
1024 9         61 for (@$whandles) {
1025 12 50       125 die("no data supplied for handle " . fileno($_)) if !exists $wbuf_of->{$_};
1026 12 100       53 if ($wbuf_of->{$_}) {
1027 8         18 $writer->add($_);
1028             } else { # nothing to write
1029 4         21 close $_;
1030             }
1031             }
1032              
1033             # we'll handle EPIPE explicitly below
1034 9         231 local $SIG{PIPE} = 'IGNORE';
1035              
1036 9   66     90 while ($reader->handles || $writer->handles) {
1037 572         10932 my @ready = IO::Select->select($reader, $writer, undef, undef);
1038 572 50       222974 if (!@ready) {
1039 0         0 die("error doing select: $!");
1040             }
1041 572         488 my ($rready, $wready, $eready) = @ready;
1042 572 50       753 if (@$eready) {
1043 0         0 die("select returned an unexpected exception handle, this shouldn't happen");
1044             }
1045 572         618 for my $rhandle (@$rready) {
1046 316         356 my $n = fileno($rhandle);
1047             my $count = sysread($rhandle, $rbuf_of->{$rhandle},
1048 316         2574 $blocksize, length($rbuf_of->{$rhandle}));
1049 316 50       457 warn("read $count bytes from handle $n") if $DEBUG;
1050 316 50       421 if (!defined $count) { # read error
1051 0 0       0 if ($!{EPIPE}) {
1052 0 0       0 warn("read failure (gpg exited?) from handle $n: $!")
1053             if $DEBUG;
1054             } else {
1055 0         0 warn("read failure from handle $n: $!");
1056             }
1057 0         0 $reader->remove($rhandle);
1058 0         0 close $rhandle;
1059 0         0 next;
1060             }
1061 316 100       589 if ($count == 0) { # EOF
1062 21 50       50 warn("read done from handle $n") if $DEBUG;
1063 21         58 $reader->remove($rhandle);
1064 21         736 close $rhandle;
1065 21         39 next;
1066             }
1067             }
1068 572         769 for my $whandle (@$wready) {
1069 397         314 my $n = fileno($whandle);
1070 397 100       601 $woffset_of->{$whandle} = 0 if !exists $woffset_of->{$whandle};
1071             my $count = syswrite($whandle, $wbuf_of->{$whandle},
1072 397         5499 $blocksize, $woffset_of->{$whandle});
1073 397 50       491 if (!defined $count) {
1074 0 0       0 if ($!{EPIPE}) { # write error
1075 0 0       0 warn("write failure (gpg exited?) from handle $n: $!")
1076             if $DEBUG;
1077             } else {
1078 0         0 warn("write failure from handle $n: $!");
1079             }
1080 0         0 $writer->remove($whandle);
1081 0         0 close $whandle;
1082 0         0 next;
1083             }
1084 397 50       452 warn("wrote $count bytes to handle $n") if $DEBUG;
1085 397         445 $woffset_of->{$whandle} += $count;
1086 397 100       1511 if ($woffset_of->{$whandle} >= length($wbuf_of->{$whandle})) {
1087 8 50       15 warn("write done to handle $n") if $DEBUG;
1088 8         24 $writer->remove($whandle);
1089 8         5069 close $whandle;
1090 8         39 next;
1091             }
1092             }
1093             }
1094 9         421 return $rbuf_of;
1095             }
1096              
1097             # FIXME: there's no reason why is_signed and is_encrypted couldn't be
1098             # static (class) methods, so maybe we should support that.
1099              
1100             # FIXME: will we properly deal with signed+encrypted stuff? probably not.
1101              
1102             # Autoload methods go after =cut, and are processed by the autosplit program.
1103              
1104             1;
1105             __END__