Perl to parse email, change "From:" header, send onwards

Question

I wish I was lying, but I've spent several months trying to get this to work and I have to admit defeat on my perl scripting skills. I'm at a loss to make this work and need help (for which I wil be very grateful).

The background: I am running a discussion email list using a third party Listserv. I want to change the "From" header on incoming emails to an address at my domain, by doing a database lookup for the email address, and then adding the users name and company code to the From header, and sending it on.

For example, Super Dave , is changed to David Smith (ABC - LON) , and then the list members will see that header instead of whatever he has chosen as his "From free text".

The script I have developed works very well ... except that more complex emails seem to stun it. Right now the script takes a text version of the email, strips out all the MIME parts and html bits, and changes the header. If it encounters an email format thats new to it (and I havent written a code line to handle), it stops. I could continue fixing each type of email coming in, but I think thats overkill - I need to get back to the KISS method.

Note: the database lookup is without issue. The problem is in the way the email body finally arrives at the listserver.

Instead of this, I want to leave the original email untouched, but just change the From header. Nothing else. Is there any way to do that? Here is (the salient part of) the script.

What Im after is a much simpler method to search the email for the from Header, change it to another value, and then send it on.

Thoughts?

$connect = DBI->connect($dsn, $user, $pw);
open FH, ">mail.txt" or die "can't open mail.txt: $!";
while ( $_ = <STDIN>) {
print FH "$_";
}
close(FH);
$file_content = `cat 'mail.txt' | grep -m1 From |tail -n+1`;
chomp($file_content);
$from = `echo "$file_content"| sed -e "s/.*<//;s/>.*//"`;
chomp($from);
$subject=`cat mail.txt |grep -m1 Subject| sed -e "s/.*Subject: //"`;
chomp($subject);
system('./body.sh');
$encoded=`cat body.txt`;

#Decode the mail and save output to dbody.txt. Still have header+body at this stage.
$body=decode_qp($encoded);
open FF, ">dbody.txt" or die $!;
print FF $body;
close FF;
#If body still has headers, Look for first blank line, and delete all before - this is the body
$bodycheck =`cat dbody.txt`;
if ($bodycheck =~ /Message-Id/ ){
$bodyfinal= `sed '0,/^\$/d' dbody.txt`;
} else {
$bodyfinal =$bodycheck
}

#Save the output to bodyfinal.txt
open FF, ">bodyfinal.txt" or die $!;
print FF $bodyfinal;
close FF;

#THIS SECTION contains code to query the database with the original FROM email address
#get username and domain and then change to lower case for the query
$case_username = substr($from, 0, index($from, '@'));
$m_username = lc($case_username);
$case_domain = substr($from, index($from, '@')+1);
$m_domain = lc($case_domain);
#print "\n##############$m_username\@$m_domain#################\n";
$query = "select user_real_name, company_code, location_code from user where user_email='$m_username\@$m_domain'";
$query_handle = $connect->prepare($query);
$query_handle->execute() or die $DBI::errstr;
@result=$query_handle->fetchrow_array();
print "\n@result\n";
##Forward the mail


sub sendEmail
 {
        my ($to, $from_sub, $subject, $message) = @_;
        my $sendmail = '/usr/sbin/sendmail';
        open(MAIL, "|$sendmail -oi -t");
                print MAIL "From: $from_sub\n";
                print MAIL "To: $to\n";
                print MAIL "Subject: $subject\n\n";
                print MAIL "$message\n";
        close(MAIL);
 }

{my $msg = MIME::Lite->new
(
        Subject => "$subject",
        From    => "$result[0] ($result[1]/$codes[0]-$result[2])<listmail@>",
        To      => 'opg@maillist.com',
        Type    => 'text/plain',
        Encoding => '7bit',
        Data    => "From: $result[0]/$result[1]-$codes[0]/$result[2] \n________________________________________________ \n \n$bodyfinal \n"
);
$msg->send();
}

Answer 1

To only answer "what is a simple method to search some file for a From: header, change it to another value, and send it on?": use Tie::File;

Given a file named 'email' that contains the example headers from this page,

#! /usr/bin/env perl
use common::sense;
use Tie::File;

tie my @f, 'Tie::File', 'email' or die $!;

for (@f) {
  if (/^From:/) {
    say "old: $_";
    s/(?<=^From:).*$/ A New Sender <anewsender\@ans.com>/;
    say "new: $_";
    last
  }
}

untie @f;

Output:

$ perl tie-ex 
old: From: Taylor Evans <example_from@dc.edu>
new: From: A New Sender <anewsender@ans.com>

$ grep ^From email
From: A New Sender <anewsender@ans.com>

Mind, there's all kinds of wrong with this. Headers don't need to be neatly on one line; there can be more than one From: header (by someone else's scripting error, for instance); there can even be no From: header in the headers and then a From: randomly in the body. Spammers do strange things. But if your original code already contains these limitations and you're happy enough with them, try this.

Meanwhile, there are already great Perl modules that handle mail. Take a look through the Email:: modules listed here.