scratch/sign
changeset 12 9f127fcfdf6d
parent 11 15a5ac599b95
child 14 4f50e6aa028b
child 15 7c3215a97e4b
equal deleted inserted replaced
11:15a5ac599b95 12:9f127fcfdf6d
     1 #! /usr/bin/perl
     1 #! /usr/bin/perl
     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;
       
     7 use autodie qw(:all);
       
     8 
       
     9 use Digest::MD5 qw(md5_hex);
     6 
    10 
     7 use blib;
    11 use blib;
     8 use Message::2822;
    12 use Message::2822;
     9 
    13 
    10 my $message = Message::2822->new(file => shift//"ex/mails/unsigned");
    14 umask(077);
       
    15 my $boundary = md5_hex(time);
       
    16 my $dir = File::Temp->newdir();
    11 
    17 
    12 say $message->header_content("received:");
    18 my $unsigned = Message::2822->new(file => shift//"ex/mails/unsigned");
    13 say $message->header_content("to:");
       
    14 
    19 
    15 exit;
       
    16 
    20 
    17 say $message->orig_header();
    21 # copy the body into a tmp file and copy there the content-
    18 say $message->orig_body();
    22 # header lines
       
    23 open(my $message, "+>$dir/message");
       
    24 print {$message}
       
    25     $unsigned->header_lines(qr/^content-/i), "\n",
       
    26     $unsigned->orig_body;
       
    27 $message->flush();
    19 
    28 
    20 #say map { ">> '$_'\n" } $message->header_fields();
    29 # now remove the unwanted content- header lines and add new ones
       
    30 $unsigned->remove_header_lines(qr/^content-.*?:/im);
    21 
    31 
       
    32 $unsigned->add_header_line("Content-Type: "
       
    33     . "multipart/signed; micalg=pgp-sha1;\n"
       
    34     . "\tprotocol=\"application/pgp-signature\"; boundary=\"$boundary\"");
       
    35 $unsigned->add_header_line("Content-Disposition: inline");
       
    36 
       
    37 
       
    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";
       
    48 
       
    49 seek($message, 0, 0);
       
    50 
       
    51 print "--${boundary}\n",
       
    52       <$message>, "\n",
       
    53       "--${boundary}\n",
       
    54       <<___, <$sig>, "\n--${boundary}--\n";
       
    55 Content-Type: application/pgp-signature; name="signature.asc"
       
    56 Content-Description: Digital Signature
       
    57 Content-Disposition: inline
       
    58 
       
    59 ___