File Coverage

blib/lib/Mail/GPG/Test.pm
Criterion Covered Total %
statement 173 258 67.0
branch 76 132 57.5
condition 33 79 41.7
subroutine 24 26 92.3
pod 0 16 0.0
total 306 511 59.8


line stmt bran cond sub pod time code
1             package Mail::GPG::Test;
2              
3             # $Id: Test.pm,v 1.6 2006/11/18 08:48:28 joern Exp $
4              
5 6     6   180456 use strict;
  6         29  
  6         454  
6              
7 6     6   2637 use Mail::GPG;
  6         16  
  6         191  
8 6     6   30 use MIME::Entity;
  6         10  
  6         156  
9 6     6   24 use MIME::Parser;
  6         8  
  6         79  
10 6     6   22 use Data::Dumper;
  6         17  
  6         259  
11 6     6   31 use File::Path;
  6         9  
  6         366  
12              
13 6     6   31 use File::Temp qw(tempdir);
  6         14  
  6         664  
14              
15             my $TIMEIT = 0;
16              
17             our $DUMPDIR;
18              
19             BEGIN {
20 6   50 6   49 $DUMPDIR = $ENV{DUMPDIR} || './mail-gpg-test';
21              
22 6 100       9553 if (not -d $DUMPDIR ) {
23 1 50       2268 File::Path::make_path($DUMPDIR) or die "Cannot create '$DUMPDIR' - $!";
24             }
25             }
26              
27              
28              
29             my $has_encode = eval { require Encode; 1 };
30              
31 78     78 0 6495 sub get_gpg_home_dir { shift->{gpg_home_dir} }
32 219     219 0 2230 sub get_use_long_key_ids { shift->{use_long_key_ids} }
33              
34 0     0 0 0 sub set_gpg_home_dir { shift->{gpg_home_dir} = $_[1] }
35 0     0 0 0 sub set_use_long_key_ids { shift->{use_long_key_ids} = $_[1] }
36              
37             #-- These methods return information about the shipped test key.
38             #-- The email adress has a German umlaut and colons
39             #-- to test the proper decoding of gpg --list-keys output.
40 127 100   127 0 1175 sub get_key_id { $_[0]->get_use_long_key_ids ?
41             '062F00DAE20F5035' : 'E20F5035' }
42 30 100   30 0 120 sub get_key_sub_id { $_[0]->get_use_long_key_ids ?
43             '6C187D0F196ED9E3' : '196ED9E3' }
44 180     180 0 2700 sub get_key_mail { 'Jörn Reder Mail::GPG Test Key ' }
45 62     62 0 254 sub get_passphrase { 'test' }
46              
47             sub new {
48 8     8 0 8667 my $class = shift;
49 8         40 my %par = @_;
50 8         23 my ($use_long_key_ids) = $par{'use_long_key_ids'};
51              
52 8         85 my $gpg_home_dir = tempdir("mgpgXXXX");
53              
54 8         2690 my $self = bless {
55             gpg_home_dir => $gpg_home_dir,
56             use_long_key_ids => $use_long_key_ids,
57             }, $class;
58              
59 8         31 return $self;
60             }
61              
62             sub DESTROY {
63 8     8   2413 my $self = shift;
64              
65             #-- tempdir ( CLEANUP => 1 ) seem not to work if
66             #-- an exception occured, so we use this destructor
67             #-- to remove the gpg home dir on exit.
68 8         142 rmtree( [ $self->get_gpg_home_dir ], 0, 0 );
69              
70 8         502 1;
71             }
72              
73             sub init {
74 8     8 0 46 my $self = shift;
75              
76 8         29 my $gpg_home_dir = $self->get_gpg_home_dir;
77              
78 8         45 my $command = "gpg --batch --no-tty --homedir $gpg_home_dir"
79             . " --import t/mgpg-test-key.pub.asc"
80             . " >/dev/null 2>&1 && "
81             . "gpg --batch --no-tty --homedir $gpg_home_dir"
82             . " --allow-secret-key-import"
83             . " --import t/mgpg-test-key.sec.asc"
84             . " >/dev/null 2>&1 && echo MGPG_OK";
85              
86 8         262315 my $output = qx[ $command ];
87              
88 8         623 return $output =~ /MGPG_OK/;
89             }
90              
91             sub get_mail_gpg {
92 62     62 0 272 my $self = shift;
93              
94             my $mg = Mail::GPG->new(
95             debug => $ENV{DUMPFILES},
96 62         955 default_key_id => $self->get_key_id,
97             default_passphrase => $self->get_passphrase,
98             use_long_key_ids => $self->get_use_long_key_ids,
99             gnupg_hash_init => {
100             homedir => $self->get_gpg_home_dir,
101             always_trust => 1,
102              
103             },
104             );
105              
106 62         285 return $mg;
107             }
108              
109             sub get_test_mail_body {
110 48     48 0 914 "This is a test mail body,\n"
111             . "with special characters: ÄÜÖß\n"
112             . "and lines with whitespace \n"
113             . "and a cr/lf line ending\r\n" . "and\n"
114             . "From at the beginning\n"
115             . "Let's see what happens.\n";
116             }
117              
118             sub print_parse_entity {
119 54     54 0 233 my $self = shift;
120 54         506 my %par = @_;
121             my ($entity, $modify) =
122 54         189 @par{'entity','modify'};
123              
124 54         257 my ( $fh, $file ) = File::Temp::tempfile(
125             'mgpgXXXXXXXX',
126             DIR => $DUMPDIR,
127             UNLINK => 1,
128             );
129              
130 54         21479 $entity->print($fh);
131 54         527598 close $fh;
132              
133 54 100       253 if ($modify) {
134 12 50       348 open( $fh, $file ) or die "can't read $file";
135 12         413 my $data = join( '', <$fh> );
136 12         111 close $fh;
137 12         113 $data =~ s/whitespace/spacewhite/g;
138 12         44 $data =~ tr/L/l/;
139 12 50       579 open( $fh, ">$file" ) or die "can't write $file";
140 12         85 print $fh $data;
141 12         742 close $fh;
142             }
143              
144 54 50       1629 open( $fh, $file ) or die "can't read $file";
145 54         400 my $mg = $self->get_mail_gpg;
146 54         395 my $parsed_entity = $mg->parse( mail_fh => $fh );
147 54         10267 close $fh;;
148 54         409 return $parsed_entity;
149             }
150              
151             sub sign_test {
152 24     24 0 252 my $self = shift;
153 24         233 my %par = @_;
154             my ($mg, $method, $encoding, $attach, $invalid) =
155 24         116 @par{'mg','method','encoding','attach','invalid'};
156              
157 24 100       206 $attach = "" if not defined $attach;
158 24 50       183 $invalid = "" if not defined $invalid;
159              
160 24 100       77 $attach = " (w/ attachmnt)" if $attach;
161 24 100       80 $invalid = "" if not $invalid;
162 24 100       48 $invalid = " (invalid)" if $invalid;
163              
164 24         129 my $test_name = "$method:$encoding Signature $attach$invalid";
165              
166 24         191 my $entity = MIME::Entity->build(
167             From => $self->get_key_mail,
168             Subject => "Mail::GPG Testmail",
169             Data => [ $self->get_test_mail_body ],
170             Encoding => $encoding,
171             Charset => "iso-8859-1",
172             );
173              
174 24 100       39901 if ($attach) {
175 8         79 $entity->attach(
176             Type => "application/octet-stream",
177             Disposition => "inline",
178             Data => [ "A great Ättächment. \n" x 10 ],
179             Encoding => "base64",
180             );
181             }
182              
183 24         18101 my $signed_entity = $mg->$method( entity => $entity );
184              
185 24 50       264 if ( not $mg->is_signed( entity => $signed_entity ) ) {
186 0         0 ok( 0, "$test_name: Entity not signed" );
187 0         0 return;
188             }
189              
190 24         170 my $signed_entity_string = $signed_entity->as_string;
191              
192 24         67405 my $parsed_entity = $self->print_parse_entity(
193             entity => $signed_entity,
194             modify => $invalid,
195             );
196              
197 24 50       90 if ( $ENV{DUMPFILES} ) {
198 0 0       0 my $tmp_file = "$DUMPDIR/$method-$encoding-"
    0          
199             . ( $attach ? "attach" : "noattach" ) . "-"
200             . ( $invalid ? "invalid" : "valid" );
201              
202 0         0 open( SEND, ">$tmp_file.send" );
203 0         0 open( RETR, ">$tmp_file.retr" );
204              
205 0         0 print SEND $signed_entity->as_string;
206 0         0 print RETR $parsed_entity->as_string;
207              
208 0         0 close SEND;
209 0         0 close RETR;
210             }
211              
212 24 100 100     181 if ( not $invalid
      100        
213             and not( $encoding eq 'base64' and $method eq 'armor_sign' ) ) {
214 10 50       121 if ( !Mail::GPG->is_signed( entity => $signed_entity ) ) {
215 0         0 ok( 0, "$test_name: MIME::Entity sign check failed" );
216 0         0 return;
217             }
218 10 50       96 if (!Mail::GPG->is_signed_quick(
219             mail_sref => \$signed_entity_string
220             )
221             ) {
222 0         0 ok( 0, "$test_name: mail_sref sign check failed" );
223 0         0 return;
224             }
225 10         96 my $tmp_file = "$DUMPDIR/Mail-GPG-Test-$$.txt";
226 10 50       517 open( TMP, "+>$tmp_file" ) or die "can't write $tmp_file";
227 10         90 print TMP $signed_entity_string;
228 10 50       53 if ( !Mail::GPG->is_signed_quick( mail_fh => \*TMP ) ) {
229 0         0 ok( 0, "$test_name: mail_fh sign check failed" );
230 0         0 close TMP;
231 0         0 unlink $tmp_file;
232 0         0 return;
233             }
234 10         76 close TMP;
235 10         407 unlink $tmp_file;
236             }
237              
238 24         57 my $result = eval { $mg->verify( entity => $parsed_entity, ); };
  24         226  
239              
240 24         120 my $error = $@;
241              
242 24 50 66     160 if ( not $invalid and $@ ) {
243 0         0 ok( 0, "$test_name: $@" );
244 0         0 return;
245             }
246              
247 24 50 33     170 if (not $invalid
      66        
248             and ( $result->get_sign_key_id ne $self->get_key_id
249             or $result->get_sign_mail ne $self->get_key_mail )
250             ) {
251 0         0 ok( 0, "Key/Email wrong" );
252 0         0 return;
253             }
254              
255 24 50 66     133 if ( not $invalid and $result->get_sign_trust ne '-' ) {
256 0         0 ok( 0, "Owner trust wrong" );
257             }
258              
259 24 100       75 if ($invalid) {
260 12 100       24 if ($error) {
261 2         32 ok( 1, $test_name );
262             }
263             else {
264 10         76 ok( !$result->get_sign_ok, $test_name );
265             }
266             }
267             else {
268 12         116 ok( $result->get_sign_ok, $test_name );
269             }
270              
271 24         22092 1;
272             }
273              
274             sub enc_test {
275 24     24 0 203 my $self = shift;
276 24         216 my %par = @_;
277             my ($mg, $method, $encoding, $attach) =
278 24         174 @par{'mg','method','encoding','attach'};
279              
280 24 100       241 $attach = " (w/ attachmnt)" if $attach;
281 24 100       104 $attach = "" if not defined $attach;
282              
283 24         74 my $entity = MIME::Entity->build(
284             From => $self->get_key_mail,
285             Subject => "Mail::GPG Testmail",
286             Data => [ $self->get_test_mail_body ],
287             Encoding => $encoding,
288             Charset => "iso-8859-1",
289             );
290              
291 24 100       35550 if ($attach) {
292 8         36 $entity->attach(
293             Type => "application/octet-stream",
294             Disposition => "inline",
295             Data => [ "A great Ättächment. \n" x 10 ],
296             Encoding => "base64",
297             );
298             }
299              
300 24         18230 my $enc_entity = $mg->$method(
301             entity => $entity,
302             recipients => [ $self->get_key_mail ],
303             );
304              
305 24 50       410 if ( not $mg->is_encrypted( entity => $enc_entity ) ) {
306 0         0 ok( 0, "Entity not encrypted" );
307 0         0 return;
308             }
309              
310 24         256 my $parsed_entity = $self->print_parse_entity(
311             entity => $enc_entity,
312             );
313              
314 24         109 my ( $dec_key_id, $dec_key_mail )
315             = $mg->get_decrypt_key( entity => $parsed_entity, );
316              
317 24 50       162 if ($has_encode) {
318 24 50       450 if ( $dec_key_id ne $self->get_key_id ) {
319 0         0 ok( 0,
320             "Decryption key wrong: "
321             . "$dec_key_id=="
322             . $self->get_key_id
323             );
324 0         0 return;
325             }
326 24 50       241 if ( $dec_key_mail ne $self->get_key_mail ) {
327 0         0 ok( 0,
328             "Decryption email wrong: "
329             . "$dec_key_mail=="
330             . $self->get_key_mail
331             );
332 0         0 return;
333             }
334             }
335             else {
336 0 0       0 if ( $dec_key_id ne $self->get_key_id ) {
337 0         0 ok( 0,
338             "Decryption key or email wrong: "
339             . "$dec_key_id=="
340             . $self->get_key_id );
341 0         0 return;
342             }
343             }
344              
345             my ( $dec_entity, $result )
346 24         61 = eval { $mg->decrypt( entity => $parsed_entity, ); };
  24         236  
347              
348 24 50       158 if ( $ENV{DUMPFILES} ) {
349 0 0       0 my $tmp_file
350             = "$DUMPDIR/$method-$encoding-" . ( $attach ? "attach" : "noattach" );
351              
352 0         0 open( SEND, ">$tmp_file.send" );
353 0         0 open( RETR, ">$tmp_file.retr" );
354             }
355              
356 24 50 66     392 if ( $method =~ /encrypt/
      33        
      66        
357             and $method !~ /sign/
358             and ( $result->get_is_signed
359             or $result->get_sign_key_id
360             or $result->get_sign_mail
361             or $result->get_sign_ok )
362             ) {
363 0         0 ok( 0, "Signature reported but message not signed" );
364 0         0 return;
365             }
366              
367 24 50 33     217 if ($method =~ /sign/
      66        
368             and ( not $result->get_sign_ok
369             or not $result->get_is_signed
370             or not $result->get_sign_key_id eq $self->get_key_id
371             or not $result->get_sign_mail eq $self->get_key_mail )
372             ) {
373 0         0 ok( 0, "Signature bad" );
374 0         0 return;
375             }
376              
377 24 50       62 if ($has_encode) {
378 24 50 33     174 if ( not $result->get_is_encrypted
      33        
      33        
379             or not $result->get_enc_ok
380             or not $result->get_enc_key_id eq $self->get_key_sub_id
381             or not $result->get_enc_mail eq $self->get_key_mail ) {
382 0         0 ok( 0, "Decryption failed" );
383 0         0 return;
384             }
385             }
386             else {
387 0 0 0     0 if ( not $result->get_is_encrypted
      0        
388             or not $result->get_enc_ok
389             or not $result->get_enc_key_id eq $self->get_key_sub_id ) {
390 0         0 ok( 0, "Decryption failed" );
391 0         0 return;
392             }
393             }
394 24 100       161 if ( $method =~ /armor/ ) {
    100          
395 8         29 my $entity_body = $entity->bodyhandle->as_string;
396 8         120 ok( $dec_entity->bodyhandle->as_string eq $entity_body,
397             "$method:$encoding Decryption$attach" );
398 8 50       5747 if ( $ENV{DUMPFILES} ) {
399 0         0 print SEND $entity_body;
400 0         0 print RETR $dec_entity->bodyhandle->as_string;
401             }
402             }
403             elsif ( not $attach ) {
404 8         33 ok( $dec_entity->body_as_string eq $entity->body_as_string,
405             "$method:$encoding Decryption$attach" );
406 8 50       21564 if ( $ENV{DUMPFILES} ) {
407 0         0 print SEND $entity->body_as_string;
408 0         0 print RETR $dec_entity->body_as_string;
409             }
410             }
411             else {
412 8   33     62 ok( ( $dec_entity->parts(0)->body_as_string eq
413             $entity->parts(0)->body_as_string
414             and $dec_entity->parts(1)->body_as_string eq
415             $entity->parts(1)->body_as_string
416             ),
417             "$method:$encoding Decryption$attach"
418             );
419 8 50       28745 if ( $ENV{DUMPFILES} ) {
420 0         0 print SEND $entity->body_as_string;
421 0         0 print RETR $dec_entity->body_as_string;
422             }
423             }
424              
425 24 50       103 if ( $ENV{DUMPFILES} ) {
426 0         0 close SEND;
427 0         0 close RETR;
428             }
429              
430 24         1783 1;
431             }
432              
433             sub big_test {
434 6     6 0 37 my $self = shift;
435 6         59 my %par = @_;
436 6         39 my ($mg, $chunks) = @par{'mg','chunks'};
437              
438 6   50     62 $chunks ||= 200000;
439              
440 6         18 srand($chunks);
441              
442 6         27 my $line = (join "", map { chr(32+rand(80)) } (1..40))."\n";
  240         386  
443              
444 6         50851 my @big_data = ( $line x $chunks );
445              
446 6         38 my $entity = MIME::Entity->build(
447             From => $self->get_key_mail,
448             Subject => "Mail::GPG Testmail",
449             Data => \@big_data,
450             Encoding => "base64",
451             Charset => "iso-8859-1",
452             );
453              
454 6         66014 my ($start, $dur);
455 6 50       23 if ( $TIMEIT ) {
456 6     6   2664 use Time::HiRes qw(time);
  6         6784  
  6         20  
457 0         0 $start = time();
458 0         0 print "encrypt... ";
459             }
460 6         26 my $enc_entity = $mg->mime_sign_encrypt(
461             entity => $entity,
462             recipients => [ $self->get_key_mail ],
463             );
464 6 50       75 if ($TIMEIT ) {
465 0         0 $dur = time-$start;
466 0         0 print "$dur !\n";
467             }
468 6 50       85 if ( not $mg->is_encrypted( entity => $enc_entity ) ) {
469 0         0 ok( 0, "Entity not encrypted" );
470 0         0 return;
471             }
472              
473 6 50       20 if ($TIMEIT ) {
474 0         0 $start = time();
475 0         0 print "print_parse... ";
476             }
477 6         98 my $parsed_entity = $self->print_parse_entity(
478             entity => $enc_entity,
479             );
480 6 50       21 if ($TIMEIT ) {
481 0         0 $dur = time-$start;
482 0         0 print "$dur !\n";
483             }
484              
485 6 50       13 if ($TIMEIT ) {
486 0         0 $start = time();
487 0         0 print "get_decrypt_key... ";
488             }
489 6         28 my ( $dec_key_id, $dec_key_mail )
490             = $mg->get_decrypt_key( entity => $parsed_entity, );
491 6 50       30 if ($TIMEIT ) {
492 0         0 $dur = time-$start;
493 0         0 print "$dur !\n";
494             }
495              
496 6 50       26 if ($has_encode) {
497 6 50       99 if ( $dec_key_id ne $self->get_key_id ) {
498 0         0 ok( 0,
499             "Decryption - key wrong: "
500             . "$dec_key_id=="
501             . $self->get_key_id );
502 0         0 return;
503             }
504              
505 6 50       37 if ( $dec_key_mail ne $self->get_key_mail ) {
506 0         0 ok( 0,
507             "Decryption - email wrong: "
508             . "$dec_key_mail=="
509             . $self->get_key_mail );
510 0         0 return;
511             }
512              
513              
514             }
515             else {
516 0 0       0 if ( $dec_key_id ne $self->get_key_id ) {
517 0         0 ok( 0,
518             "Decryption key or email wrong: "
519             . "$dec_key_id=="
520             . $self->get_key_id );
521 0         0 return;
522             }
523             }
524              
525 6 50       18 if ($TIMEIT ) {
526 0         0 print "decrypt... ";
527 0         0 $start = time();
528             }
529             my ( $dec_entity, $result )
530 6         11 = eval { $mg->decrypt( entity => $parsed_entity, ); };
  6         57  
531 6 50       32 if ($TIMEIT ) {
532 0         0 $dur = time-$start;
533 0         0 print "$dur !\n";
534             }
535 6 50 33     30 if ( not $result->get_sign_ok
      33        
      33        
536             or not $result->get_is_signed
537             or not $result->get_sign_key_id eq $self->get_key_id
538             or not $result->get_sign_mail eq $self->get_key_mail ) {
539 0         0 ok( 0, "Signature bad" );
540 0         0 return;
541             }
542              
543 6 50       28 if ($has_encode) {
544 6 50 33     46 if ( not $result->get_is_encrypted
      33        
      33        
545             or not $result->get_enc_ok
546             or not $result->get_enc_key_id eq $self->get_key_sub_id
547             or not $result->get_enc_mail eq $self->get_key_mail ) {
548 0         0 ok( 0, "Decryption failed" );
549 0         0 return;
550             }
551             }
552             else {
553 0 0 0     0 if ( not $result->get_is_encrypted
      0        
554             or not $result->get_enc_ok
555             or not $result->get_enc_key_id eq $self->get_key_sub_id ) {
556 0         0 ok( 0, "Decryption failed" );
557 0         0 return;
558             }
559             }
560              
561 6         88 ok( 1, "Big entity" );
562              
563 6         22151 1;
564             }
565              
566             1;