expn.pl

早期freebsd实现

#
# This routine is used only within &giveup.  It checks to
# see if we really have to giveup or if there is a second
# chance because we did something before that can be 
# backtracked.
#
# %fallback{"$user *** $host"} tracks what is able to fallback
# %fellback{"$user *** $host"} tracks what has fallen back
#
# If there is a valid backtrack, then queue up the new possibility
#
sub try_fallback
{
	local($method,$user,*host,*fall_table,*fellback) = @_;
	local($us,$fallhost,$oldhost,$ft,$i);

	if ($debug > 8) {
		print "Fallback table $method:\n";
		for $i (sort keys %fall_table) {
			print "\t'$i'\t\t'$fall_table{$i}'\n";
		}
		print "Fellback table $method:\n";
		for $i (sort keys %fellback) {
			print "\t'$i'\t\t'$fellback{$i}'\n";
		}
		print "U: $user H: $host\n";
	}
	
	$us = "$user *** $host";
	if (defined $fellback{$us}) {
		#
		# Undo a previous fallback so that we can try again
		# Nest fallbacks are avoided because they could
		# lead to infinite loops
		#
		$fallhost = $fellback{$us};
		print "Already $method fell back from $us -> \n" if $debug;
		$us = "$user *** $fallhost";
		$oldhost = $fallhost;
	} elsif (($method eq 'mx') && (defined $mxbacktrace{$us}) && (defined $mx_secondary{$mxbacktrace{$us}})) {
		print "Fallback an MX expansion $us -> \n" if $debug;
		$oldhost = $mxbacktrace{$us};
	} else {
		print "Oldhost($host, $us) = " if $debug;
		$oldhost = $host;
	}
	print "$oldhost\n" if $debug;
	if (((defined $fall_table{$us}) && ($ft = $us)) || ((defined $fall_table{$oldhost}) && ($ft = $oldhost))) {
		print "$method Fallback = ".$fall_table{$ft}."\n" if $debug;
		local(@so,$newhost);
		@so = split(' ',$fall_table{$ft});
		$newhost = shift(@so);
		print "Falling back ($method) $us -> $newhost (from $oldhost)\n" if $debug;
		if ($method eq 'mx') {
			if (! defined ($mxbacktrace{"$user *** $newhost"})) {
				if (defined $mxbacktrace{"$user *** $oldhost"}) {
					print "resetting oldhost $oldhost to the original: " if $debug;
					$oldhost = $mxbacktrace{"$user *** $oldhost"};
					print "$oldhost\n" if $debug;
				}
				$mxbacktrace{"$user *** $newhost"} = $oldhost;
				print "mxbacktrace $user *** $newhost -> $oldhost\n" if $debug;
			}
			$mx{&trhost($oldhost)} = $newhost;
		} else {
			$temporary_redirect{$us} = $newhost;
		}
		if (@so) {
			print "Can still $method  $us: @so\n" if $debug;
			$fall_table{$ft} = join(' ',@so);
		} else {
			print "No more fallbacks for $us\n" if $debug;
			delete $fall_table{$ft};
		}
		if (defined $create_host_backtrack{$us}) {
			$create_host_backtrack{"$user *** $newhost"} 
				= $create_host_backtrack{$us};
		}
		$fellback{"$user *** $newhost"} = $oldhost;
		&expn($newhost,$user,$names{$us},$level{$us});
		return 1;
	}
	delete $temporary_redirect{$us};
	$host = $oldhost;
	return 0;
}
# return 1 if you could send mail to the address as is.
sub validAddr
{
	local($addr) = @_;
	$res = &do_validAddr($addr);
	print "validAddr($addr) = $res\n" if $debug;
	$res;
}
sub do_validAddr
{
	local($addr) = @_;
	local($urx) = "[-A-Za-z_.0-9+]+";

	# \u
	return 0 if ($addr =~ /^\\/);
	# ?@h
	return 1 if ($addr =~ /.\@$urx$/);
	# @h:?
	return 1 if ($addr =~ /^\@$urx\:./);
	# h!u
	return 1 if ($addr =~ /^$urx!./);
	# u
	return 1 if ($addr =~ /^$urx$/);
	# ?
	print "validAddr($addr) = ???\n" if $debug;
	return 0;
}
# Some systems use expn and vrfy interchangeably.  Some only
# implement one or the other.  Some check expn against mailing
# lists and vrfy against users.  It doesn't appear to be
# consistent.
#
# So, what do we do?  We try everything!
#
#
# Ranking of result codes: good: 250, 251/551, 252, 550, anything else
#
# Ranking of inputs: best: [e-mail], okay: user
#
# Return value: $error_string, @responces_from_server
sub expn_vrfy
{
	local($u,$server) = @_;
	local(@c) = ('expn', 'vrfy');
	local(@try_u) = $u;
	local(@ret,$code);

	if (($u =~ /(.+)@(.+)/) && (&trhost($2) eq &trhost($server))) {
		push(@try_u,$1);
	}

	TRY:
	for $c (@c) {
		for $try_u (@try_u) {
			&alarm("$c'ing $try_u on $server",'',$u);
			&ps("$c $try_u");
			alarm(0);
			$s = <S>;
			if ($s eq '') {
				return "$server: lost connection";
			}
			if ($s !~ /^(\d+)([- ])/) {
				return "$server: garbled reply to '$c $try_u'";
			}
			if ($1 == 250) {
				$code = 250;
				@ret = ("",$s);
				push(@ret,&read_response($2,$debug));
				return @ret;
			} 
			if ($1 == 551 || $1 == 251) {
				$code = $1;
				@ret = ("",$s);
				push(@ret,&read_response($2,$debug));
				next;
			}
			if ($1 == 252 && ($code == 0 || $code == 550)) {
				$code = 252;
				@ret = ("",$s);
				push(@ret,&read_response($2,$watch));
				next;
			}
			if ($1 == 550 && $code == 0) {
				$code = 550;
				@ret = ("",$s);
				push(@ret,&read_response($2,$watch));
				next;
			}
			&read_response($2,$watch);
		}
	}
	return "$server: expn/vrfy not implemented" unless @ret;
	return @ret;
}
# sometimes the old parse routine (now parse2) didn't
# reject funky addresses. 
sub parse
{
	local($oldaddr,$server,$oldname,$one_to_one) = @_;
	local($newhost, $newaddr, $newname, $um) =  &parse2($oldaddr,$server,$oldname,$one_to_one);
	if ($newaddr =~ m,^["/],) {
		return (undef, $oldaddr, $newname) if $valid;
		return (undef, $um, $newname);
	}
	return ($newhost, $newaddr, $newname);
}

# returns ($new_smtp_server,$new_address,$new_name)
# given a responce from a SMTP server ($newaddr), the 
# current host ($server), the old "name" and a flag that
# indicates if it is being called during the initial 
# command line parsing ($parsing_args)
sub parse2
{
	local($newaddr,$context_host,$old_name,$parsing_args) = @_;
	local(@names) = $old_name;
	local($urx) = "[-A-Za-z_.0-9+]+";
	local($unmangle);

	#
	# first, separate out the address part.
	#

	#
	# [NAME] <ADDR [(NAME)]>
	# [NAME] <[(NAME)] ADDR
	# ADDR [(NAME)]
	# (NAME) ADDR
	# [(NAME)] <ADDR>
	#
	if ($newaddr =~ /^\<(.*)\>$/) {
		print "<A:$1>\n" if $debug;
		$newaddr = &trim($1);
		print "na = $newaddr\n" if $debug;
	}
	if ($newaddr =~ /^([^\<\>]*)\<([^\<\>]*)\>([^\<\>]*)$/) {
		# address has a < > pair in it.
		print "N:$1 <A:$2> N:$3\n" if $debug;
		$newaddr = &trim($2);
		unshift(@names, &trim($3,$1));
		print "na = $newaddr\n" if $debug;
	}
	if ($newaddr =~ /^([^\(\)]*)\(([^\(\)]*)\)([^\(\)]*)$/) {
		# address has a ( ) pair in it.
		print "A:$1 (N:$2) A:$3\n" if $debug;
		unshift(@names,&trim($2));
		local($f,$l) = (&trim($1),&trim($3));
		if (($f && $l) || !($f || $l)) {
			# address looks like:
			# foo (bar) baz  or (bar)
			# not allowed!
			print STDERR "Could not parse $newaddr\n" if $vw;
			return(undef,$newaddr,&firstname(@names));
		}
		$newaddr = $f if $f;
		$newaddr = $l if $l;
		print "newaddr now = $newaddr\n" if $debug;
	}
	#
	# @foo:bar
	# j%k@l
	# a@b
	# b!a
	# a
	#
	$unmangle = $newaddr;
	if ($newaddr =~ /^\@($urx)\:(.+)$/) {
		print "(\@:)" if $debug;
		# this is a bit of a cheat, but it seems necessary
		return (&domainify($1,$context_host,$2),$2,&firstname(@names),$unmangle);
	}
	if ($newaddr =~ /^(.+)\@($urx)$/) {
		print "(\@)" if $debug;
		return (&domainify($2,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
	}
	if ($parsing_args) {
		if ($newaddr =~ /^($urx)\!(.+)$/) {
			return (&domainify($1,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
		}
		if ($newaddr =~ /^($urx)$/) {
			return ($context_host,$newaddr,&firstname(@names),$unmangle);
		}
		print STDERR "Could not parse $newaddr\n";
	}
	print "(?)" if $debug;
	return(undef,$newaddr,&firstname(@names),$unmangle);
}
# return $u (@$server) unless $u includes reference to $server
sub compact
{
	local($u, $server) = @_;
	local($se) = $server;
	local($sp);
	$se =~ s/(\W)/\\$1/g;
	$sp = " (\@$server)";
	if ($u !~ /$se/i) {
		return "$u$sp";
	}
	return $u;
}
# remove empty (spaces don't count) members from an array
sub trim
{
	local(@v) = @_;
	local($v,@r);
	for $v (@v) {
		$v =~ s/^\s+//;
		$v =~ s/\s+$//;
		push(@r,$v) if ($v =~ /\S/);
	}
	return(@r);
}
# using the host part of an address, and the server name, add the
# servers' domain to the address if it doesn't already have a 
# domain.  Since this sometimes failes, save a back reference so
# it can be unrolled.
sub domainify
{
	local($host,$domain_host,$u) = @_;
	local($domain,$newhost);

	# cut of trailing dots 
	$host =~ s/\.$//;
	$domain_host =~ s/\.$//;

	if ($domain_host !~ /\./) {
		#
		# domain host isn't, keep $host whatever it is
		#
		print "domainify($host,$domain_host) = $host\n" if $debug;
		return $host;
	}

	# 
	# There are several weird situtations that need to be 
	# accounted for.  They have to do with domain relay hosts.
	#
	# Examples: 
	#	host		server		"right answer"
	#	
	#	shiva.cs	cs.berkeley.edu	shiva.cs.berkeley.edu
	#	shiva		cs.berkeley.edu	shiva.cs.berekley.edu
	#	cumulus		reed.edu	@reed.edu:cumulus.uucp
	# 	tiberius	tc.cornell.edu	tiberius.tc.cornell.edu
	#
	# The first try must always be to cut the domain part out of 
	# the server and tack it onto the host.
	#
	# A reasonable second try is to tack the whole server part onto
	# the host and for each possible repeated element, eliminate 
	# just that part.
	#
	# These extra "guesses" get put into the %domainify_fallback
	# array.  They will be used to give addresses a second chance
	# in the &giveup routine
	#

	local(%fallback);

	local($long); 
	$long = "$host $domain_host";
	$long =~ tr/A-Z/a-z/;
	print "long = $long\n" if $debug;
	if ($long =~ s/^([^ ]+\.)([^ ]+) \2(\.[^ ]+\.[^ ]+)/$1$2$3/) {
		# matches shiva.cs cs.berkeley.edu and returns shiva.cs.berkeley.edu
		print "condensed fallback $host $domain_host -> $long\n" if $debug;
		$fallback{$long} = 9;
	}

	local($fh);
	$fh = $domain_host;
	while ($fh =~ /\./) {
		print "FALLBACK $host.$fh = 1\n" if $debug > 7;
		$fallback{"$host.$fh"} = 1;
		$fh =~ s/^[^\.]+\.//;
	}

	$fallback{"$host.$domain_host"} = 2;

	($domain = $domain_host) =~ s/^[^\.]+//;
	$fallback{"$host$domain"} = 6
		if ($domain =~ /\./);

	if ($host =~ /\./) {
		#
		# Host is already okay, but let's look for multiple
		# interpretations
		#
		print "domainify($host,$domain_host) = $host\n" if $debug;
		delete $fallback{$host};
		$domainify_fallback{"$u *** $host"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
		return $host;
	}

	$domain = ".$domain_host"
		if ($domain !~ /\..*\./);
	$newhost = "$host$domain";

	$create_host_backtrack{"$u *** $newhost"} = $domain_host;
	print "domainify($host,$domain_host) = $newhost\n" if $debug;
	delete $fallback{$newhost};
	$domainify_fallback{"$u *** $newhost"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
	if ($debug) {
		print "fallback = ";
		print $domainify_fallback{"$u *** $newhost"} 
			if defined($domainify_fallback{"$u *** $newhost"});
		print "\n";
	}
	return $newhost;
}
# return the first non-empty element of an array
sub firstname
{
	local(@names) = @_;
	local($n);
	while(@names) {
		$n = shift(@names);
		return $n if $n =~ /\S/;
	}
	return undef;
}
# queue up more addresses to expand
sub expn
{
	local($host,$addr,$name,$level) = @_;
	if ($host) {
		$host = &trhost($host);

		if (($debug > 3) || (defined $giveup{$host})) {
			unshift(@hosts,$host) unless $users{$host};
		} else {
			push(@hosts,$host) unless $users{$host};
		}
		$users{$host} .= " $addr";
		$names{"$addr *** $host"} = $name;
		$level{"$addr *** $host"} = $level + 1;
		print "expn($host,$addr,$name)\n" if $debug;
		return "\t$addr\n";
	} else {
		return &final($addr,'NONE',$name);
	}
}
# compute the numerical average value of an array
sub average
{
	local(@e) = @_;
	return 0 unless @e;
	local($e,$sum);
	for $e (@e) {
		$sum += $e;
	}
	$sum / @e;
}
# print to the server (also to stdout, if -w)
sub ps
{
	local($p) = @_;
	print ">>> $p\n" if $watch;
	print S "$p\n";
}
# return case-adjusted name for a host (for comparison purposes)
sub trhost 
{
	# treat foo.bar as an alias for Foo.BAR
	local($host) = @_;
	local($trhost) = $host;
	$trhost =~ tr/A-Z/a-z/;
	if ($trhost{$trhost}) {
		$host = $trhost{$trhost};
	} else {