#!/usr/bin/perl
#
#NAME
#  Mrpl - generate mail reply headers
#
#SYNOPSIS
#    !}Mrpl
#
#DESCRIPTION
# Given a set of email headers on stdin, this program tries to figure out how
# to  send  a reply back, and generates what it guesses might be good headers
# for a reply message.  We can also make a  list  of  the  input  lines,  and
# produce  them  at  the  end  as comments.  We put "#\t" on the ones that we
# process, and "#??\t" on the ones we don't  recognize.   We  join  continued
# lines  and  scrunch  whitspace.   Eventually,  we might want to delete this
# debugging junk, but for now, it's useful.
#
# The following verbose levels might be of interest:
#   -V1 default, gives only reply header lines.
#   -V2 shows the original headers as scrunched comments.
#   -V3 gives X-* lines showing critical info extracted.
#   -V4 gives X-Rcvd lines showing parse of email path info.
#
#KLUDGE
# If the first header line is indented via a tab, we strip  away  an  initial
# tab  from  all  the  input.   This  is to handle the indenting done by some
# incarnations of the mail(1) and Mail(1) commands.
#
#AUTHOR
#   John Chambers <jc@trillian.mit.edu>
# Copyright (c) 1992 by John Chambers.   Permission  to  use  is  granted  to
# everyone,  as  long  as  you give me credit for my work (and mistakes), and
# take credit for what you add or delete.  No warrantee of any kind is stated
# or  implied.   Whether this code works is dependent, among other things, on
# your operating system and which version of perl you may have.

($me = $0) =~ s".*/"";		# Our actual name, minus directories.
$V = $ENV{"V_$me"} || 1;	# Verbosity level.
$lin = $nxt = '';
$Rf = '';	# Reference list.
$I = '#';	# Char used to flag original lines.

# Process the command-line args.
#
for $a (@ARGV) {
	if ($a =~ /-[DdVv]([0-9])*/) {	# Verbosity level.
		$V = $1 ? $1 : 2;
		next;
	}
	print STDERR "Arg \"$a\" ignored.\n";
}

# Chew up the input, one header line at a time.  Note that we use  getline(),
# which merges multi-line items into a single line.  We still must handle the
# possibility of a mixture of tabs and spaces, but perl's \s makes this easy.
#
while ($l = &getline()) {
	chop $l;
	@line[$#line + 1] = "$I\t$l";
	if ($l =~ /^Reply-To:\s*(.*)/) {	# The preferred Internet return address.
		$Reply_To = $l;
		$r = $1;
		if ($r =~ /^(.*)<(.*)>\s*$/) {	# R.J.Hacker <foo!bar!rjh>
			$RT = &trim($2);	# Should be bang path to sender.
			$Fd = &trim($1);	# Should be description or name.
			next;
		} elsif ($r =~ /^(.*)\((.*)\)\s*$/) {	# foo!bar!rjh (R.J.Hacker)
			$RT = &trim($1);	# Should be bang path to sender.
			$Fd = &trim($2);	# Should be description or name.
			next;
		} else {
			$RT = &trim($1);	# Should be just a (bang) path to sender.
			next;
#		} else {
#			print STDERR "### Can't handle Reply-To line.\n";
		}
	}
	if ($l =~ /^Apparently-To:[ 	]*(.*)/) {
		$Apparently_To = $l;
		$AT = &trim($1);	# Should be email path from sender to recipient.
		next;
	}
	if ($l =~ /^From +([^ ]+) *(.*)/) {	# UUCP return address.
		$UUCP_From = $l;
		$FU =		# UUCP "From" path.
		$Fr = &trim($1);	# Should be bang path to sender.
		$Dr = $2;	# Date received.
		next;
	}
	if ($l =~ /^From:/) {	# Some people don't like us to use this.
		$SMTP_From = $l;
		if ($l =~ /^From:[ 	]*(.+) +\((.*)\)/) {
			$FS = 
			$Fr = &trim($1);	# Can be any kind of path to sender.
			$Fd = &trim($2);	# Comment should describe sender.
			next;
		}
		if ($l =~ /^From:[ 	]*(.+) +<(.*)>/) {
			$FS = 
			$Fr = &trim($2);	# Can be any kind of path to sender.
			$Fd = &trim($1);	# Comment should describe sender.
			next;
		}
		if ($l =~ /^From:[ 	]*(.+)/) {
			$FS = 
			$Fr = &trim($1);	# Assume it's just an email path.
			next;
		}
		next;
	}
	if ($l =~ /^X-/) {	# At present, we don't recognize any of these.
		next;
	}
	if ($l =~ /^Return-Path:[ 	]*(.*)/) {	# Return path hated by some.
		$Return_Path = $l;
		$RP = &trim($1);	# Path back to sender.
		next;
	}
	if ($l =~ /^Received:(.*)/) {
		$Re = $1 . ' ';	# Path back to sender.
		$R_for = $R_sid = $R_mlr = $R_frm = $R_via = $R_mid = '';
#		$Received = $l;
		if ($Re =~ s/\s+\(*for\s+(\S+)\)*\s*/ /) {
			$R_for = &trim($1);	# Mail handler id.
		}
		if ($Re =~ s/\s+by\s+([A-Za-z0-9.-]+)\s*/ /) {
			$R_sid = &trim($1);	# Should be system id.
		}
		if ($Re =~ s/\s+from\s+([A-Za-z0-9.-]+)\s+/ /) {
			$R_frm = &trim($1);	# Id of sender system.
		}
		if ($Re =~ s/\s+id\s+(<\S*>)\s*;*/ /) {
			$R_mid = &trim($1);	# Message id.
		}
		if ($Re =~ s/\s+[Ii][Dd]\s+(\S*)\s*;*/ /) {
			$R_mid = &trim($1);	# Message id.
		}
		if ($Re =~ s/\s+via\s+(\S*)\s*;*/ /) {
			$R_via = &trim($1);	# Network name.
		}
		if ($Re =~ s/\s+with\s+(\S*)\s*;*/ /) {
			$R_wth = &trim($1);	# Network name.
		}
		if ($Re =~ s/^\s+\((.*)\)/ /) {
			$R_mlr = $1;	# Mail handler id.
		}
		$Re =~ s/^\s+//;
		$Re =~ s/\s+$//;
		if ($V > 3) {
			print "X-Rcvd:\tby <$R_sid> from <$R_frm>\n";
			print "\tfor <$R_for> via <$R_via> with <$R_wth>\n" 
				if $R_for || $R_via;
			print "\tid <$R_mid> ($R_mlr)\n"
				if $R_mid || $R_mlr;
			print "\t[$Re]\n" 
				if $Re;
		}
		next;
	}
	if ($l =~ /^[ 	]*\(for (.*)\)\s+id\s[ 	]*(.*)/) {
		$Msg_Id = $l;
#		$Fr = $1;	# Who this system thought it was sent to.
		$Id = $2;	# One system's message ID, plus assorted junk.
		next;
	}
	if ($l =~ /^Sender:[ 	]*(.+)/) {	# Where is this documented?
		$Sender = $l;
		$FS = 
		$Fr = $1;
		next;
	}
	if ($l =~ /^Subject:[ 	]*(.+)/) {	# Not required, but nice to have.
		$Sb = $1;	# Subject is arbitrary string.
		$Sb =~ s/ *R[Ee][: ]*//;
		next;
	}
	if ($l =~ /^To:[ 	]*(.+)/) {	# Not always who it was originally sent to.
		$Sent_To = $l;
		$To = $1;	# Should be valid email address.
		next;
	}
	if ($l =~ /^Cc:[ 	]*(.+)/) {	# Not always who it was originally sent to.
		$Also_To = $l;
		$Cc = $1;	# Should be valid email address(es).
		next;
	}
	if ($l =~ /^Date:[ 	]*(.+)/) {	# Not always who it was originally sent to.
#		$Date = $l;
		$Ds = $1;	# Date sent.
		next;
	}
	if ($l =~ /^(Newsgroups*):[ 	]*(.+)/) {	# Reply to BB article.
#		$Newsgroup = $l;
		$Nh = $1;	# Can be plural.
		$Ng = $2;
		next;
	}
	if ($l =~ /^(References*):[ 	]*(.+)/) {	# Other BB articles.
#		$Rh = $1;	# Can be plural.
		$Rf = $2;
		next;
	}
	if ($l =~ /^In-Reply-To:[ 	]*(.+)/) {
		$In_Reply_To = $l;
		$IRT = $1;	# Should be valid email address.
		next;
	}
	if ($l =~ /^Message-Id:[ 	]*(.+)/) {	# Other BB articles.
		$Message_Id = $l;
		$ID = $1;
		next;
	}
	if ($l =~ /^X-Mailer:[ 	]*(.+)/) {
		$X_Mailer = $l;
		$XM = $1;	# Should be valid email address.
		next;
	}
	@line[$#line] =~ s/^$I/$I??/;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# We now put out a summary of what we learned from the headers.  This is done #
# only at debug level 3 and higher, because we usually don't want it.         #
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
if ($V > 2) {
	if ($Message_Id)    {print "X-$Message_Id\n";}
	if ($Sent_To)       {print "X-Sent-To: $To\n";}
	if ($Also_To)       {print "X-Also-To: $Cc\n";}
	if ($Apparently_To) {print "X-Aply-To: $AT\n";}
	if ($Dr)            {print "X-Recv-Date: $Dr\n";}
	if ($Ds)            {print "X-Send-Date: $Ds\n";}
	if ($XM)            {print "X-$X_Mailer\n";}
	if ($In_Reply_To)   {print "X-In-Reply: $IRT\n";}
	if ($Reply_To)      {print "X-$Reply_To\n";}
	if ($Return_Path)   {print "X-$Return_Path\n";}
	if ($Sender)        {print "X-$Sender\n";}
	if ($SMTP_From)     {print "X-SMTP-$SMTP_From\n";}
	if ($UUCP_From)     {print "X-UUCP-From: $FU\n";}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Well, that wraps up the processing of the input,  which  should  have  been #
# only email header lines, though all sorts of junk is possible. To reply, we #
# go thru the possible return addresses in what we believe is  the  preferred #
# order, taking the first that is nonnull.                                    #
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
if ($RT) {
	&to($RT,$Fd);
} elsif ($RP) {
	&to($RP,$Fd);
} elsif ($Fr) {
	&to($Fr,$Fd);
} else {
	&to("UNKNOWN",$Fd);	# This should bounce rapidly.
}
# It's conventional to add exactly one "Re:" to the subject.
if ($Sb) {
	print "Subject: Re: $Sb\n";
}
# For news/BB articles, we preserve the group names.
if ($Ng) {
	$Ng =~ s/,  */,/g;
	print "$Nh: $Ng\n";
}
# We use the REPLYTO environment variable like the mail package does:
if  ($replyto = $ENV{"REPLYTO"}) {
	print "Reply-To: $replyto\n";
}
# If there were any references, we preserve them.
$Rf = "$ID,$Rf" if ($ID);
if ($Rf) {
	$Rf =~ s/, *$//;
	$Rf =~ s/,  */,/g;
	print "References: $Rf\n";
}
if ($V > 1) {
	for $l (@line) {
		$l =~ s/\s+/ /g;
		print "$l\n";
	}
}
exit 0;
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Here's a routine to generate the "To:  Note that we first strip off  spaces #
# and "<>"." line.  We also remember the recipient for possible later use.    #
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
sub to {
	local($rcpt,$desc) = @_;
	$rcpt =~ s/^[ 	<]*//;
	$rcpt =~ s/[ 	>]*$//;
	$rcpt =~ s/\.ENET\./.MKO./i;	# Kludge for DEC MKO machines.
	print "To: <$rcpt> ($desc)\n";
	$TO = $rcpt;
	return $TO;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Deliver up the input one "line" at a time.  The intent  here  is  to  merge #
# multi-line  header  entries into a single line for processing.  It is quite #
# common for various mailers to break up long lines into multiple lines, with #
# tabs and/or spaces on the continuation lines.                               #
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
sub getline {
	$lin = $nxt;	# Advance the queue by one line.
	$nxt = <STDIN>;	# Fetch one line of input.
	$nxt =~ s/^	// if $outdent;
	if (! $lin && $nxt) {	# Do we have a next line yet?
		if ($nxt =~ /^	/) {
			$outdent = 1;	# The headers are indented.
			$nst =~ s/^	//;	# Undo the indentation.
		}
		$lin = $nxt;		# If not, advance the new line to the head.
		$nxt = <STDIN>;		# Read-ahead the second line of the file..
		$nxt =~ s/^	// if $outdent;
	}
	while ($nxt =~ /^\s/) {		# Does next line start with white space?
		chop $lin;		# Get rid of the newline.
		$lin .= $nxt;	# Join the lines.
		$nxt = <STDIN>;	# Read-ahead yet another line..
		$nxt =~ s/^	// if $outdent;
	}
	return $lin;
}
sub trim {
	local($x) = @_;
	$x =~ s/^\s*[<("]*\s*//;
	$x =~ s/\s*[;>)"]*\s*$//;
	return $x;
}