2 |
2 |
3 use 5.010; |
3 use 5.010; |
4 use strict; |
4 use strict; |
5 use warnings; |
5 use warnings; |
6 use File::Temp; |
6 use File::Temp; |
|
7 use GnuPG; |
7 use autodie qw(:all); |
8 use autodie qw(:all); |
8 |
9 |
9 use Digest::MD5 qw(md5_hex); |
10 use Digest::MD5 qw(md5_hex); |
10 |
11 |
11 use blib; |
12 use blib; |
12 use Message::2822; |
13 use Message::2822; |
13 |
14 |
14 umask(077); |
15 umask(077); |
15 my $boundary = md5_hex(time); |
16 my $boundary = md5_hex(time); |
16 my $dir = File::Temp->newdir(); |
17 my $dir = File::Temp->newdir(); |
17 |
18 |
18 my $unsigned = Message::2822->new(file => shift//"ex/mails/unsigned"); |
19 my $unsigned = Message::2822->new(file => shift // "ex/mails/unsigned"); |
19 |
20 |
|
21 # copy the changed body into a tmp file and copy there the |
|
22 # changed content-header lines |
|
23 open(my $message, "+>$dir/message"); |
20 |
24 |
21 # copy the body into a tmp file and copy there the content- |
25 open(my $header, "+>$dir/header"); |
22 # header lines |
26 print {$header} $unsigned->header_lines(qr/^content-/i); |
23 open(my $message, "+>$dir/message"); |
27 seek($header, 0, 0); |
24 print {$message} |
28 while (<$header>) { |
25 $unsigned->header_lines(qr/^content-/i), "\n", |
29 s/\r?\n/\r\n/g; |
26 $unsigned->orig_body; |
30 print {$message} $_; |
|
31 } |
|
32 print {$message} "\r\n"; |
|
33 |
|
34 open(my $body, "+>$dir/body"); |
|
35 print {$body} $unsigned->orig_body; |
|
36 seek($body, 0, 0); |
|
37 while (<$body>) { |
|
38 s/\r?\n/\r\n/g; |
|
39 print {$message} $_; |
|
40 } |
|
41 |
27 $message->flush(); |
42 $message->flush(); |
|
43 |
|
44 # ask GPG to sign it… |
|
45 open(my $sig, "+>$dir/signature.asc"); |
|
46 my $gpg = new GnuPG(homedir => "ex/gpg"); |
|
47 seek($message, 0, 0); |
|
48 eval { |
|
49 $gpg->sign( |
|
50 plaintext => $message, |
|
51 'detach-sign' => 1, |
|
52 armor => 1, |
|
53 output => $sig |
|
54 ); |
|
55 }; |
|
56 |
|
57 if ($@) { |
|
58 $unsigned->add_header_line("X-GPGate-signed: not\n"); |
|
59 print $unsigned->header_lines, "\n"; |
|
60 print $unsigned->orig_body; |
|
61 exit 0; |
|
62 } |
28 |
63 |
29 # now remove the unwanted content- header lines and add new ones |
64 # now remove the unwanted content- header lines and add new ones |
30 $unsigned->remove_header_lines(qr/^content-.*?:/im); |
65 $unsigned->remove_header_lines(qr/^content-.*?:/im); |
31 |
66 |
32 $unsigned->add_header_line("Content-Type: " |
67 $unsigned->add_header_line("Content-Type: " |
33 . "multipart/signed; micalg=pgp-sha1;\n" |
68 . "multipart/signed; micalg=pgp-sha1;\n" |
34 . "\tprotocol=\"application/pgp-signature\"; boundary=\"$boundary\""); |
69 . "\tprotocol=\"application/pgp-signature\"; boundary=\"$boundary\""); |
35 $unsigned->add_header_line("Content-Disposition: inline"); |
70 $unsigned->add_header_line("Content-Disposition: inline"); |
36 |
71 |
37 |
72 $unsigned->add_header_line("X-GPGate-signed: yes\n"); |
38 # ask GPG to sign it… |
|
39 system("gpg", |
|
40 "--rfc1991", |
|
41 "--detach-sign", |
|
42 "--homedir" => "ex/gpg", |
|
43 "--armor" => "$dir/message"); |
|
44 |
|
45 open(my $sig, "$dir/message.asc"); |
|
46 |
|
47 print $unsigned->header_lines, "\n"; |
73 print $unsigned->header_lines, "\n"; |
48 |
74 |
49 seek($message, 0, 0); |
75 seek($message, 0, 0); |
|
76 seek($sig, 0, 0); |
50 |
77 |
51 print "--${boundary}\n", |
78 print "--${boundary}\n", |
52 <$message>, "\n", |
79 <$message>, "\n", |
53 "--${boundary}\n", |
80 "--${boundary}\n", |
54 <<___, <$sig>, "\n--${boundary}--\n"; |
81 <<___, <$sig>, "--${boundary}--\n"; |
55 Content-Type: application/pgp-signature; name="signature.asc" |
82 Content-Type: application/pgp-signature; name="signature.asc" |
56 Content-Description: Digital Signature |
83 Content-Description: Digital Signature |
57 Content-Disposition: inline |
84 Content-Disposition: inline |
58 |
85 |
59 ___ |
86 ___ |