138494Sobrien#!@PERL@ 238494Sobrien'di '; 338494Sobrien'ds 00 \\"'; 438494Sobrien'ig 00 '; 538494Sobrien# 638494Sobrien# THIS PROGRAM IS ITS OWN MANUAL PAGE. INSTALL IN man & bin. 738494Sobrien# 838494Sobrien 938494Sobrien# hardcoded constants, should work fine for BSD-based systems 1038494Sobrien#require 'sys/socket.ph'; # perl 4 1138494Sobrienuse Socket; # perl 5 1238494Sobrien$AF_INET = &AF_INET; 1338494Sobrien$SOCK_STREAM = &SOCK_STREAM; 1438494Sobrien$sockaddr = 'S n a4 x8'; 1538494Sobrien 1638494Sobrien# system requirements: 1738494Sobrien# must have 'nslookup' and 'hostname' programs. 1838494Sobrien 19174294Sobrien# $Header: /home/cvsroot/am-utils/scripts/expn.1,v 1.4 2003/07/18 15:17:37 ezk Exp $ 2038494Sobrien 2138494Sobrien# TODO: 2238494Sobrien# less magic should apply to command-line addresses 2338494Sobrien# less magic should apply to local addresses 2438494Sobrien# add magic to deal with cross-domain cnames 2538494Sobrien 2638494Sobrien# Checklist: (hard addresses) 2738494Sobrien# 250 Kimmo Suominen <"|/usr/local/mh/lib/slocal -user kim"@grendel.tac.nyc.ny.us> 2838494Sobrien# harry@hofmann.cs.Berkeley.EDU -> harry@tenet (.berkeley.edu) [dead] 2938494Sobrien# bks@cs.berkeley.edu -> shiva.CS (.berkeley.edu) [dead] 3038494Sobrien# dan@tc.cornell.edu -> brown@tiberius (.tc.cornell.edu) 3138494Sobrien 3238494Sobrien############################################################################# 3338494Sobrien# 3438494Sobrien# Copyright (c) 1993 David Muir Sharnoff 3538494Sobrien# All rights reserved. 3638494Sobrien# 3738494Sobrien# Redistribution and use in source and binary forms, with or without 3838494Sobrien# modification, are permitted provided that the following conditions 3938494Sobrien# are met: 4038494Sobrien# 1. Redistributions of source code must retain the above copyright 4138494Sobrien# notice, this list of conditions and the following disclaimer. 4238494Sobrien# 2. Redistributions in binary form must reproduce the above copyright 4338494Sobrien# notice, this list of conditions and the following disclaimer in the 4438494Sobrien# documentation and/or other materials provided with the distribution. 4538494Sobrien# 3. All advertising materials mentioning features or use of this software 46119679Smbr# must display the following acknowledgment: 4738494Sobrien# This product includes software developed by the David Muir Sharnoff. 4838494Sobrien# 4. The name of David Sharnoff may not be used to endorse or promote products 4938494Sobrien# derived from this software without specific prior written permission. 5038494Sobrien# 5138494Sobrien# THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND 5238494Sobrien# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 5338494Sobrien# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 5438494Sobrien# ARE DISCLAIMED. IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE 5538494Sobrien# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 5638494Sobrien# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 5738494Sobrien# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 5838494Sobrien# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 5938494Sobrien# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 6038494Sobrien# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 6138494Sobrien# SUCH DAMAGE. 6238494Sobrien# 63119679Smbr# This copyright notice derived from material copyrighted by the Regents 6438494Sobrien# of the University of California. 6538494Sobrien# 6638494Sobrien# Contributions accepted. 6738494Sobrien# 6838494Sobrien############################################################################# 6938494Sobrien 7038494Sobrien# overall structure: 7138494Sobrien# in an effort to not trace each address individually, but rather 7238494Sobrien# ask each server in turn a whole bunch of questions, addresses to 7338494Sobrien# be expanded are queued up. 7438494Sobrien# 7538494Sobrien# This means that all accounting w.r.t. an address must be stored in 7638494Sobrien# various arrays. Generally these arrays are indexed by the 7738494Sobrien# string "$addr *** $server" where $addr is the address to be 7838494Sobrien# expanded "foo" or maybe "foo@bar" and $server is the hostname 7938494Sobrien# of the SMTP server to contact. 8038494Sobrien# 8138494Sobrien 8238494Sobrien# important global variables: 8338494Sobrien# 8438494Sobrien# @hosts : list of servers still to be contacted 8538494Sobrien# $server : name of the current we are currently looking at 8638494Sobrien# @users = $users{@hosts[0]} : addresses to expand at this server 8738494Sobrien# $u = $users[0] : the current address being expanded 8838494Sobrien# $names{"$users[0] *** $server"} : the 'name' associated with the address 8938494Sobrien# $mxbacktrace{"$users[0] *** $server"} : record of mx expansion 9038494Sobrien# $mx_secondary{$server} : other mx relays at the same priority 91119679Smbr# $domainify_fallback{"$users[0] *** $server"} : alternative names to try 9238494Sobrien# instead of $server if $server doesn't work 9338494Sobrien# $temporary_redirect{"$users[0] *** $server"} : when trying alternates, 9438494Sobrien# temporarily channel all tries along current path 9538494Sobrien# $giveup{$server} : do not bother expanding addresses at $server 9638494Sobrien# $verbose : -v 9738494Sobrien# $watch : -w 9838494Sobrien# $vw : -v or -w 9938494Sobrien# $debug : -d 10038494Sobrien# $valid : -a 10138494Sobrien# $levels : -1 10238494Sobrien# S : the socket connection to $server 10338494Sobrien 10438494Sobrien$have_nslookup = 1; # we have the nslookup program 10538494Sobrien$port = 'smtp'; 10638494Sobrien$av0 = $0; 10738494Sobrien$ENV{'PATH'} .= ":/usr/etc" unless $ENV{'PATH'} =~ m,/usr/etc,; 10838494Sobrien$ENV{'PATH'} .= ":/usr/ucb" unless $ENV{'PATH'} =~ m,/usr/ucb,; 10938494Sobrienselect(STDERR); 11038494Sobrien 11138494Sobrien$0 = "$av0 - running hostname"; 11238494Sobrienchop($name = `hostname || uname -n`); 11338494Sobrien 11438494Sobrien$0 = "$av0 - lookup host FQDN and IP addr"; 11538494Sobrien($hostname,$aliases,$type,$len,$thisaddr) = gethostbyname($name); 11638494Sobrien 11738494Sobrien$0 = "$av0 - parsing args"; 11838494Sobrien$usage = "Usage: $av0 [-1avwd] user[\@host] [user2[host2] ...]"; 11938494Sobrienfor $a (@ARGV) { 12038494Sobrien die $usage if $a eq "-"; 12138494Sobrien while ($a =~ s/^(-.*)([1avwd])/$1/) { 12238494Sobrien eval '$'."flag_$2 += 1"; 12338494Sobrien } 12438494Sobrien next if $a eq "-"; 12538494Sobrien die $usage if $a =~ /^-/; 12638494Sobrien &expn(&parse($a,$hostname,undef,1)); 12738494Sobrien} 12838494Sobrien$verbose = $flag_v; 12938494Sobrien$watch = $flag_w; 13038494Sobrien$vw = $flag_v + $flag_w; 13138494Sobrien$debug = $flag_d; 13238494Sobrien$valid = $flag_a; 13338494Sobrien$levels = $flag_1; 13438494Sobrien 13538494Sobriendie $usage unless @hosts; 13638494Sobrienif ($valid) { 13738494Sobrien if ($valid == 1) { 13838494Sobrien $validRequirement = 0.8; 13938494Sobrien } elsif ($valid == 2) { 14038494Sobrien $validRequirement = 1.0; 14138494Sobrien } elsif ($valid == 3) { 14238494Sobrien $validRequirement = 0.9; 14338494Sobrien } else { 14438494Sobrien $validRequirement = (1 - (1/($valid-3))); 14538494Sobrien print "validRequirement = $validRequirement\n" if $debug; 14638494Sobrien } 14738494Sobrien} 14838494Sobrien 14938494Sobrien$0 = "$av0 - building local socket"; 15038494Sobrien($name,$aliases,$proto) = getprotobyname('tcp'); 15138494Sobrien($name,$aliases,$port) = getservbyname($port,'tcp') 15238494Sobrien unless $port =~ /^\d+/; 15338494Sobrien$this = pack($sockaddr, &AF_INET, 0, $thisaddr); 15438494Sobrien 15538494SobrienHOST: 15638494Sobrienwhile (@hosts) { 15738494Sobrien $server = shift(@hosts); 15838494Sobrien @users = split(' ',$users{$server}); 15938494Sobrien delete $users{$server}; 16038494Sobrien 16138494Sobrien # is this server already known to be bad? 16238494Sobrien $0 = "$av0 - looking up $server"; 16338494Sobrien if ($giveup{$server}) { 16438494Sobrien &giveup('mx domainify',$giveup{$server}); 16538494Sobrien next; 16638494Sobrien } 16738494Sobrien 16838494Sobrien # do we already have an mx record for this host? 16938494Sobrien next HOST if &mxredirect($server,*users); 17038494Sobrien 17138494Sobrien # look it up, or try for an mx. 17238494Sobrien $0 = "$av0 - gethostbyname($server)"; 17338494Sobrien 17438494Sobrien ($name,$aliases,$type,$len,$thataddr) = gethostbyname($server); 17538494Sobrien # if we can't get an A record, try for an MX record. 17638494Sobrien unless($thataddr) { 17738494Sobrien &mxlookup(1,$server,"$server: could not resolve name",*users); 17838494Sobrien next HOST; 17938494Sobrien } 180119679Smbr 18138494Sobrien # get a connection, or look for an mx 18238494Sobrien $0 = "$av0 - socket to $server"; 18338494Sobrien $that = pack($sockaddr, &AF_INET, $port, $thataddr); 18438494Sobrien socket(S, &AF_INET, &SOCK_STREAM, $proto) 18538494Sobrien || die "socket: $!"; 18638494Sobrien $0 = "$av0 - bind to $server"; 187119679Smbr bind(S, $this) 18838494Sobrien || die "bind $hostname,0: $!"; 18938494Sobrien $0 = "$av0 - connect to $server"; 19038494Sobrien print "debug = $debug server = $server\n" if $debug > 8; 19138494Sobrien if (! connect(S, $that) || ($debug == 10 && $server =~ /relay\d.UU.NET$/i)) { 19238494Sobrien $0 = "$av0 - $server: could not connect: $!\n"; 19338494Sobrien $emsg = $!; 19438494Sobrien unless (&mxlookup(0,$server,"$server: could not connect: $!",*users)) { 19538494Sobrien &giveup('mx',"$server: Could not connect: $emsg"); 19638494Sobrien } 19738494Sobrien next HOST; 19838494Sobrien } 19938494Sobrien select((select(S),$| = 1)[0]); # don't buffer output to S 20038494Sobrien 20138494Sobrien # read the greeting 20238494Sobrien $0 = "$av0 - talking to $server"; 20338494Sobrien &alarm("greeting with $server",''); 20438494Sobrien while(<S>) { 20538494Sobrien alarm(0); 20638494Sobrien print if $watch; 20738494Sobrien if (/^(\d+)([- ])/) { 20838494Sobrien if ($1 != 220) { 20938494Sobrien $0 = "$av0 - bad numeric response from $server"; 21038494Sobrien &alarm("giving up after bad response from $server",''); 21138494Sobrien &read_response($2,$watch); 21238494Sobrien alarm(0); 21338494Sobrien print STDERR "$server: NOT 220 greeting: $_" 21438494Sobrien if ($debug || $vw); 21538494Sobrien if (&mxlookup(0,$server,"$server: did not respond with a 220 greeting",*users)) { 21638494Sobrien close(S); 21738494Sobrien next HOST; 21838494Sobrien } 21938494Sobrien } 22038494Sobrien last if ($2 eq " "); 22138494Sobrien } else { 22238494Sobrien $0 = "$av0 - bad response from $server"; 22338494Sobrien print STDERR "$server: NOT 220 greeting: $_" 22438494Sobrien if ($debug || $vw); 22538494Sobrien unless (&mxlookup(0,$server,"$server: did not respond with SMTP codes",*users)) { 22638494Sobrien &giveup('',"$server: did not talk SMTP"); 22738494Sobrien } 22838494Sobrien close(S); 22938494Sobrien next HOST; 23038494Sobrien } 23138494Sobrien &alarm("greeting with $server",''); 23238494Sobrien } 23338494Sobrien alarm(0); 234119679Smbr 23538494Sobrien # if this causes problems, remove it 23638494Sobrien $0 = "$av0 - sending helo to $server"; 23738494Sobrien &alarm("sending helo to $server",""); 23838494Sobrien &ps("helo $hostname"); 23938494Sobrien while(<S>) { 24038494Sobrien print if $watch; 24138494Sobrien last if /^\d+ /; 24238494Sobrien } 24338494Sobrien alarm(0); 24438494Sobrien 24538494Sobrien # try the users, one by one 24638494Sobrien USER: 24738494Sobrien while(@users) { 24838494Sobrien $u = shift(@users); 24938494Sobrien $0 = "$av0 - expanding $u [\@$server]"; 25038494Sobrien 25138494Sobrien # do we already have a name for this user? 25238494Sobrien $oldname = $names{"$u *** $server"}; 25338494Sobrien 25438494Sobrien print &compact($u,$server)." ->\n" if ($verbose && ! $valid); 25538494Sobrien if ($valid) { 25638494Sobrien # 257119679Smbr # when running with -a, we delay taking any action 25838494Sobrien # on the results of our query until we have looked 25938494Sobrien # at the complete output. @toFinal stores expansions 26038494Sobrien # that will be final if we take them. @toExpn stores 261119679Smbr # expansions that are not final. @isValid keeps 26238494Sobrien # track of our ability to send mail to each of the 26338494Sobrien # expansions. 26438494Sobrien # 26538494Sobrien @isValid = (); 26638494Sobrien @toFinal = (); 26738494Sobrien @toExpn = (); 26838494Sobrien } 26938494Sobrien 27038494Sobrien# ($ecode,@expansion) = &expn_vrfy($u,$server); 27138494Sobrien (@foo) = &expn_vrfy($u,$server); 27238494Sobrien ($ecode,@expansion) = @foo; 27338494Sobrien if ($ecode) { 27438494Sobrien &giveup('',$ecode,$u); 27538494Sobrien last USER; 27638494Sobrien } 27738494Sobrien 27838494Sobrien for $s (@expansion) { 27938494Sobrien $s =~ s/[\n\r]//g; 28038494Sobrien $0 = "$av0 - parsing $server: $s"; 28138494Sobrien 28238494Sobrien $skipwatch = $watch; 28338494Sobrien 28438494Sobrien if ($s =~ /^[25]51([- ]).*<(.+)>/) { 28538494Sobrien print "$s" if $watch; 28638494Sobrien print "(pretending 250$1<$2>)" if ($debug && $watch); 28738494Sobrien print "\n" if $watch; 28838494Sobrien $s = "250$1<$2>"; 28938494Sobrien $skipwatch = 0; 29038494Sobrien } 29138494Sobrien 29238494Sobrien if ($s =~ /^250([- ])(.+)/) { 29338494Sobrien print "$s\n" if $skipwatch; 29438494Sobrien ($done,$addr) = ($1,$2); 29538494Sobrien ($newhost, $newaddr, $newname) = &parse($addr,$server,$oldname, $#expansion == 0); 29638494Sobrien print "($newhost, $newaddr, $newname) = &parse($addr, $server, $oldname)\n" if $debug; 29738494Sobrien if (! $newhost) { 29838494Sobrien # no expansion is possible w/o a new server to call 29938494Sobrien if ($valid) { 30038494Sobrien push(@isValid, &validAddr($newaddr)); 30138494Sobrien push(@toFinal,$newaddr,$server,$newname); 30238494Sobrien } else { 30338494Sobrien &verbose(&final($newaddr,$server,$newname)); 30438494Sobrien } 30538494Sobrien } else { 30638494Sobrien $newmxhost = &mx($newhost,$newaddr); 307119679Smbr print "$newmxhost = &mx($newhost)\n" 30838494Sobrien if ($debug && $newhost ne $newmxhost); 30938494Sobrien $0 = "$av0 - parsing $newaddr [@$newmxhost]"; 31038494Sobrien print "levels = $levels, level{$u *** $server} = ".$level{"$u *** $server"}."\n" if ($debug > 1); 311119679Smbr # If the new server is the current one, 31238494Sobrien # it would have expanded things for us 31338494Sobrien # if it could have. Mx records must be 31438494Sobrien # followed to compare server names. 31538494Sobrien # We are also done if the recursion 31638494Sobrien # count has been exceeded. 31738494Sobrien if (&trhost($newmxhost) eq &trhost($server) || ($levels && $level{"$u *** $server"} >= $levels)) { 31838494Sobrien if ($valid) { 31938494Sobrien push(@isValid, &validAddr($newaddr)); 32038494Sobrien push(@toFinal,$newaddr,$newmxhost,$newname); 32138494Sobrien } else { 32238494Sobrien &verbose(&final($newaddr,$newmxhost,$newname)); 32338494Sobrien } 32438494Sobrien } else { 32538494Sobrien # more work to do... 32638494Sobrien if ($valid) { 32738494Sobrien push(@isValid, &validAddr($newaddr)); 32838494Sobrien push(@toExpn,$newmxhost,$newaddr,$newname,$level{"$u *** $server"}); 32938494Sobrien } else { 33038494Sobrien &verbose(&expn($newmxhost,$newaddr,$newname,$level{"$u *** $server"})); 33138494Sobrien } 33238494Sobrien } 33338494Sobrien } 33438494Sobrien last if ($done eq " "); 33538494Sobrien next; 33638494Sobrien } 33738494Sobrien # 550 is a known code... Should the be 33838494Sobrien # included in -a output? Might be a bug 33938494Sobrien # here. Does it matter? Can assume that 340119679Smbr # there won't be UNKNOWN USER responses 34138494Sobrien # mixed with valid users? 34238494Sobrien if ($s =~ /^(550)([- ])/) { 34338494Sobrien if ($valid) { 34438494Sobrien print STDERR "\@$server:$u ($oldname) USER UNKNOWN\n"; 34538494Sobrien } else { 34638494Sobrien &verbose(&final($u,$server,$oldname,"USER UNKNOWN")); 34738494Sobrien } 34838494Sobrien last if ($2 eq " "); 34938494Sobrien next; 350119679Smbr } 351119679Smbr # 553 is a known code... 35238494Sobrien if ($s =~ /^(553)([- ])/) { 35338494Sobrien if ($valid) { 35438494Sobrien print STDERR "\@$server:$u ($oldname) USER AMBIGUOUS\n"; 35538494Sobrien } else { 35638494Sobrien &verbose(&final($u,$server,$oldname,"USER AMBIGUOUS")); 35738494Sobrien } 35838494Sobrien last if ($2 eq " "); 35938494Sobrien next; 360119679Smbr } 361119679Smbr # 252 is a known code... 36238494Sobrien if ($s =~ /^(252)([- ])/) { 36338494Sobrien if ($valid) { 36438494Sobrien print STDERR "\@$server:$u ($oldname) REFUSED TO VRFY\n"; 36538494Sobrien } else { 36638494Sobrien &verbose(&final($u,$server,$oldname,"REFUSED TO VRFY")); 36738494Sobrien } 36838494Sobrien last if ($2 eq " "); 36938494Sobrien next; 370119679Smbr } 37138494Sobrien &giveup('',"$server: did not grok '$s'",$u); 37238494Sobrien last USER; 37338494Sobrien } 37438494Sobrien 37538494Sobrien if ($valid) { 37638494Sobrien # 37738494Sobrien # now we decide if we are going to take these 37838494Sobrien # expansions or roll them back. 37938494Sobrien # 38038494Sobrien $avgValid = &average(@isValid); 38138494Sobrien print "avgValid = $avgValid\n" if $debug; 38238494Sobrien if ($avgValid >= $validRequirement) { 38338494Sobrien print &compact($u,$server)." ->\n" if $verbose; 38438494Sobrien while (@toExpn) { 38538494Sobrien &verbose(&expn(splice(@toExpn,0,4))); 38638494Sobrien } 38738494Sobrien while (@toFinal) { 38838494Sobrien &verbose(&final(splice(@toFinal,0,3))); 38938494Sobrien } 39038494Sobrien } else { 39138494Sobrien print "Tossing some valid to avoid invalid ".&compact($u,$server)."\n" if ($avgValid > 0.0 && ($vw || $debug)); 39238494Sobrien print &compact($u,$server)." ->\n" if $verbose; 39338494Sobrien &verbose(&final($u,$server,$newname)); 39438494Sobrien } 39538494Sobrien } 39638494Sobrien } 39738494Sobrien 39838494Sobrien &alarm("sending 'quit' to $server",''); 39938494Sobrien $0 = "$av0 - sending 'quit' to $server"; 40038494Sobrien &ps("quit"); 40138494Sobrien while(<S>) { 40238494Sobrien print if $watch; 40338494Sobrien last if /^\d+ /; 40438494Sobrien } 40538494Sobrien close(S); 40638494Sobrien alarm(0); 40738494Sobrien} 40838494Sobrien 40938494Sobrien$0 = "$av0 - printing final results"; 41038494Sobrienprint "----------\n" if $vw; 41138494Sobrienselect(STDOUT); 41238494Sobrienfor $f (sort @final) { 41338494Sobrien print "$f\n"; 41438494Sobrien} 41538494Sobrienunlink("/tmp/expn$$"); 41638494Sobrienexit(0); 41738494Sobrien 41838494Sobrien 41938494Sobrien# abandon all attempts deliver to $server 42038494Sobrien# register the current addresses as the final ones 42138494Sobriensub giveup 42238494Sobrien{ 42338494Sobrien local($redirect_okay,$reason,$user) = @_; 42438494Sobrien local($us,@so,$nh,@remaining_users); 42538494Sobrien local($pk,$file,$line); 42638494Sobrien ($pk, $file, $line) = caller; 42738494Sobrien 42838494Sobrien $0 = "$av0 - giving up on $server: $reason"; 42938494Sobrien # 43038494Sobrien # add back a user if we gave up in the middle 43138494Sobrien # 43238494Sobrien push(@users,$user) if $user; 43338494Sobrien # 43438494Sobrien # don't bother with this system anymore 43538494Sobrien # 43638494Sobrien unless ($giveup{$server}) { 43738494Sobrien $giveup{$server} = $reason; 43838494Sobrien print STDERR "$reason\n"; 43938494Sobrien } 44038494Sobrien print "Giveup at $file:$line!!! redirect okay = $redirect_okay; $reason\n" if $debug; 44138494Sobrien # 44238494Sobrien # Wait! 44338494Sobrien # Before giving up, see if there is a chance that 44438494Sobrien # there is another host to redirect to! 44538494Sobrien # (Kids, don't do this at home! Hacking is a dangerous 44638494Sobrien # crime and you could end up behind bars.) 44738494Sobrien # 44838494Sobrien for $u (@users) { 44938494Sobrien if ($redirect_okay =~ /\bmx\b/) { 45038494Sobrien next if &try_fallback('mx',$u,*server, 45138494Sobrien *mx_secondary, 45238494Sobrien *already_mx_fellback); 45338494Sobrien } 45438494Sobrien if ($redirect_okay =~ /\bdomainify\b/) { 45538494Sobrien next if &try_fallback('domainify',$u,*server, 45638494Sobrien *domainify_fallback, 45738494Sobrien *already_domainify_fellback); 45838494Sobrien } 45938494Sobrien push(@remaining_users,$u); 46038494Sobrien } 46138494Sobrien @users = @remaining_users; 46238494Sobrien for $u (@users) { 46338494Sobrien print &compact($u,$server)." ->\n" if ($verbose && $valid && $u); 46438494Sobrien &verbose(&final($u,$server,$names{"$u *** $server"},$reason)); 46538494Sobrien } 46638494Sobrien} 46738494Sobrien# 46838494Sobrien# This routine is used only within &giveup. It checks to 46938494Sobrien# see if we really have to giveup or if there is a second 470119679Smbr# chance because we did something before that can be 47138494Sobrien# backtracked. 47238494Sobrien# 47338494Sobrien# %fallback{"$user *** $host"} tracks what is able to fallback 47438494Sobrien# %fellback{"$user *** $host"} tracks what has fallen back 47538494Sobrien# 47638494Sobrien# If there is a valid backtrack, then queue up the new possibility 47738494Sobrien# 47838494Sobriensub try_fallback 47938494Sobrien{ 48038494Sobrien local($method,$user,*host,*fall_table,*fellback) = @_; 48138494Sobrien local($us,$fallhost,$oldhost,$ft,$i); 48238494Sobrien 48338494Sobrien if ($debug > 8) { 48438494Sobrien print "Fallback table $method:\n"; 48538494Sobrien for $i (sort keys %fall_table) { 48638494Sobrien print "\t'$i'\t\t'$fall_table{$i}'\n"; 48738494Sobrien } 48838494Sobrien print "Fellback table $method:\n"; 48938494Sobrien for $i (sort keys %fellback) { 49038494Sobrien print "\t'$i'\t\t'$fellback{$i}'\n"; 49138494Sobrien } 49238494Sobrien print "U: $user H: $host\n"; 49338494Sobrien } 494119679Smbr 49538494Sobrien $us = "$user *** $host"; 49638494Sobrien if (defined $fellback{$us}) { 49738494Sobrien # 49838494Sobrien # Undo a previous fallback so that we can try again 49938494Sobrien # Nested fallbacks are avoided because they could 50038494Sobrien # lead to infinite loops 50138494Sobrien # 50238494Sobrien $fallhost = $fellback{$us}; 50338494Sobrien print "Already $method fell back from $us -> \n" if $debug; 50438494Sobrien $us = "$user *** $fallhost"; 50538494Sobrien $oldhost = $fallhost; 50638494Sobrien } elsif (($method eq 'mx') && (defined $mxbacktrace{$us}) && (defined $mx_secondary{$mxbacktrace{$us}})) { 50738494Sobrien print "Fallback an MX expansion $us -> \n" if $debug; 50838494Sobrien $oldhost = $mxbacktrace{$us}; 50938494Sobrien } else { 51038494Sobrien print "Oldhost($host, $us) = " if $debug; 51138494Sobrien $oldhost = $host; 51238494Sobrien } 51338494Sobrien print "$oldhost\n" if $debug; 51438494Sobrien if (((defined $fall_table{$us}) && ($ft = $us)) || ((defined $fall_table{$oldhost}) && ($ft = $oldhost))) { 51538494Sobrien print "$method Fallback = ".$fall_table{$ft}."\n" if $debug; 51638494Sobrien local(@so,$newhost); 51738494Sobrien @so = split(' ',$fall_table{$ft}); 51838494Sobrien $newhost = shift(@so); 51938494Sobrien print "Falling back ($method) $us -> $newhost (from $oldhost)\n" if $debug; 52038494Sobrien if ($method eq 'mx') { 52138494Sobrien if (! defined ($mxbacktrace{"$user *** $newhost"})) { 52238494Sobrien if (defined $mxbacktrace{"$user *** $oldhost"}) { 52338494Sobrien print "resetting oldhost $oldhost to the original: " if $debug; 52438494Sobrien $oldhost = $mxbacktrace{"$user *** $oldhost"}; 52538494Sobrien print "$oldhost\n" if $debug; 52638494Sobrien } 52738494Sobrien $mxbacktrace{"$user *** $newhost"} = $oldhost; 52838494Sobrien print "mxbacktrace $user *** $newhost -> $oldhost\n" if $debug; 52938494Sobrien } 53038494Sobrien $mx{&trhost($oldhost)} = $newhost; 53138494Sobrien } else { 53238494Sobrien $temporary_redirect{$us} = $newhost; 53338494Sobrien } 53438494Sobrien if (@so) { 53538494Sobrien print "Can still $method $us: @so\n" if $debug; 53638494Sobrien $fall_table{$ft} = join(' ',@so); 53738494Sobrien } else { 53838494Sobrien print "No more fallbacks for $us\n" if $debug; 53938494Sobrien delete $fall_table{$ft}; 54038494Sobrien } 54138494Sobrien if (defined $create_host_backtrack{$us}) { 542119679Smbr $create_host_backtrack{"$user *** $newhost"} 54338494Sobrien = $create_host_backtrack{$us}; 54438494Sobrien } 54538494Sobrien $fellback{"$user *** $newhost"} = $oldhost; 54638494Sobrien &expn($newhost,$user,$names{$us},$level{$us}); 54738494Sobrien return 1; 54838494Sobrien } 54938494Sobrien delete $temporary_redirect{$us}; 55038494Sobrien $host = $oldhost; 55138494Sobrien return 0; 55238494Sobrien} 55338494Sobrien# return 1 if you could send mail to the address as is. 55438494Sobriensub validAddr 55538494Sobrien{ 55638494Sobrien local($addr) = @_; 55738494Sobrien $res = &do_validAddr($addr); 55838494Sobrien print "validAddr($addr) = $res\n" if $debug; 55938494Sobrien $res; 56038494Sobrien} 56138494Sobriensub do_validAddr 56238494Sobrien{ 56338494Sobrien local($addr) = @_; 56438494Sobrien local($urx) = "[-A-Za-z_.0-9+]+"; 56538494Sobrien 56638494Sobrien # \u 56738494Sobrien return 0 if ($addr =~ /^\\/); 56838494Sobrien # ?@h 56938494Sobrien return 1 if ($addr =~ /.\@$urx$/); 57038494Sobrien # @h:? 57138494Sobrien return 1 if ($addr =~ /^\@$urx\:./); 57238494Sobrien # h!u 57338494Sobrien return 1 if ($addr =~ /^$urx!./); 57438494Sobrien # u 57538494Sobrien return 1 if ($addr =~ /^$urx$/); 57638494Sobrien # ? 57738494Sobrien print "validAddr($addr) = ???\n" if $debug; 57838494Sobrien return 0; 57938494Sobrien} 58038494Sobrien# Some systems use expn and vrfy interchangeably. Some only 58138494Sobrien# implement one or the other. Some check expn against mailing 58238494Sobrien# lists and vrfy against users. It doesn't appear to be 58338494Sobrien# consistent. 58438494Sobrien# 58538494Sobrien# So, what do we do? We try everything! 58638494Sobrien# 58738494Sobrien# 58838494Sobrien# Ranking of result codes: good: 250, 251/551, 252, 550, anything else 58938494Sobrien# 59038494Sobrien# Ranking of inputs: best: user@host.domain, okay: user 59138494Sobrien# 59238494Sobrien# Return value: $error_string, @responses_from_server 59338494Sobriensub expn_vrfy 59438494Sobrien{ 59538494Sobrien local($u,$server) = @_; 59638494Sobrien local(@c) = ('expn', 'vrfy'); 59738494Sobrien local(@try_u) = $u; 59838494Sobrien local(@ret,$code); 59938494Sobrien 60038494Sobrien if (($u =~ /(.+)@(.+)/) && (&trhost($2) eq &trhost($server))) { 60138494Sobrien push(@try_u,$1); 60238494Sobrien } 60338494Sobrien 60438494Sobrien TRY: 60538494Sobrien for $c (@c) { 60638494Sobrien for $try_u (@try_u) { 60738494Sobrien &alarm("${c}'ing $try_u on $server",'',$u); 60838494Sobrien &ps("$c $try_u"); 60938494Sobrien alarm(0); 61038494Sobrien $s = <S>; 61138494Sobrien if ($s eq '') { 61238494Sobrien return "$server: lost connection"; 61338494Sobrien } 61438494Sobrien if ($s !~ /^(\d+)([- ])/) { 61538494Sobrien return "$server: garbled reply to '$c $try_u'"; 61638494Sobrien } 61738494Sobrien if ($1 == 250) { 61838494Sobrien $code = 250; 61938494Sobrien @ret = ("",$s); 62038494Sobrien push(@ret,&read_response($2,$debug)); 62138494Sobrien return (@ret); 622119679Smbr } 62338494Sobrien if ($1 == 551 || $1 == 251) { 62438494Sobrien $code = $1; 62538494Sobrien @ret = ("",$s); 62638494Sobrien push(@ret,&read_response($2,$debug)); 62738494Sobrien next; 62838494Sobrien } 62938494Sobrien if ($1 == 252 && ($code == 0 || $code == 550)) { 63038494Sobrien $code = 252; 63138494Sobrien @ret = ("",$s); 63238494Sobrien push(@ret,&read_response($2,$watch)); 63338494Sobrien next; 63438494Sobrien } 63538494Sobrien if ($1 == 550 && $code == 0) { 63638494Sobrien $code = 550; 63738494Sobrien @ret = ("",$s); 63838494Sobrien push(@ret,&read_response($2,$watch)); 63938494Sobrien next; 64038494Sobrien } 64138494Sobrien &read_response($2,$watch); 64238494Sobrien } 64338494Sobrien } 64438494Sobrien return "$server: expn/vrfy not implemented" unless @ret; 64538494Sobrien return @ret; 64638494Sobrien} 64738494Sobrien# sometimes the old parse routine (now parse2) didn't 648119679Smbr# reject funky addresses. 64938494Sobriensub parse 65038494Sobrien{ 65138494Sobrien local($oldaddr,$server,$oldname,$one_to_one) = @_; 65238494Sobrien local($newhost, $newaddr, $newname, $um) = &parse2($oldaddr,$server,$oldname,$one_to_one); 65338494Sobrien if ($newaddr =~ m,^["/],) { 65438494Sobrien return (undef, $oldaddr, $newname) if $valid; 65538494Sobrien return (undef, $um, $newname); 65638494Sobrien } 65738494Sobrien return ($newhost, $newaddr, $newname); 65838494Sobrien} 65938494Sobrien 66038494Sobrien# returns ($new_smtp_server,$new_address,$new_name) 661119679Smbr# given a response from a SMTP server ($newaddr), the 66238494Sobrien# current host ($server), the old "name" and a flag that 663119679Smbr# indicates if it is being called during the initial 66438494Sobrien# command line parsing ($parsing_args) 66538494Sobriensub parse2 66638494Sobrien{ 66738494Sobrien local($newaddr,$context_host,$old_name,$parsing_args) = @_; 66838494Sobrien local(@names) = $old_name; 66938494Sobrien local($urx) = "[-A-Za-z_.0-9+]+"; 67038494Sobrien local($unmangle); 67138494Sobrien 67238494Sobrien # 67338494Sobrien # first, separate out the address part. 67438494Sobrien # 67538494Sobrien 67638494Sobrien # 67738494Sobrien # [NAME] <ADDR [(NAME)]> 67838494Sobrien # [NAME] <[(NAME)] ADDR 67938494Sobrien # ADDR [(NAME)] 68038494Sobrien # (NAME) ADDR 68138494Sobrien # [(NAME)] <ADDR> 68238494Sobrien # 68338494Sobrien if ($newaddr =~ /^\<(.*)\>$/) { 68438494Sobrien print "<A:$1>\n" if $debug; 68538494Sobrien ($newaddr) = &trim($1); 68638494Sobrien print "na = $newaddr\n" if $debug; 68738494Sobrien } 68838494Sobrien if ($newaddr =~ /^([^\<\>]*)\<([^\<\>]*)\>([^\<\>]*)$/) { 68938494Sobrien # address has a < > pair in it. 69038494Sobrien print "N:$1 <A:$2> N:$3\n" if $debug; 69138494Sobrien ($newaddr) = &trim($2); 69238494Sobrien unshift(@names, &trim($3,$1)); 69338494Sobrien print "na = $newaddr\n" if $debug; 69438494Sobrien } 69538494Sobrien if ($newaddr =~ /^([^\(\)]*)\(([^\(\)]*)\)([^\(\)]*)$/) { 69638494Sobrien # address has a ( ) pair in it. 69738494Sobrien print "A:$1 (N:$2) A:$3\n" if $debug; 69838494Sobrien unshift(@names,&trim($2)); 69938494Sobrien local($f,$l) = (&trim($1),&trim($3)); 70038494Sobrien if (($f && $l) || !($f || $l)) { 70138494Sobrien # address looks like: 70238494Sobrien # foo (bar) baz or (bar) 70338494Sobrien # not allowed! 70438494Sobrien print STDERR "Could not parse $newaddr\n" if $vw; 70538494Sobrien return(undef,$newaddr,&firstname(@names)); 70638494Sobrien } 70738494Sobrien $newaddr = $f if $f; 70838494Sobrien $newaddr = $l if $l; 70938494Sobrien print "newaddr now = $newaddr\n" if $debug; 71038494Sobrien } 71138494Sobrien # 71238494Sobrien # @foo:bar 71338494Sobrien # j%k@l 71438494Sobrien # a@b 71538494Sobrien # b!a 71638494Sobrien # a 71738494Sobrien # 71838494Sobrien $unmangle = $newaddr; 71938494Sobrien if ($newaddr =~ /^\@($urx)\:(.+)$/) { 72038494Sobrien print "(\@:)" if $debug; 72138494Sobrien # this is a bit of a cheat, but it seems necessary 72238494Sobrien return (&domainify($1,$context_host,$2),$2,&firstname(@names),$unmangle); 72338494Sobrien } 72438494Sobrien if ($newaddr =~ /^(.+)\@($urx)$/) { 72538494Sobrien print "(\@)" if $debug; 72638494Sobrien return (&domainify($2,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle); 72738494Sobrien } 72838494Sobrien if ($parsing_args) { 72938494Sobrien if ($newaddr =~ /^($urx)\!(.+)$/) { 73038494Sobrien return (&domainify($1,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle); 73138494Sobrien } 73238494Sobrien if ($newaddr =~ /^($urx)$/) { 73338494Sobrien return ($context_host,$newaddr,&firstname(@names),$unmangle); 73438494Sobrien } 73538494Sobrien print STDERR "Could not parse $newaddr\n"; 73638494Sobrien } 73738494Sobrien print "(?)" if $debug; 73838494Sobrien return(undef,$newaddr,&firstname(@names),$unmangle); 73938494Sobrien} 74038494Sobrien# return $u (@$server) unless $u includes reference to $server 74138494Sobriensub compact 74238494Sobrien{ 74338494Sobrien local($u, $server) = @_; 74438494Sobrien local($se) = $server; 74538494Sobrien local($sp); 74638494Sobrien $se =~ s/(\W)/\\$1/g; 74738494Sobrien $sp = " (\@$server)"; 74838494Sobrien if ($u !~ /$se/i) { 74938494Sobrien return "$u$sp"; 75038494Sobrien } 75138494Sobrien return $u; 75238494Sobrien} 75338494Sobrien# remove empty (spaces don't count) members from an array 75438494Sobriensub trim 75538494Sobrien{ 75638494Sobrien local(@v) = @_; 75738494Sobrien local($v,@r); 75838494Sobrien for $v (@v) { 75938494Sobrien $v =~ s/^\s+//; 76038494Sobrien $v =~ s/\s+$//; 76138494Sobrien push(@r,$v) if ($v =~ /\S/); 76238494Sobrien } 76338494Sobrien return(@r); 76438494Sobrien} 76538494Sobrien# using the host part of an address, and the server name, add the 766119679Smbr# servers' domain to the address if it doesn't already have a 76738494Sobrien# domain. Since this sometimes fails, save a back reference so 76838494Sobrien# it can be unrolled. 76938494Sobriensub domainify 77038494Sobrien{ 77138494Sobrien local($host,$domain_host,$u) = @_; 77238494Sobrien local($domain,$newhost); 77338494Sobrien 774119679Smbr # cut of trailing dots 77538494Sobrien $host =~ s/\.$//; 77638494Sobrien $domain_host =~ s/\.$//; 77738494Sobrien 77838494Sobrien if ($domain_host !~ /\./) { 77938494Sobrien # 78038494Sobrien # domain host isn't, keep $host whatever it is 78138494Sobrien # 78238494Sobrien print "domainify($host,$domain_host) = $host\n" if $debug; 78338494Sobrien return $host; 78438494Sobrien } 78538494Sobrien 786119679Smbr # 787119679Smbr # There are several weird situations that need to be 78838494Sobrien # accounted for. They have to do with domain relay hosts. 78938494Sobrien # 790119679Smbr # Examples: 79138494Sobrien # host server "right answer" 792119679Smbr # 79338494Sobrien # shiva.cs cs.berkeley.edu shiva.cs.berkeley.edu 79438494Sobrien # shiva cs.berkeley.edu shiva.cs.berekley.edu 79538494Sobrien # cumulus reed.edu @reed.edu:cumulus.uucp 79638494Sobrien # tiberius tc.cornell.edu tiberius.tc.cornell.edu 79738494Sobrien # 798119679Smbr # The first try must always be to cut the domain part out of 79938494Sobrien # the server and tack it onto the host. 80038494Sobrien # 80138494Sobrien # A reasonable second try is to tack the whole server part onto 802119679Smbr # the host and for each possible repeated element, eliminate 80338494Sobrien # just that part. 80438494Sobrien # 80538494Sobrien # These extra "guesses" get put into the %domainify_fallback 80638494Sobrien # array. They will be used to give addresses a second chance 80738494Sobrien # in the &giveup routine 80838494Sobrien # 80938494Sobrien 81038494Sobrien local(%fallback); 81138494Sobrien 812119679Smbr local($long); 81338494Sobrien $long = "$host $domain_host"; 81438494Sobrien $long =~ tr/A-Z/a-z/; 81538494Sobrien print "long = $long\n" if $debug; 81638494Sobrien if ($long =~ s/^([^ ]+\.)([^ ]+) \2(\.[^ ]+\.[^ ]+)/$1$2$3/) { 81738494Sobrien # matches shiva.cs cs.berkeley.edu and returns shiva.cs.berkeley.edu 81838494Sobrien print "condensed fallback $host $domain_host -> $long\n" if $debug; 81938494Sobrien $fallback{$long} = 9; 82038494Sobrien } 82138494Sobrien 82238494Sobrien local($fh); 82338494Sobrien $fh = $domain_host; 82438494Sobrien while ($fh =~ /\./) { 82538494Sobrien print "FALLBACK $host.$fh = 1\n" if $debug > 7; 82638494Sobrien $fallback{"$host.$fh"} = 1; 82738494Sobrien $fh =~ s/^[^\.]+\.//; 82838494Sobrien } 82938494Sobrien 83038494Sobrien $fallback{"$host.$domain_host"} = 2; 83138494Sobrien 83238494Sobrien ($domain = $domain_host) =~ s/^[^\.]+//; 83338494Sobrien $fallback{"$host$domain"} = 6 83438494Sobrien if ($domain =~ /\./); 83538494Sobrien 83638494Sobrien if ($host =~ /\./) { 83738494Sobrien # 83838494Sobrien # Host is already okay, but let's look for multiple 83938494Sobrien # interpretations 84038494Sobrien # 84138494Sobrien print "domainify($host,$domain_host) = $host\n" if $debug; 84238494Sobrien delete $fallback{$host}; 84338494Sobrien $domainify_fallback{"$u *** $host"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback; 84438494Sobrien return $host; 84538494Sobrien } 84638494Sobrien 84738494Sobrien $domain = ".$domain_host" 84838494Sobrien if ($domain !~ /\..*\./); 84938494Sobrien $newhost = "$host$domain"; 85038494Sobrien 85138494Sobrien $create_host_backtrack{"$u *** $newhost"} = $domain_host; 85238494Sobrien print "domainify($host,$domain_host) = $newhost\n" if $debug; 85338494Sobrien delete $fallback{$newhost}; 85438494Sobrien $domainify_fallback{"$u *** $newhost"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback; 85538494Sobrien if ($debug) { 85638494Sobrien print "fallback = "; 857119679Smbr print $domainify_fallback{"$u *** $newhost"} 85838494Sobrien if defined($domainify_fallback{"$u *** $newhost"}); 85938494Sobrien print "\n"; 86038494Sobrien } 86138494Sobrien return $newhost; 86238494Sobrien} 86338494Sobrien# return the first non-empty element of an array 86438494Sobriensub firstname 86538494Sobrien{ 86638494Sobrien local(@names) = @_; 86738494Sobrien local($n); 86838494Sobrien while(@names) { 86938494Sobrien $n = shift(@names); 87038494Sobrien return $n if $n =~ /\S/; 87138494Sobrien } 87238494Sobrien return undef; 87338494Sobrien} 87438494Sobrien# queue up more addresses to expand 87538494Sobriensub expn 87638494Sobrien{ 87738494Sobrien local($host,$addr,$name,$level) = @_; 87838494Sobrien if ($host) { 87938494Sobrien $host = &trhost($host); 88038494Sobrien 88138494Sobrien if (($debug > 3) || (defined $giveup{$host})) { 88238494Sobrien unshift(@hosts,$host) unless $users{$host}; 88338494Sobrien } else { 88438494Sobrien push(@hosts,$host) unless $users{$host}; 88538494Sobrien } 88638494Sobrien $users{$host} .= " $addr"; 88738494Sobrien $names{"$addr *** $host"} = $name; 88838494Sobrien $level{"$addr *** $host"} = $level + 1; 88938494Sobrien print "expn($host,$addr,$name)\n" if $debug; 89038494Sobrien return "\t$addr\n"; 89138494Sobrien } else { 89238494Sobrien return &final($addr,'NONE',$name); 89338494Sobrien } 89438494Sobrien} 89538494Sobrien# compute the numerical average value of an array 89638494Sobriensub average 89738494Sobrien{ 89838494Sobrien local(@e) = @_; 89938494Sobrien return 0 unless @e; 90038494Sobrien local($e,$sum); 90138494Sobrien for $e (@e) { 90238494Sobrien $sum += $e; 90338494Sobrien } 90438494Sobrien $sum / @e; 90538494Sobrien} 90638494Sobrien# print to the server (also to stdout, if -w) 90738494Sobriensub ps 90838494Sobrien{ 90938494Sobrien local($p) = @_; 91038494Sobrien print ">>> $p\n" if $watch; 91138494Sobrien print S "$p\n"; 91238494Sobrien} 91338494Sobrien# return case-adjusted name for a host (for comparison purposes) 914119679Smbrsub trhost 91538494Sobrien{ 91638494Sobrien # treat foo.bar as an alias for Foo.BAR 91738494Sobrien local($host) = @_; 91838494Sobrien local($trhost) = $host; 91938494Sobrien $trhost =~ tr/A-Z/a-z/; 92038494Sobrien if ($trhost{$trhost}) { 92138494Sobrien $host = $trhost{$trhost}; 92238494Sobrien } else { 92338494Sobrien $trhost{$trhost} = $host; 92438494Sobrien } 92538494Sobrien $trhost{$trhost}; 92638494Sobrien} 92738494Sobrien# re-queue users if an mx record dictates a redirect 92838494Sobrien# don't allow a user to be redirected more than once 92938494Sobriensub mxredirect 93038494Sobrien{ 93138494Sobrien local($server,*users) = @_; 93238494Sobrien local($u,$nserver,@still_there); 93338494Sobrien 93438494Sobrien $nserver = &mx($server); 93538494Sobrien 93638494Sobrien if (&trhost($nserver) ne &trhost($server)) { 93738494Sobrien $0 = "$av0 - mx redirect $server -> $nserver\n"; 93838494Sobrien for $u (@users) { 93938494Sobrien if (defined $mxbacktrace{"$u *** $nserver"}) { 94038494Sobrien push(@still_there,$u); 94138494Sobrien } else { 94238494Sobrien $mxbacktrace{"$u *** $nserver"} = $server; 94338494Sobrien print "mxbacktrace{$u *** $nserver} = $server\n" 94438494Sobrien if ($debug > 1); 94538494Sobrien &expn($nserver,$u,$names{"$u *** $server"}); 94638494Sobrien } 94738494Sobrien } 94838494Sobrien @users = @still_there; 94938494Sobrien if (! @users) { 95038494Sobrien return $nserver; 95138494Sobrien } else { 95238494Sobrien return undef; 95338494Sobrien } 95438494Sobrien } 95538494Sobrien return undef; 95638494Sobrien} 95738494Sobrien# follow mx records, return a hostname 958119679Smbr# also follow temporary redirections coming from &domainify and 95938494Sobrien# &mxlookup 96038494Sobriensub mx 96138494Sobrien{ 96238494Sobrien local($h,$u) = @_; 96338494Sobrien 96438494Sobrien for (;;) { 96538494Sobrien if (defined $mx{&trhost($h)} && $h ne $mx{&trhost($h)}) { 96638494Sobrien $0 = "$av0 - mx expand $h"; 96738494Sobrien $h = $mx{&trhost($h)}; 96838494Sobrien return $h; 96938494Sobrien } 97038494Sobrien if ($u) { 97138494Sobrien if (defined $temporary_redirect{"$u *** $h"}) { 97238494Sobrien $0 = "$av0 - internal redirect $h"; 97338494Sobrien print "Temporary redirect taken $u *** $h -> " if $debug; 97438494Sobrien $h = $temporary_redirect{"$u *** $h"}; 97538494Sobrien print "$h\n" if $debug; 97638494Sobrien next; 97738494Sobrien } 97838494Sobrien $htr = &trhost($h); 97938494Sobrien if (defined $temporary_redirect{"$u *** $htr"}) { 98038494Sobrien $0 = "$av0 - internal redirect $h"; 98138494Sobrien print "temporary redirect taken $u *** $h -> " if $debug; 98238494Sobrien $h = $temporary_redirect{"$u *** $htr"}; 98338494Sobrien print "$h\n" if $debug; 98438494Sobrien next; 98538494Sobrien } 98638494Sobrien } 98738494Sobrien return $h; 98838494Sobrien } 98938494Sobrien} 99038494Sobrien# look up mx records with the name server. 99138494Sobrien# re-queue expansion requests if possible 99238494Sobrien# optionally give up on this host. 993119679Smbrsub mxlookup 99438494Sobrien{ 99538494Sobrien local($lastchance,$server,$giveup,*users) = @_; 99638494Sobrien local(*T); 99738494Sobrien local(*NSLOOKUP); 99838494Sobrien local($nh, $pref,$cpref); 99938494Sobrien local($o0) = $0; 100038494Sobrien local($nserver); 100138494Sobrien local($name,$aliases,$type,$len,$thataddr); 100238494Sobrien local(%fallback); 100338494Sobrien 100438494Sobrien return 1 if &mxredirect($server,*users); 100538494Sobrien 100638494Sobrien if ((defined $mx{$server}) || (! $have_nslookup)) { 100738494Sobrien return 0 unless $lastchance; 100838494Sobrien &giveup('mx domainify',$giveup); 100938494Sobrien return 0; 101038494Sobrien } 101138494Sobrien 101238494Sobrien $0 = "$av0 - nslookup of $server"; 101338494Sobrien open(T,">/tmp/expn$$") || die "open > /tmp/expn$$: $!\n"; 101438494Sobrien print T "set querytype=MX\n"; 101538494Sobrien print T "$server\n"; 101638494Sobrien close(T); 101738494Sobrien $cpref = 1.0E12; 101838494Sobrien undef $nserver; 101938494Sobrien open(NSLOOKUP,"nslookup < /tmp/expn$$ 2>&1 |") || die "open nslookup: $!"; 102038494Sobrien while(<NSLOOKUP>) { 102138494Sobrien print if ($debug > 2); 102238494Sobrien if (/mail exchanger = ([-A-Za-z_.0-9+]+)/) { 102338494Sobrien $nh = $1; 102438494Sobrien if (/preference = (\d+)/) { 102538494Sobrien $pref = $1; 102638494Sobrien if ($pref < $cpref) { 102738494Sobrien $nserver = $nh; 102838494Sobrien $cpref = $pref; 102938494Sobrien } elsif ($pref) { 103038494Sobrien $fallback{$pref} .= " $nh"; 103138494Sobrien } 103238494Sobrien } 103338494Sobrien } 103438494Sobrien if (/Non-existent domain/) { 103538494Sobrien # 1036119679Smbr # These addresses are hosed. Kaput! Dead! 103738494Sobrien # However, if we created the address in the 1038119679Smbr # first place then there is a chance of 103938494Sobrien # salvation. 104038494Sobrien # 1041119679Smbr 1 while(<NSLOOKUP>); 104238494Sobrien close(NSLOOKUP); 104338494Sobrien return 0 unless $lastchance; 104438494Sobrien &giveup('domainify',"$server: Non-existent domain",undef,1); 1045119679Smbr return 0; 104638494Sobrien } 1047119679Smbr 104838494Sobrien } 104938494Sobrien close(NSLOOKUP); 105038494Sobrien unlink("/tmp/expn$$"); 105138494Sobrien unless ($nserver) { 105238494Sobrien $0 = "$o0 - finished mxlookup"; 105338494Sobrien return 0 unless $lastchance; 105438494Sobrien &giveup('mx domainify',"$server: Could not resolve address"); 105538494Sobrien return 0; 105638494Sobrien } 105738494Sobrien 105838494Sobrien # provide fallbacks in case $nserver doesn't work out 105938494Sobrien if (defined $fallback{$cpref}) { 106038494Sobrien $mx_secondary{$server} = $fallback{$cpref}; 106138494Sobrien } 106238494Sobrien 106338494Sobrien $0 = "$av0 - gethostbyname($nserver)"; 106438494Sobrien ($name,$aliases,$type,$len,$thataddr) = gethostbyname($nserver); 106538494Sobrien 106638494Sobrien unless ($thataddr) { 106738494Sobrien $0 = $o0; 106838494Sobrien return 0 unless $lastchance; 106938494Sobrien &giveup('mx domainify',"$nserver: could not resolve address"); 107038494Sobrien return 0; 107138494Sobrien } 107238494Sobrien print "MX($server) = $nserver\n" if $debug; 107338494Sobrien print "$server -> $nserver\n" if $vw && !$debug; 107438494Sobrien $mx{&trhost($server)} = $nserver; 107538494Sobrien # redeploy the users 107638494Sobrien unless (&mxredirect($server,*users)) { 107738494Sobrien return 0 unless $lastchance; 107838494Sobrien &giveup('mx domainify',"$nserver: only one level of mx redirect allowed"); 107938494Sobrien return 0; 108038494Sobrien } 108138494Sobrien $0 = "$o0 - finished mxlookup"; 108238494Sobrien return 1; 108338494Sobrien} 108438494Sobrien# if mx expansion did not help to resolve an address 1085119679Smbr# (ie: foo@bar became @baz:foo@bar, then undo the 108638494Sobrien# expansion). 108738494Sobrien# this is only used by &final 108838494Sobriensub mxunroll 108938494Sobrien{ 109038494Sobrien local(*host,*addr) = @_; 109138494Sobrien local($r) = 0; 109238494Sobrien print "looking for mxbacktrace{$addr *** $host}\n" 109338494Sobrien if ($debug > 1); 109438494Sobrien while (defined $mxbacktrace{"$addr *** $host"}) { 1095119679Smbr print "Unrolling MX expansion: \@$host:$addr -> " 109638494Sobrien if ($debug || $verbose); 109738494Sobrien $host = $mxbacktrace{"$addr *** $host"}; 1098119679Smbr print "\@$host:$addr\n" 109938494Sobrien if ($debug || $verbose); 110038494Sobrien $r = 1; 110138494Sobrien } 110238494Sobrien return 1 if $r; 110338494Sobrien $addr = "\@$host:$addr" 110438494Sobrien if ($host =~ /\./); 110538494Sobrien return 0; 110638494Sobrien} 1107119679Smbr# register a completed expansion. Make the final address as 110838494Sobrien# simple as possible. 110938494Sobriensub final 111038494Sobrien{ 111138494Sobrien local($addr,$host,$name,$error) = @_; 111238494Sobrien local($he); 111338494Sobrien local($hb,$hr); 111438494Sobrien local($au,$ah); 111538494Sobrien 111638494Sobrien if ($error =~ /Non-existent domain/) { 1117119679Smbr # 111838494Sobrien # If we created the domain, then let's undo the 111938494Sobrien # damage... 112038494Sobrien # 112138494Sobrien if (defined $create_host_backtrack{"$addr *** $host"}) { 112238494Sobrien while (defined $create_host_backtrack{"$addr *** $host"}) { 112338494Sobrien print "Un&domainifying($host) = " if $debug; 112438494Sobrien $host = $create_host_backtrack{"$addr *** $host"}; 112538494Sobrien print "$host\n" if $debug; 112638494Sobrien } 112738494Sobrien $error = "$host: could not locate"; 112838494Sobrien } else { 1129119679Smbr # 113038494Sobrien # If we only want valid addresses, toss out 113138494Sobrien # bad host names. 113238494Sobrien # 113338494Sobrien if ($valid) { 113438494Sobrien print STDERR "\@$host:$addr ($name) Non-existent domain\n"; 113538494Sobrien return ""; 113638494Sobrien } 113738494Sobrien } 113838494Sobrien } 113938494Sobrien 114038494Sobrien MXUNWIND: { 114138494Sobrien $0 = "$av0 - final parsing of \@$host:$addr"; 114238494Sobrien ($he = $host) =~ s/(\W)/\\$1/g; 114338494Sobrien if ($addr !~ /@/) { 114438494Sobrien # addr does not contain any host 114538494Sobrien $addr = "$addr@$host"; 114638494Sobrien } elsif ($addr !~ /$he/i) { 114738494Sobrien # if host part really something else, use the something 114838494Sobrien # else. 114938494Sobrien if ($addr =~ m/(.*)\@([^\@]+)$/) { 115038494Sobrien ($au,$ah) = ($1,$2); 115138494Sobrien print "au = $au ah = $ah\n" if $debug; 115238494Sobrien if (defined $temporary_redirect{"$addr *** $ah"}) { 115338494Sobrien $addr = "$au\@".$temporary_redirect{"$addr *** $ah"}; 115438494Sobrien print "Rewrite! to $addr\n" if $debug; 115538494Sobrien next MXUNWIND; 115638494Sobrien } 115738494Sobrien } 115838494Sobrien # addr does not contain full host 115938494Sobrien if ($valid) { 116038494Sobrien if ($host =~ /^([^\.]+)(\..+)$/) { 116138494Sobrien # host part has a . in it - foo.bar 116238494Sobrien ($hb, $hr) = ($1, $2); 116338494Sobrien if ($addr =~ /\@([^\.\@]+)$/ && ($1 eq $hb)) { 1164119679Smbr # addr part has not . 116538494Sobrien # and matches beginning of 1166119679Smbr # host part -- tack on a 116738494Sobrien # domain name. 116838494Sobrien $addr .= $hr; 116938494Sobrien } else { 1170119679Smbr &mxunroll(*host,*addr) 117138494Sobrien && redo MXUNWIND; 117238494Sobrien } 117338494Sobrien } else { 1174119679Smbr &mxunroll(*host,*addr) 117538494Sobrien && redo MXUNWIND; 117638494Sobrien } 117738494Sobrien } else { 117838494Sobrien $addr = "${addr}[\@$host]" 117938494Sobrien if ($host =~ /\./); 118038494Sobrien } 118138494Sobrien } 118238494Sobrien } 118338494Sobrien $name = "$name " if $name; 118438494Sobrien $error = " $error" if $error; 118538494Sobrien if ($valid) { 118638494Sobrien push(@final,"$name<$addr>"); 118738494Sobrien } else { 118838494Sobrien push(@final,"$name<$addr>$error"); 118938494Sobrien } 119038494Sobrien "\t$name<$addr>$error\n"; 119138494Sobrien} 119238494Sobrien 119338494Sobriensub alarm 119438494Sobrien{ 119538494Sobrien local($alarm_action,$alarm_redirect,$alarm_user) = @_; 119638494Sobrien alarm(3600); 119738494Sobrien $SIG{ALRM} = 'handle_alarm'; 119838494Sobrien} 119938494Sobrien# this involves one great big ugly hack. 120038494Sobrien# the "next HOST" unwinds the stack! 120138494Sobriensub handle_alarm 120238494Sobrien{ 120338494Sobrien &giveup($alarm_redirect,"Timed out during $alarm_action",$alarm_user); 120438494Sobrien next HOST; 120538494Sobrien} 120638494Sobrien 120738494Sobrien# read the rest of the current smtp daemon's response (and toss it away) 120838494Sobriensub read_response 120938494Sobrien{ 121038494Sobrien local($done,$watch) = @_; 121138494Sobrien local(@resp); 121238494Sobrien print $s if $watch; 121338494Sobrien while(($done eq "-") && ($s = <S>) && ($s =~ /^\d+([- ])/)) { 121438494Sobrien print $s if $watch; 121538494Sobrien $done = $1; 121638494Sobrien push(@resp,$s); 121738494Sobrien } 121838494Sobrien return @resp; 121938494Sobrien} 122038494Sobrien# print args if verbose. Return them in any case 122138494Sobriensub verbose 122238494Sobrien{ 122338494Sobrien local(@tp) = @_; 122438494Sobrien print "@tp" if $verbose; 122538494Sobrien} 122638494Sobrien# to pass perl -w: 122738494Sobrien@tp; 122838494Sobrien$flag_a; 122938494Sobrien$flag_d; 123038494Sobrien$flag_1; 123138494Sobrien%already_domainify_fellback; 123238494Sobrien%already_mx_fellback; 123338494Sobrien&handle_alarm; 1234119679Smbr################### BEGIN PERL/TROFF TRANSITION 1235119679Smbr.00 ; 123638494Sobrien 123738494Sobrien'di 123838494Sobrien.nr nl 0-1 123938494Sobrien.nr % 0 1240119679Smbr.\\"'; __END__ 124138494Sobrien.\" ############## END PERL/TROFF TRANSITION 124238494Sobrien.TH EXPN 1 "March 11, 1993" 124338494Sobrien.AT 3 124438494Sobrien.SH NAME 124538494Sobrienexpn \- recursively expand mail aliases 124638494Sobrien.SH SYNOPSIS 124738494Sobrien.B expn 124838494Sobrien.RI [ -a ] 124938494Sobrien.RI [ -v ] 125038494Sobrien.RI [ -w ] 125138494Sobrien.RI [ -d ] 125238494Sobrien.RI [ -1 ] 125338494Sobrien.IR user [@ hostname ] 125438494Sobrien.RI [ user [@ hostname ]]... 125538494Sobrien.SH DESCRIPTION 125638494Sobrien.B expn 125738494Sobrienwill use the SMTP 125838494Sobrien.B expn 1259119679Smbrand 126038494Sobrien.B vrfy 1261119679Smbrcommands to expand mail aliases. 126238494SobrienIt will first look up the addresses you provide on the command line. 1263119679SmbrIf those expand into addresses on other systems, it will 1264119679Smbrconnect to the other systems and expand again. It will keep 126538494Sobriendoing this until no further expansion is possible. 126638494Sobrien.SH OPTIONS 1267119679SmbrThe default output of 126838494Sobrien.B expn 126938494Sobriencan contain many lines which are not valid 1270119679Smbremail addresses. With the 127138494Sobrien.I -aa 127238494Sobrienflag, only expansions that result in legal addresses 127338494Sobrienare used. Since many mailing lists have an illegal 127438494Sobrienaddress or two, the single 127538494Sobrien.IR -a , 127638494Sobrienaddress, flag specifies that a few illegal addresses can 1277119679Smbrbe mixed into the results. More 127838494Sobrien.I -a 127938494Sobrienflags vary the ratio. Read the source to track down 128038494Sobrienthe formula. With the 128138494Sobrien.I -a 128238494Sobrienoption, you should be able to construct a new mailing 128338494Sobrienlist out of an existing one. 128438494Sobrien.LP 1285119679SmbrIf you wish to limit the number of levels deep that 128638494Sobrien.B expn 128738494Sobrienwill recurse as it traces addresses, use the 128838494Sobrien.I -1 1289119679Smbroption. For each 129038494Sobrien.I -1 1291119679Smbranother level will be traversed. So, 129238494Sobrien.I -111 129338494Sobrienwill traverse no more than three levels deep. 129438494Sobrien.LP 129538494SobrienThe normal mode of operation for 129638494Sobrien.B expn 129738494Sobrienis to do all of its work silently. 129838494SobrienThe following options make it more verbose. 129938494SobrienIt is not necessary to make it verbose to see what it is 1300119679Smbrdoing because as it works, it changes its 130138494Sobrien.BR argv [0] 130238494Sobrienvariable to reflect its current activity. 1303119679SmbrTo see how it is expanding things, the 130438494Sobrien.IR -v , 1305119679Smbrverbose, flag will cause 1306119679Smbr.B expn 130738494Sobriento show each address before 130838494Sobrienand after translation as it works. 1309119679SmbrThe 131038494Sobrien.IR -w , 131138494Sobrienwatch, flag will cause 131238494Sobrien.B expn 131338494Sobriento show you its conversations with the mail daemons. 1314119679SmbrFinally, the 131538494Sobrien.IR -d , 131638494Sobriendebug, flag will expose many of the inner workings so that 131738494Sobrienit is possible to eliminate bugs. 131838494Sobrien.SH ENVIRONMENT 1319119679SmbrNo environment variables are used. 132038494Sobrien.SH FILES 132138494Sobrien.B /tmp/expn$$ 1322119679Smbr.B temporary file used as input to 132338494Sobrien.BR nslookup . 132438494Sobrien.SH SEE ALSO 1325119679Smbr.BR aliases (5), 132638494Sobrien.BR sendmail (8), 132738494Sobrien.BR nslookup (8), 132838494SobrienRFC 823, and RFC 1123. 132938494Sobrien.SH BUGS 1330119679SmbrNot all mail daemons will implement 133138494Sobrien.B expn 133238494Sobrienor 133338494Sobrien.BR vrfy . 133438494SobrienIt is not possible to verify addresses that are served 133538494Sobrienby such daemons. 133638494Sobrien.LP 133738494SobrienWhen attempting to connect to a system to verify an address, 133838494Sobrien.B expn 133938494Sobrienonly tries one IP address. Most mail daemons 134038494Sobrienwill try harder. 134138494Sobrien.LP 1342119679SmbrIt is assumed that you are running domain names and that 1343119679Smbrthe 1344119679Smbr.BR nslookup (8) 1345119679Smbrprogram is available. If not, 134638494Sobrien.B expn 134738494Sobrienwill not be able to verify many addresses. It will also pause 134838494Sobrienfor a long time unless you change the code where it says 134938494Sobrien.I $have_nslookup = 1 135038494Sobriento read 1351119679Smbr.I $have_nslookup = 135238494Sobrien.IR 0 . 135338494Sobrien.LP 1354119679SmbrLastly, 135538494Sobrien.B expn 135638494Sobriendoes not handle every valid address. If you have an example, 135738494Sobrienplease submit a bug report. 135838494Sobrien.SH CREDITS 135938494SobrienIn 1986 or so, Jon Broome wrote a program of the same name 136038494Sobrienthat did about the same thing. It has since suffered bit rot 136138494Sobrienand Jon Broome has dropped off the face of the earth! 136238494Sobrien(Jon, if you are out there, drop me a line) 136338494Sobrien.SH AVAILABILITY 1364119679SmbrThe latest version of 136538494Sobrien.B expn 136638494Sobrienis available through anonymous ftp at 136738494Sobrien.IR ftp://ftp.idiom.com/pub/muir-programs/expn . 136838494Sobrien.SH AUTHOR 136938494Sobrien.I David Muir Sharnoff\ \ \ \ <muir@idiom.com> 1370