#!/usr/local/bin/perl
# send.pl - send mail with localized From address
#           by Rob Funk <funk+@osu.edu>  18 Aug 1996
#
# Currently requires sendmail.
#
# Pine (and possibly other mail programs) doesn't like to send out
# unqualified From addresses; it fully-qualifies the address instead
# of letting the MTA (e.g. sendmail) do it.  This causes a problem
# when the local machine simply cannot be qualified with a valid name.
#
# This program attempts to fix the problem by parsing the "From:"
# header just like sendmail does (with a few simplifications).  I
# literally tranlated the sendmail.cf rules into Perl code.  It
# recognizes the hostname and domain returned by the uname() system
# call, along with "localhost" and anything listed in
# /etc/sendmail.cw, as domains added my the mail program.  If one of
# these domains is found in the address, it replaces the entire from
# line with "From: username".
#
# After this program modifies the From header, sendmail is better able
# to recognize addresses in the userdb database, and do any necessary
# "mailname" replacement.
#
# To use this with Pine, install it as /usr/local/sbin/send.pl, then
# edit pine.conf or pine.conf.fixed (probably located in either
# /usr/local/lib or /usr/lib).  Find the "sendmail-path" line, and
# change the line to say "sendmail-path=/usr/local/sbin/send.pl".
#
# You may need to change the use-only-domain-name and/or the
# user-domain values in pine.conf.  When you can get Pine to always
# send with the same domain after the @, add that domain to
# /etc/sendmail.cw.
#
# My settings:
# (pine.conf)
# user-domain=
# smtp-server=
# use-only-domain-name=Yes
# sendmail-path=/usr/local/sbin/send.pl
#
# (sendmail.cw)
# homenet.ohio-state.edu

require 'syscall.ph';

$MAILER = '/usr/sbin/sendmail';
$FW = '/etc/sendmail.cw'; # same as the Fw line in sendmail.cf

# Get domain name and related info
$buf = ' ' x (65*6); syscall(&SYS_uname, $buf);
$w = substr($buf, 1*65, 65); $w =~ s/[\s\0]//g; # $w is machine name
$m = substr($buf, 5*65, 65); $m =~ s/[\s\0]//g; # $m is domain name
($m eq '(none)') && ($m = '');

$j = "$w.$m"; # $j is fully-qualified hostname
@w = ('localhost',$w,$j);
if (open(FW)) {
  push (@w, grep(/^[^\#].+$/,<FW>) );
  chomp @w;
  close FW;
}

#@P = ('.');

########################

@options = ('-t','-oem','-oi');
push (@options, @ARGV);

$pid=open(MAILER,'|-');
if (!defined($pid)) {
  # fork failed
  die "$0: Cannot open pipe to $MAILER: $!\n";
} elsif ($pid==0) {
  # child
  exec $MAILER,@options;
  die "$0: unable to exec $MAILER: $!\n";
}
select MAILER;

$header = 1;
while (<STDIN>) {
  $header=0 if /^$/;

  if ($header && /^From:\s*(.*)$/i) {
    $from = &FixFrom($1); $from =~ s/^\s*(.*)\s*$/$1/;
    print "From: $from\n";
  } else {
    print;
  }
}

close MAILER;
exit 0;

#######################################################

sub FixFrom {
  local($_) = shift;
  local($local,$smtp,$error) = (0,0,0);

  chomp;
  $_ = &S3;
  $_ = &S0;
  $_ = &S4;

  return $_;
}

sub S3 {
  # handle null input (translate to <@> special case)
  return $_ if s/^$/<\@>/; # R$@                     $@ <@>

  # strip group: syntax (not inside angle brackets!) and trailing semicolon
  s/^(.*)/$1<\@>/; # R$*	$: $1 <@>	mark addresses
  s/^(.*?)<(.*?)>(.*?)<\@>/$1<$2>$3/; # R$*<$*>$*<@>	$:$1<$2>$3	unmark <addr>
  s/^(.*?)::(.*?)<\@>/$1::$2/;# R$* :: $* <@>	$: $1 :: $2	unmark node::addr
  s/^:include:(.*?)<\@>/:include:$1/; # R:include:$*<@>	$: :include:$1	unmark :include:...
  s/^(.*?):(.*?)<\@>/$2/; # R$* : $* <@>	$: $2	strip colon if marked
  s/^(.*?)<\@>/$1/; # R$* <@>	$: $1	unmark
  s/^(.*?);/$1/; # R$* ;	$: $1	strip trailing semi

  # null input now results from list:; syntax
  return $_ if s/^$/:; <\@>/; # R$@			$@ :; <@>

  # strip angle brackets -- note RFC733 heuristic to get innermost item
  s/^(.*)/<$1>/; # R$*			$: < $1 >			housekeeping <>
  while (s/^(.+?)<(.*?)>/<$2>/) {} # R$+ < $* >		   < $2 >			strip excess on left
  while (s/^<(.*?)>(.+)/<$1>/) {} # R< $* > $+		   < $1 >			strip excess on right
  return $_ if s/^<>/<\@>/; # R<>			$@ < @ >			MAIL FROM:<> case
  s/^<(.+?)>/$1/; # R< $+ >			$: $1				remove housekeeping <>

  # make sure <@a,@b,@c:user@d> syntax is easy to parse -- undone later
  while (s/^\@(.+?),(.+)/$1:$2/) {} # R@ $+ , $+		@ $1 : $2			change all "," to ":"

  # localize and dispose of route-based addresses
  # R@ $+ : $+		$@ $>96 < @$1 > : $2		handle <route-addr>

  # find focus for list syntax
  # R $+ : $* ; @ $+	$@ $>96 $1 : $2 ; < @ $3 >	list syntax
  # R $+ : $* ;		$@ $1 : $2;			list syntax

  # find focus for @ syntax addresses
  s/^(.+?)\@(.+)/$1<\@$2>/; # R$+ @ $+		$: $1 < @ $2 >			focus on domain
  while (s/^(.+?)<(.+?)\@(.+?)>/$1$2<\@$3>/) {} # R$+ < $+ @ $+ >		$1 $2 < @ $3 >			move gaze right
  return &S96 if /^(.+?)<\@(.+?)>/; # R$+ < @ $+ >		$@ $>96 $1 < @ $2 >		already canonical

  # do some sanity checking
  while (s/^(.*?)<\@(.*?):(.*?)>(.*)/$1<\@$2$3>$4/) {} # R$* < @ $* : $* > $*	$1 < @ $2 $3 > $4		nix colons in addrs

  # convert old-style addresses to a domain-based address
  # R$- ! $+		$@ $>96 $2 < @ $1 .UUCP >	resolve uucp names
  # R$+ . $- ! $+		$@ $>96 $3 < @ $1 . $2 >		domain uucps
  # R$+ ! $+		$@ $>96 $2 < @ $1 .UUCP >	uucp subdomains

  # if we have % signs, take the rightmost one
  while (s/^(.*?)%(.*)/$1\@$2/) {} # R$* % $*		$1 @ $2				First make them all @s.
  while (s/^(.*?)\@(.*?)\@(.*)/$1%$2\@$3/) {} # R$* @ $* @ $*		$1 % $2 @ $3			Undo all but the last.
  return &S96 if s/^(.*?)\@(.*)/$1<\@$2>/;# R$* @ $*		$@ $>96 $1 < @ $2 >		Insert < > and finish

  return $_;
}

sub S96 {

  # handle special cases for local names
  s/^(.*?)<\@localhost>(.*)/$1<\@$j.>$2/; # R$* < @ localhost > $*		$: $1 < @ $j . > $2		no domain at all
  s/^(.*?)<\@localhost\.$m>(.*)/$1\@$j.>$2/; # R$* < @ localhost . $m > $*	$: $1 < @ $j . > $2		local domain
  s/^(.*?)<\@localhost\.UUCP>(.*)/$1<\@$j.>$2/; # R$* < @ localhost . UUCP > $*	$: $1 < @ $j . > $2		.UUCP domain
  s/^(.*?)<\@\[(.+?)\]>(.*)/$1<\@\@[$2]>$3/; # R$* < @ [ $+ ] > $*		$: $1 < @@ [ $2 ] > $3		mark [a.b.c.d]
  foreach $ww (@w) {s/^(.*?)<\@\@$ww>(.*)/$1<\@$j.>$3/;} # R$* < @@ $=w > $*		$: $1 < @ $j . > $3		self-literal
  return $_ if s/^(.*?)<\@\@(.+?)>(.*)/$1<\@$2>$3/; # R$* < @@ $+ > $*		$@ $1 < @ $2 > $3		canon IP addr

  # look up domains in the domain table
  #R$* < @ $+ > $* 		$: $1 < @ $(domaintable $2 $) > $3


  # if really UUCP, handle it immediately

  # try UUCP traffic as a local address
  s/^(.*?)<\@(.+?)\.UUCP>(.*)/$1<\@$2.UUCP.>$3/; # R$* < @ $+ . UUCP > $*		$: $1 < @ $[ $2 $] . UUCP . > $3
  return $_ if s/^(.*?)<\@(.+?)\.\.UUCP\.>(.*)/$1<\@$2.>$3/; # R$* < @ $+ . . UUCP . > $*		$@ $1 < @ $2 . > $3

  # (last rule, using name server, was moved from here, per Jerry Lynch -- RMF)

  # local host aliases and pseudo-domains are always canonical
  foreach $ww (@w) {s/^(.*?)<\@$ww>(.*)/$1<\@$ww.>$2/;} # R$* < @ $=w > $*		$: $1 < @ $2 . > $3
  #foreach $PP (@P) {s/^(.*?)<\@(.*?)$PP>(.*)/$1<\@$2$PP.>$3/;} # R$* < @ $* $=P > $*		$: $1 < @ $2 $3 . > $4
  while (s/^(.*?)<\@(.*?)\.\.>(.*)/$1<\@$2.>$3/) {} # R$* < @ $* . . > $*		$1 < @ $2 . > $3

  # if this is the local hostname, make sure we treat it as canonical
  s/^(.*?)<\@$j>(.*)/$1<\@$j.>$2/; # R$* < @ $j > $*			$: $1 < @ $j . > $2

  # pass to name server to make hostname canonical
  # (this rule used to be above -- RMF)
  # R$* < @ $* $~P > $*		$: $1 < @ $[ $2 $3 $] > $4

  return $_;
}

sub S4 {
  return $_ if s/(.*?)<\@>//; # R$* <@>			$@				handle <> and list:;

  # strip trailing dot off possibly canonical name
  while (s/^(.*?)<\@(.+?)\.>(.*)/$1<\@$2>$3/) {} # R$* < @ $+ . > $*	$1 < @ $2 > $3

  # externalize local domain info
  while (s/^(.*?)<(.+?)>(.*)/$1$2$3/) {} # R$* < $+ > $*		$1 $2 $3			defocus
  while (s/^\@(.+?):\@(.+?):(.+)/\@$1,\@$2:$3/) {} # R@ $+ : @ $+ : $+	@ $1 , @ $2 : $3		<route-addr> canonical
  return $_ if /^\@/; # R@ $*			$@ @ $1				... and exit

  # UUCP must always be presented in old form
  # R$+ @ $- . UUCP		$2!$1				u@h.UUCP => h!u

  # delete duplicate local names
  foreach $ww (@w) {foreach $www (@w) {s/^(.+?)%$ww\@$www/$1@$j/;}} # R$+ % $=w @ $=w		$1 @ $j				u%host@host => u@host

  return $_;
}


sub S0 {
  ($error=1 && return $_) if /^<\@>/; # R<@>			$#local $: <@>		special case error msgs
  ($error=1 && return $_) if /^(.*?):(.*?);<\@>/; # R$* : $* ; <@>		$#error $@ 5.1.3 $: "list:; syntax illegal for recipient addresses"
  ($error=1 && return $_) if /^<\@(.+?)>/; # R<@ $+>			$#error $@ 5.1.1 $: "user address required"
  ($error=1 && return $_) if /^(.*?)<(.*?):(.*?)>(.*)/; # R$* <$* : $* > $*	$#error $@ 5.1.1 $: "colon illegal in host name part"
  ($error=1 && return $_) if /^(.*?)<\@\.>(.*)/; # R$* < @ . > $*		$#error $@ 5.1.2 $: "invalid host name"

  # handle numeric address spec
  # R$* < @ [ $+ ] > $*	$: $>98 $1 < @ [ $2 ] > $3	numeric internet spec
  ($smtp=1 && return $_) if /^(.*?)<\@\[(.+?)\]>(.*)/; # R$* < @ [ $+ ] > $*	$#smtp $@ [$2] $: $1 < @ [$2] > $3	still numeric: send

  # now delete the local info -- note $=O to find characters that cause forwarding
  return &S97 if s/(.*?)<\@>(.*)/$1/; # R$* < @ > $*		$@ $>97 $1		user@ => user
  foreach $ww (@w) {return &S97 if s/^<\@$ww\.>:(.*)/$1/;} # R< @ $=w . > : $*	$@ $>97 $2		@here:... -> ...
  # R$- < @ $=w . >		$: $(dequote $1 $) < @ $2 . >	dequote "foo"@here
  foreach $ww (@w) {return &S97 if s/^(.*?)(.*?)<\@$ww\.>/$1$2@$ww/;} # R$* $=O $* < @ $=w . >	$@ $>97 $1 $2 $3		...@here -> ...

  # handle local hacks
  # R$*			$: $>98 $1

  # short circuit local delivery so forwarded email works
  # R$=L < @ $=w . >	$#local $: @ $1		special local names
  foreach $ww (@w) {($local=1 && return $_) if s/^(.+?)<\@$ww\.>/$1/;} # R$+ < @ $=w . >		$#local $: $1			regular local name

  # not local -- try mailer table lookup
  ##R$* <@ $+ > $*		$: < $2 > $1 < @ $2 > $3	extract host name
  ##R< $+ . > $*		$: < $1 > $2			strip trailing dot
  ##R< $+ > $*		$: < $(mailertable $1 $) > $2	lookup
  ##R< error : $- $+ > $*	$#error $@ $1 $: $2		check -- error?
  ##R< $- : $+ > $* 	$# $1 $@ $2 $: $3		check -- resolved?
  ##R< $+ > $*		$: $>90 <$1> $2			try domain

  # resolve remotely connected UUCP links (if any)

  # resolve fake top level domains by forwarding to other hosts

  # pass names that still have a host to a smarthost (if defined)
  # R$* < @ $* > $*		$: $>95 < $S > $1 < @ $2 > $3	glue on smarthost name

  # deal with other remote names
  ($smtp=1 && return $_) if /^(.*?)<\@(.*?)>(.*)/; # R$* < @$* > $*		$#smtp $@ $2 $: $1 < @ $2 > $3		user@host.domain

  # if this is quoted, strip the quotes and try again
  # R$+			$: $(dequote $1 $)		strip quotes
  # R$+ $=O $+		$@ $>97 $1 $2 $3			try again

  # handle locally delivered names
  # R$=L			$#local $: @ $1			special local names
  ($local=1 && return $_) if /^(.+?)/; # R$+			$#local $: $1			regular local names

  return $_;
}


sub S97 {
  $_=&S3; # R$*			$: $>3 $1
  $_=&S0; # R$*			$@ $>0 $1

  return $_;
}