Article 3588 of comp.lang.perl:
Xref: feenix.metronet.com comp.lang.perl:3588
Path: feenix.metronet.com!news.ecn.bgu.edu!wupost!howland.reston.ans.net!gatech!purdue!not-for-mail
From: spaf@cs.purdue.edu (Gene Spafford)
Newsgroups: comp.lang.perl
Subject: Re: Looking for mailstuff.pl
Date: 20 Jun 1993 22:36:09 -0500
Organization: Department of Computer Sciences, Purdue University
Lines: 87
Message-ID: <203ab9INNl0k@uther.cs.purdue.edu>
References: <1993Jun16.220130.17349@pslu1.psl.wisc.edu>
NNTP-Posting-Host: uther.cs.purdue.edu
In-reply-to: hoymand@wissago.uwex.edu's message of Wed, 16 Jun 93 22:01:30 GMT

It hasn't been updated in a while, but here it is:

#  Routines to parse out an RFC 822 mailheader
#     E. H. Spafford, 11/91; last mod 9/9/92
#  
#  Includes contribution/bugfix from:
#      Mike Stok  <mike@meiko.com>
#  
#  ParseMailHeader breaks out the header into an % array
#    indexed by a lower-cased keyword, e.g.
#       &ParseMailHeader(STDIN, *Array);
#	use $Array{'subject'}
#
#    Note that some duplicate lines (like "Received:") will get joined
#     into a single entry in %Array; use @Array if you want them separate
#    $Array will contain the unprocessed header, with embedded
#     newlines
#    @Array will contain the header, one line per entry
#
#  RetMailAddr tries to pull out the "preferred" return address
#    based on the presence or absence of various return-reply fields

package MailStuff;

#  Call as &ParseMailHeader(FileHandle, *array)

sub main'ParseMailHeader  ## Public
{
    local($save1, $save2) = ($*, $/);
    local($FH, *array) =  @_;
    local ($keyw, $val);

    %array = ();
    @array = ();

# force unqualified filehandles into callers' package
    local($package) = caller;
    $FH =~ s/^[^']+$/$package'$&/;

    ($*, $/) = (1, '');
    $array = $_ = <$FH>;
    ($*, $/) = ($save1, $save2); 
    s/\n\s+/ /g;
       
    @array = split('\n');
    foreach $_ (@array)
    {
	($keyw, $val) = m/^([^:]+):\s*(.*\S)\s*$/g;
	$keyw =~ y/A-Z/a-z/;
	if (defined($array{$keyw})) {
	    $array{$keyw} .= "\t$val";
	} else {
	    $array{$keyw} = $val;
	}
    }
}


#  Call as $addr = &RetMailAddr(*array)
#    This assumes that the header is in RFC 822 format

sub main'RetMailAddr  ## Public
{
    local(*arr) = @_;

    local($ReplyTo) = ($arr{'reply-to'} || $arr{'from'} ||
		       $arr{'return-path'} || $arr{'apparently-from'});

    defined($ReplyTo) ?  &CleanAddr($ReplyTo) : undef;
}

sub CleanAddr   ## Private
{
    local($_) = @_;
    s/\s*\(.*\)\s*//;
    1 while s/.*<(.*)>.*/$1/;
    s/^\s*(.*\S)\s*$/$1/;
    s/^@.*:.+@.+$/<$&>/;
    $_;
}

1;
-- 
Gene Spafford, COAST Project Director
Software Engineering Research Center & Dept. of Computer Sciences
Purdue University, W. Lafayette IN 47907-1398
Internet:  spaf@cs.purdue.edu	phone:  (317) 494-7825