fixreply

#!/usr/bin/env perl
#
# fixreply
#
# Rewrite a mail message's Reply-To header to the mailing list address so that
# using the mail client Reply command sends a reply to the list by default.
#
# The headers that override Reply-To, in order of preference, are:
# Mail-Followup-To	<http://cr.yp.to/proto/replyto.html>
# List-Post	<http://www.ietf.org/rfc/rfc2369.txt>
#
# Michael Wardle <michael@endbracket.net>
# $Id$

use Mail::Internet;

# whether to print informational messages
$verbose = 1;

# fields to replace and which fields to replace them with
$replacements{"Reply-To"} = [ "Mail-Followup-To", "List-Post" ];

# read the original message
$original = new Mail::Internet(\*STDIN);
$header = $original->head();
$body = $original->body();

# log the message id
if ($verbose)
{
    $value = $header->get("Message-Id");
    if (defined($value))
    {
        chomp($value);
    }
    print STDERR "Message-Id: " . $value . "\n";
}

# attempt to perform replacements for every key in replacements
for $key (keys(%replacements))
{
    $old = $header->get($key);
    if (defined($old))
    {
        chomp($old);
    }

    # find the first preferred replacement header
    $new = undef;
    for $replacement (@{$replacements{$key}})
    {
        if ($header->count($replacement))
        {
            # retrieve the replacement value
            $new = $header->get($replacement);
            if (defined($new))
            {
                chomp($new);
            }

            # List-Post uses a URI rather than a mail address
            if ($new =~ /<mailto:(.*?)>/)
            {
                $new =~ s/<mailto:(.*?)>/<$1>/;
            }

            # print the old and new values
            if ($verbose)
            {
                print STDERR "Old $key: " . $old . "\n";
                print STDERR "New $key: " . $new . "\n";
            }

            last;
        }
    }

    # set the new header if a better one was found
    if ($new)
    {
        $header->replace("X-Original-" . $key, "X-Original-" . $key . ": " . $old);
    }
}

# print the new (possibly modified) message
$modified = new Mail::Internet(undef, Header=>$header, Body=>$body);
$modified->print(\*STDOUT);

# vi: set sw=4 ts=33: