#!/usr/bin/perl -s

$mail2news = 1;			# can sendmail post to newsgroups by name?

@FromHdr = (#$ENV{'HOST'} =~ /umich/)   ? () : "$ENV{'USER'}\@cs.indiana.edu",
	    ($ENV{'HOST'} =~ /indiana/) ? () : 'steve@kinzler.com',
	    ($ENV{'HOST'} =~ /kinzler/) ? () : "$ENV{'USER'}\@cs.indiana.edu",
	    'kinzler@umich.edu');
@To2From = ("(?:$ENV{'USER'}|steve)\\@[-\\w.]*");	# supplements @FromHdr
$Pwebhra = '(feedback|problems|webmaster)\@[-\w.]*hmrc\.kines\.umich\.edu';
$Pwebhra = "($Pwebhra|hra-partic\@umich\.edu)";
$Poracle = 'oracle-(admin|people|web)\@cs\.indiana\.edu';
@To2FromOnly = ($Pwebhra, $Poracle);			# replaces @FromHdr
%subFrom = ("\Q\@alamode.hmrc.kines.umich.edu" => '@www.hmrc.kines.umich.edu');
%subTo	 = ("\Qwebmaster\@carehra.ahm.com.au"  =>
				    'webmaster-ahmg@www.hmrc.kines.umich.edu');
sub Bcc { local(@a) = @FromHdr; grep(/$Pwebhra/ && s/@/-arc@/g &&
#	(s/hra-partic-arc\@umich/partic-arc\@www.hmrc.kines.umich/ || 1), @a) }
	(s/hra-partic-arc\@umich/hra-partic\@umich/		   || 1), @a) }
					#	&& s/$/, web\@umich.edu/, @a) }

#				# no ()'s allowed in the these patterns:
#$ldomain = 'cs\.indiana\.edu';	# abbreviate user@$ldomain to user
#$ddomain = '\w+\.indiana\.edu';# abbreviate user@host.$ddomain to user@host
#@hdomain = ('cs', 'moose');	# then abbreviate user@$hdomain to user
#$ldomain = 'hmrc\.kines\.umich\.edu';
#$ddomain = $ldomain;
#@hdomain = ("www\n", `hosts hmrc | sed 's/\\\..*//'`); chop @hdomain;
$ldomain = '[-\w.]*';
$ddomain = '[-\w.]*';
@hdomain = ('[-\w.]*');

$hlength = 77;			# longest acceptable header  line length
$slength = 75;			# longest acceptable subject line length

#tailer  = `boilerplate 1`;
$tailer  = '';

# box - construct reply/followup header and quote mail message or news article
# Steve Kinzler, steve@kinzler.com, Feb 94
# https://kinzler.com/me/home.html#unix

$tailu = $tailer ? ' and a tail message' : '';
$usage = "usage: $0 [ -m | -n ] [ -q ] [ file ]
	-m	construct reply header for sendmail (default)
	-n	construct followup header for inews
	-q	do not box quote the body
Output is a reply or followup header for the given mail message or news
article on input, along with a box quote of the body$tailu.
Additional messages appended on input are left as is.
Additional fields in the reply header are read from \$HEADMAIL else
\$HOME/etc/headmail, while additional followup header fields are read
from \$HEADNEWS else $HOME/etc/headnews.\n" .
(($mail2news) ?
 "Sendmail is assumed to support posting via mail to newsgroups by name
and replys to news articles include the newsgroups in the carbon copy.\n" :
 '');
$ldomain = $ddomain = '', @hdomain = ()	if $A;
print(&addrs(@ARGV), "\n"), exit	if $a || $A;
die $usage if $h || $#ARGV > 0;

$inews = $n && ! $m;
$quote = ($q) ? '' : '| ';

$input = ($#ARGV) ? '-' : $ARGV[0];
open(INPUT, "< $input") || die "$0: cannot open $input ($!)\n";

$qp	 = 0;
$ctepatt = '^Content-Transfer-Encoding:\s+';
$qppatt	 = '^quoted-printable';

$fld = '';
while (<INPUT>) {
	last if /^$/;
	$qp = $' =~ /$qppatt/i if /$ctepatt/i;
	($f, $s, $v) = /^(\S*)(\s*)(.*)/;
	if ($f ne '') {
		$fld = $f;
		$fld =~ y/A-Z/a-z/;
		$hdr{$fld} = $v;
	} else {
		$hdr{$fld} .= "\n$s$v";
	}
}

$from_   = $hdr{'from'};				  $from_ =~ s/\s.*//;
$from    = $hdr{'from:'};
$sender  = $hdr{'sender:'};
$to      = $hdr{'to:'} || $hdr{'apparently-to:'};
$to	.= ", $hdr{'resent-to:'}" if $hdr{'resent-to:'};  $to2 = $to;
$cc      = $hdr{'cc:'};
$groups  = $hdr{'newsgroups:'};
$distrib = $hdr{'distribution:'};
$return  = $hdr{'return-path:'};
$reply   = $hdr{'reply-to:'};
$follow  = $hdr{'followup-to:'};
$subject = $hdr{'subject:'};
$message = $hdr{'message-id:'};
$refs    = $hdr{'references:'};
$date    = $hdr{'date:'};
$ctype   = $hdr{'content-type:'};

# don't use a Return-Path that's probably just a BATV-tagged From address
# or a mailing list error address or a google bounce address
$return = '' if lc &addrs($return) eq lc &addrs($from)
	     || $return =~ /-errors\@|bounces\.google\.com/i;
# don't use a Reply-To that's probably just the From address
$reply  = '' if lc &addrs($reply)  eq lc &addrs($from);

foreach (@To2From) {
	($to2, $addr) = &extractaddr($to2, $_);
	push(@fromhdr, $addr) if $addr && ! grep($_ eq $addr, @fromhdr);
}
foreach (@To2FromOnly) {
	($to2, $addr) = &extractaddr($to2, $_);
	push(@onlyhdr, $addr) if $addr && ! grep($_ eq $addr, @onlyhdr);
}
if (@onlyhdr) {
	@FromHdr = (@fromhdr, @onlyhdr);
} else {
	foreach $addr (@fromhdr) {
		push(@FromHdr, $addr) if ! grep($_ eq $addr, @FromHdr);
	}
}
$to2	 =~ s/^[\s\n]*,[\s\n]*//;

$From	 =  $reply  || $from || $sender || $return || $from_;
$Groups	 =  $follow || $groups;
$Cc	 =  &subaddr(*subTo, ($to || $cc) ? $cc : ($mail2news) ? $Groups : '');
$Subject =  $subject;

$To	 =  &subaddr(*subTo, join(",\n\t", grep($_, ($From, $to2))));
$Bcc	 =  &subaddr(*subTo, join(",\n\t", &Bcc())) if defined &Bcc;
$Refs	 =  join("\n\t",  grep($_, ($refs, $message)));
$Subject =~ s/^/Re: / if $Subject && $Subject !~ /^Re:/i;

if ($inews) {
	print "Newsgroups: $Groups\n";
	print "Distribution: $distrib\n"     if $distrib;
} else {
	print 'From: ', shift @FromHdr, "\n" while @FromHdr;
	print "To: $To\n";
	print "Cc: $Cc\n"		     if $Cc;
	print "Bcc: $Bcc\n"		     if $Bcc;
}
print "Subject: $Subject\n";
print "References: $Refs\n" if $Refs;

$head = ($inews) ? $ENV{'HEADNEWS'} || "$ENV{'HOME'}/etc/headnews"
		 : $ENV{'HEADMAIL'} || "$ENV{'HOME'}/etc/headmail";
if (open(HEAD, "< $head")) {
	while (<HEAD>) { print; }
}
print "\n";

unless ($q) {
	$date =  &oneline($date);
	$date =~ s/'/'\\''/g;
	if ($date ne '' && ($date = `getdate '$date'`) ne '') {
		%mon = (0, 'Jan', 1, 'Feb',  2, 'Mar',  3, 'Apr',
			4, 'May', 5, 'Jun',  6, 'Jul',  7, 'Aug',
			8, 'Sep', 9, 'Oct', 10, 'Nov', 11, 'Dec');
		@date = localtime($date);
		$date = " $date[3]$mon{$date[4]}" .
			sprintf('%02d', $date[5] % 100);
	}

	$from = &addrs($from)   || &addrs($sender) || &addrs($from_) ||
		&addrs($return) || &addrs($reply)  || 'UNKNOWN';

	$to  = &addrs($to);
	$cc  = &addrs($cc);
	$to .= ";$cc" if $cc;
	$to  = &addrs($groups) || &addrs($follow) || 'UNKNOWN' unless $to;

	$sentline = "Sent$date from $from to $to";
	$sentline =~ s/(from \S*)/$1\n/ if length($sentline) > $hlength;

	$_ = &oneline($subject);
	s/\t/ /g; s/^\s*//; s/\s*$//;
	$_ = (/./) ? "+---------- $_ ----------" : '+----------';
	1 while length($_) > $slength && s/^\+---(.*)---$/+--$1--/;
	$subjectline = $_;

	print "$sentline\n";
	print "$subjectline\n";
}

if (($bndry = $ctype) =~ s/.*boundary="([^"]*)".*/$1/s) {
	while (<INPUT>) {
		last if /^--\Q$bndry/o;
	}
	$bndrye = 1;
} else {$bndrye = 0; }

$txt = 0;
LOOP:
while (<INPUT>) {
	last if /^From /;
	$qp = $' =~ /$qppatt/i if /$ctepatt/i;
	next if $bndrye && ! $txt
	     && /^(Content-[-\w]+:\s|\t(charset|boundary)=")/i;
	print($tailer ? "$tailer\n" : ''), $tailer = ''
	     if $bndrye && /^--\Q$bndry/;
	s/[ \t]*$//;
	if ($qp) {
		s/=\r?\n//g && do {
			$_ .= <INPUT>; redo LOOP;
		};
		s/=([\da-fA-F]{2})/pack('C', hex($1))/ge;
		s/[ \t]*$//;
	}
	print("$quote$_"), $txt++, next if /\S/;
	print if $txt;
	while (<INPUT>) {
		redo LOOP if /\S/;
	}
}
print $tailer || '', ($tailer && $_) ? "\n" : '', $_;

while (<INPUT>) { print; }
close INPUT;

## Subroutines ################################################################

sub extractaddr {
	local($_, $patt) = @_;
#	s/(,[\s\n]*)?($patt|("[^"]*"[\s\n]*)?<$patt>)//i;
	s/(,[\s\n]*)?($patt|("[^"]*"|[^,<]*)[\s\n]*<$patt>)//i;
	local($addr) = &subaddr(*subFrom, $2);
	$addr =~ s/^<(.*)>$/$1/ if $addr =~ /^<.*>$/;
	$addr =~ s/^\s*["']+(.*)["']+\s*<\1>/$1/s;
	($_, $addr);
}

sub subaddr {
	local(*a) = shift;
	local($f) = join(', ', @_);
	foreach (keys %a) { $f =~ s/$_/$a{$_}/gis }
	$f;
}

sub oneline {
	local($_) = join(' ', @_);
	s/\n\s*/ /g;
	$_;
}

sub addrs {
	local($_) = join(',', @_);
	s/\n\s*/ /g;

	1 while s/(<[^>]*>)([^,]*<[^>]*>)/$1,$2/;	# heuristic
	s/[^,]*<([^>]*)>[^,]*/$1/g;
	s/(^|,)\s+/$1/g;
	s/\s[^,]*//g;

	s/[^,]*['\(\)<>][^,]*//;
	1 while s/(^|,)[^",]*"[^",]*(,|$)/$1/;

	s/,+/,/g;
	s/^,//;
	s/,$//;

	1 while s/(^|,)([^,:]+)[@%]$ldomain(,|$)/$1$2$3/i;
	1 while s/(^|,)([^,:]+[@%])(\w+)\.$ddomain(,|$)/$1$2$3$4/i;
	foreach $hdomain (@hdomain) {
		1 while s/(^|,)([^,:]+)[@%]$hdomain(,|$)/$1$2$3/i;
	}

	1 while s/(^|,)$ldomain!([^,@%]+)(,|$)/$1$2$3/i;
	1 while s/(^|,)(\w+)\.$ddomain(![^,@%]+)(,|$)/$1$2$3$4/i;
	foreach $hdomain (@hdomain) {
		1 while s/(^|,)$hdomain!([^,@%]+)(,|$)/$1$2$3/i;
	}

	s/(^|,)prvs=[\da-fA-F]*=/$1/g;	# strip out BATV tags

	$_;
}