Vyššie na [Platon] / scripts / perl / mail-gnupg

Fix: fixed GPG encryption of multipart (attachments) emails. If Content-Type was last header line, this line get lost and no Content-Type header line was in encrypted message. So mutt can not open this message.

#!/usr/bin/perl -w

#
# mail-gnupg-encrypt.pl - encrypt received mail with
#                         your GnuPG/PGP key. Use with
#                         procmail.
#
# Developed by Lubomir Host 'rajo' <rajo AT platon.sk>
# Copyright (c) 2005 Platon SDG, http://platon.sk/
# Licensed under terms of GNU General Public License.
# All rights reserved.
#
# Changelog:
# 2005-01-13 - created
#
#
# Keywords: mail, email, protected email, encryted email,
#           GnuPG, GPG, PGP, encryption, procmail,
#           mail filter, procmailrc, formail, security
#
# http://www.faqs.org/rfcs/rfc2015.html
# http://www.faqs.org/rfcs/rfc3156.html
#

#
# Usage: add following lines into your ~/.procmailrc
#
# :0fw:
# | /path/to/mail-gnupg-encrypt.pl -r your@email.address.com
#

# $Platon: scripts/perl/mail-gnupg/mail-gnupg-encrypt.pl,v 1.4 2010-10-05 23:03:09 rajo Exp $

use strict;
use warnings;

use English;
use AppConfig qw/:expand :argcount/;
use GnuPG::Tie::Encrypt;

use vars qw (
    $VERSION
    %conf $conf
    $recipient
    $cfgfile
    $boundary $new_content_type $old_content_type
    $header_line $curr_header_key
    $new_content_type_is_set
);

sub help($;);

$| = 1;

$VERSION    = do { my @r = (q$Revision: 1.5 $=~/\d+/g); sprintf "%d." . "%02d" x $#r, @r };

my @char=("A".."Z", "a".."z", 0..9);
$boundary = join("", @char[map{rand @char} (1..16)]);

$new_content_type = "Content-Type: multipart/encrypted; protocol=\"application/pgp-encrypted\";\n\tboundary=\"$boundary\"\n";
$old_content_type = '';
$header_line = '';
$curr_header_key = '';
$new_content_type_is_set = 0;

$conf = AppConfig->new( # {{{
    {
        CASE => 1,
        DEBUG => 0,
        CREATE => 0,
        GLOBAL => {
            ARGCOUNT => ARGCOUNT_NONE,
        }
    },
    # ALIAS =>, so imperfect and universe-breaking, and we still need it.
    "config|cfg=s",        { },
    "recipient|r=s",    { },
    "version",            {
        ACTION => sub { print "$0 version $VERSION"; exit 0 }
    },
) or die "Can't initialize the AppConfig object\n";

$conf->getopt; # parse command line

$cfgfile    = $conf->cfg();
if (defined($cfgfile) and $cfgfile ne '') {
    unless (-r $cfgfile) {
        help("Config file '$cfgfile' not found\n");
    }
    else {
        $conf->file($conf->cfg)
    }
}

$recipient    = $conf->recipient();

if (!defined($recipient) or $recipient eq '') {
    help("You need specify at least recipient parameter\n");
    exit 1;
}
# }}}

tie *CIPHER, 'GnuPG::Tie::Encrypt', armor => 1, recipient => $recipient;
pipe(PARENT_RDR, CHILD_WTR) or die "Can't create pipe: $!\n";

if (my $pid = fork()) { # parent
    close (STDOUT);
    close (PARENT_RDR);
    while (my $line = <STDIN>) {
        if ($line =~ m/^$/o) { # end of header, print PGP header {{{
            print CHILD_WTR $header_line;
            if ($new_content_type_is_set == 0) {
                #warn "NO CONTENT-TYPE-YET";
                print CHILD_WTR $new_content_type;
            }
            print CHILD_WTR "\n\n--$boundary\n",
            "Content-Type: application/pgp-encrypted\n",
            "Content-Disposition: attachment\n\n",
            "Version: 1\n\n",
            "--$boundary\n",
            "Content-Type: application/octet-stream\n",
            "Content-Disposition: inline; filename=\"msg.asc\"\n\n";
            last;
        } # }}}
        if ($line =~ m/^([a-zA-Z0-9-]+):\s+/o) { # {{{
            if ($curr_header_key eq 'content-type') { # na predchadzajucom riadku bol content-type
                $header_line .= $line;
                $line = $new_content_type;
                $new_content_type_is_set = 1;
            }
            $curr_header_key = lc($1);
            if ($curr_header_key eq 'content-type') {
                $old_content_type = $line;
            }
            else {
                print CHILD_WTR $header_line, $line; # one header line completes, ship it out
                $header_line = "";
            }
        } # }}}
        else { # {{{
            if ($curr_header_key eq 'content-type') {
                $old_content_type .= $line;
                #print "OLD = '$old_content_type'\n";
            }
            else {
                #print "XXX line ='$line'\n";
                $header_line .= $line;
            }
        } # }}}
    }
    close (CHILD_WTR);
    
    #
    # rest goes to the GnuPG
    #
    print CIPHER $old_content_type;
    print CIPHER "Content-Disposition: inline\n\n";
    # mail content goes to GnuPG withouth temporary file
    while (my $line = <STDIN>) {
        print CIPHER $line;
    }
}
else { # child
    die("Fork failed!: $!") unless defined $pid;
    close (STDIN);
    close (CHILD_WTR);
    while (<PARENT_RDR>) { # first read header (unencrypted data from parent)
        print;
    }
    while (<CIPHER>) { # read encrypted output from GnuPG
        print;
    }
    # print terminator
    print "\n--$boundary--\n";
}

close CIPHER;
untie *CIPHER;

sub help($;)
{ # {{{
    my ($err) = @_;

    print STDERR "\nError: $err\n";

    print STDERR <<EOF;
Usage:

    -r
    --recipient        Define encrypted message recipient

    --cfg
    --config        Read options from config file

    --version        Print version and exit

EOF

    exit 1;
    
} # }}}

# vim: ts=4
# vim600: fdm=marker fdl=0 fdc=3