6 # THIS PROGRAM IS ITS OWN MANUAL PAGE. INSTALL IN man & bin.
12 # system requirements:
13 # must have 'nslookup' and 'hostname' programs.
15 # $OrigHeader: /home/muir/bin/RCS/expn,v 3.11 1997/09/10 08:14:02 muir Exp muir $
18 # less magic should apply to command-line addresses
19 # less magic should apply to local addresses
20 # add magic to deal with cross-domain cnames
21 # disconnect & reconnect after 25 commands to the same sendmail 8.8.* host
23 # Checklist: (hard addresses)
24 # 250 Kimmo Suominen <"|/usr/local/mh/lib/slocal -user kim"@grendel.tac.nyc.ny.us>
25 # harry@hofmann.cs.Berkeley.EDU -> harry@tenet (.berkeley.edu) [dead]
26 # bks@cs.berkeley.edu -> shiva.CS (.berkeley.edu) [dead]
27 # dan@tc.cornell.edu -> brown@tiberius (.tc.cornell.edu)
29 #############################################################################
31 # Copyright (c) 1993 David Muir Sharnoff
32 # All rights reserved.
34 # Redistribution and use in source and binary forms, with or without
35 # modification, are permitted provided that the following conditions
37 # 1. Redistributions of source code must retain the above copyright
38 # notice, this list of conditions and the following disclaimer.
39 # 2. Redistributions in binary form must reproduce the above copyright
40 # notice, this list of conditions and the following disclaimer in the
41 # documentation and/or other materials provided with the distribution.
42 # 3. All advertising materials mentioning features or use of this software
43 # must display the following acknowledgement:
44 # This product includes software developed by the David Muir Sharnoff.
45 # 4. The name of David Sharnoff may not be used to endorse or promote products
46 # derived from this software without specific prior written permission.
48 # THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND
49 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
50 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
51 # ARE DISCLAIMED. IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE
52 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
53 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
54 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
55 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
56 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
57 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
60 # This copyright notice derrived from material copyrighted by the Regents
61 # of the University of California.
63 # Contributions accepted.
65 #############################################################################
68 # in an effort to not trace each address individually, but rather
69 # ask each server in turn a whole bunch of questions, addresses to
70 # be expanded are queued up.
72 # This means that all accounting w.r.t. an address must be stored in
73 # various arrays. Generally these arrays are indexed by the
74 # string "$addr *** $server" where $addr is the address to be
75 # expanded "foo" or maybe "foo@bar" and $server is the hostname
76 # of the SMTP server to contact.
79 # important global variables:
81 # @hosts : list of servers still to be contacted
82 # $server : name of the current we are currently looking at
83 # @users = $users{@hosts[0]} : addresses to expand at this server
84 # $u = $users[0] : the current address being expanded
85 # $names{"$users[0] *** $server"} : the 'name' associated with the address
86 # $mxbacktrace{"$users[0] *** $server"} : record of mx expansion
87 # $mx_secondary{$server} : other mx relays at the same priority
88 # $domainify_fallback{"$users[0] *** $server"} : alternative names to try
89 # instead of $server if $server doesn't work
90 # $temporary_redirect{"$users[0] *** $server"} : when trying alternates,
91 # temporarily channel all tries along current path
92 # $giveup{$server} : do not bother expanding addresses at $server
99 # $S : the socket connection to $server
101 $have_nslookup = 1; # we have the nslookup program
104 $ENV{'PATH'} .= ":/usr/etc" unless $ENV{'PATH'} =~ m,/usr/etc,;
105 $ENV{'PATH'} .= ":/usr/ucb" unless $ENV{'PATH'} =~ m,/usr/ucb,;
108 $0 = "$av0 - running hostname";
109 chop($name = `hostname || uname -n`);
111 $0 = "$av0 - lookup host FQDN and IP addr";
112 ($hostname,$aliases,$type,$len,$thisaddr) = gethostbyname($name);
114 $0 = "$av0 - parsing args";
115 $usage = "Usage: $av0 [-1avwd] user[\@host] [user2[host2] ...]";
117 die $usage if $a eq "-";
118 while ($a =~ s/^(-.*)([1avwd])/$1/) {
119 eval '$'."flag_$2 += 1";
122 die $usage if $a =~ /^-/;
123 &expn(&parse($a,$hostname,undef,1));
127 $vw = $flag_v + $flag_w;
132 die $usage unless @hosts;
135 $validRequirement = 0.8;
136 } elsif ($valid == 2) {
137 $validRequirement = 1.0;
138 } elsif ($valid == 3) {
139 $validRequirement = 0.9;
141 $validRequirement = (1 - (1/($valid-3)));
142 print "validRequirement = $validRequirement\n" if $debug;
148 $server = shift(@hosts);
149 @users = split(' ',$users{$server});
150 delete $users{$server};
152 # is this server already known to be bad?
153 $0 = "$av0 - looking up $server";
154 if ($giveup{$server}) {
155 &giveup('mx domainify',$giveup{$server});
159 # do we already have an mx record for this host?
160 next HOST if &mxredirect($server,*users);
162 # look it up, or try for an mx.
163 $0 = "$av0 - gethostbyname($server)";
165 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($server);
166 # if we can't get an A record, try for an MX record.
168 &mxlookup(1,$server,"$server: could not resolve name",*users);
172 # get a connection, or look for an mx
173 $0 = "$av0 - socket to $server";
175 $S = new IO::Socket::INET (
176 'PeerAddr' => $server,
180 if (! $S || ($debug == 10 && $server =~ /relay\d.UU.NET$/i)) {
181 $0 = "$av0 - $server: could not connect: $!\n";
183 unless (&mxlookup(0,$server,"$server: could not connect: $!",*users)) {
184 &giveup('mx',"$server: Could not connect: $emsg");
191 $0 = "$av0 - talking to $server";
192 &alarm("greeting with $server",'');
196 if (/^(\d+)([- ])/) {
198 $0 = "$av0 - bad numeric response from $server";
199 &alarm("giving up after bad response from $server",'');
200 &read_response($2,$watch);
202 print STDERR "$server: NOT 220 greeting: $_"
204 if (&mxlookup(0,$server,"$server: did not respond with a 220 greeting",*users)) {
211 $0 = "$av0 - bad response from $server";
212 print STDERR "$server: NOT 220 greeting: $_"
214 unless (&mxlookup(0,$server,"$server: did not respond with SMTP codes",*users)) {
215 &giveup('',"$server: did not talk SMTP");
220 &alarm("greeting with $server",'');
224 # if this causes problems, remove it
225 $0 = "$av0 - sending helo to $server";
226 &alarm("sending helo to $server","");
227 &ps("helo $hostname");
234 # try the users, one by one
238 $0 = "$av0 - expanding $u [\@$server]";
240 # do we already have a name for this user?
241 $oldname = $names{"$u *** $server"};
243 print &compact($u,$server)." ->\n" if ($verbose && ! $valid);
246 # when running with -a, we delay taking any action
247 # on the results of our query until we have looked
248 # at the complete output. @toFinal stores expansions
249 # that will be final if we take them. @toExpn stores
250 # expnansions that are not final. @isValid keeps
251 # track of our ability to send mail to each of the
259 # ($ecode,@expansion) = &expn_vrfy($u,$server);
260 (@foo) = &expn_vrfy($u,$server);
261 ($ecode,@expansion) = @foo;
263 &giveup('',$ecode,$u);
267 for $s (@expansion) {
269 $0 = "$av0 - parsing $server: $s";
273 if ($s =~ /^[25]51([- ]).*<(.+)>/) {
274 print "$s" if $watch;
275 print "(pretending 250$1<$2>)" if ($debug && $watch);
276 print "\n" if $watch;
281 if ($s =~ /^250([- ])(.+)/) {
282 print "$s\n" if $skipwatch;
283 ($done,$addr) = ($1,$2);
284 ($newhost, $newaddr, $newname) = &parse($addr,$server,$oldname, $#expansion == 0);
285 print "($newhost, $newaddr, $newname) = &parse($addr, $server, $oldname)\n" if $debug;
287 # no expansion is possible w/o a new server to call
289 push(@isValid, &validAddr($newaddr));
290 push(@toFinal,$newaddr,$server,$newname);
292 &verbose(&final($newaddr,$server,$newname));
295 $newmxhost = &mx($newhost,$newaddr);
296 print "$newmxhost = &mx($newhost)\n"
297 if ($debug && $newhost ne $newmxhost);
298 $0 = "$av0 - parsing $newaddr [@$newmxhost]";
299 print "levels = $levels, level{$u *** $server} = ".$level{"$u *** $server"}."\n" if ($debug > 1);
300 # If the new server is the current one,
301 # it would have expanded things for us
302 # if it could have. Mx records must be
303 # followed to compare server names.
304 # We are also done if the recursion
305 # count has been exceeded.
306 if (&trhost($newmxhost) eq &trhost($server) || ($levels && $level{"$u *** $server"} >= $levels)) {
308 push(@isValid, &validAddr($newaddr));
309 push(@toFinal,$newaddr,$newmxhost,$newname);
311 &verbose(&final($newaddr,$newmxhost,$newname));
316 push(@isValid, &validAddr($newaddr));
317 push(@toExpn,$newmxhost,$newaddr,$newname,$level{"$u *** $server"});
319 &verbose(&expn($newmxhost,$newaddr,$newname,$level{"$u *** $server"}));
323 last if ($done eq " ");
326 # 550 is a known code... Should the be
327 # included in -a output? Might be a bug
328 # here. Does it matter? Can assume that
329 # there won't be UNKNOWN USER responses
330 # mixed with valid users?
331 if ($s =~ /^(550)([- ])/) {
333 print STDERR "\@$server:$u ($oldname) USER UNKNOWN\n";
335 &verbose(&final($u,$server,$oldname,"USER UNKNOWN"));
340 # 553 is a known code...
341 if ($s =~ /^(553)([- ])/) {
343 print STDERR "\@$server:$u ($oldname) USER AMBIGUOUS\n";
345 &verbose(&final($u,$server,$oldname,"USER AMBIGUOUS"));
350 # 252 is a known code...
351 if ($s =~ /^(252)([- ])/) {
353 print STDERR "\@$server:$u ($oldname) REFUSED TO VRFY\n";
355 &verbose(&final($u,$server,$oldname,"REFUSED TO VRFY"));
360 &giveup('',"$server: did not grok '$s'",$u);
366 # now we decide if we are going to take these
367 # expansions or roll them back.
369 $avgValid = &average(@isValid);
370 print "avgValid = $avgValid\n" if $debug;
371 if ($avgValid >= $validRequirement) {
372 print &compact($u,$server)." ->\n" if $verbose;
374 &verbose(&expn(splice(@toExpn,0,4)));
377 &verbose(&final(splice(@toFinal,0,3)));
380 print "Tossing some valid to avoid invalid ".&compact($u,$server)."\n" if ($avgValid > 0.0 && ($vw || $debug));
381 print &compact($u,$server)." ->\n" if $verbose;
382 &verbose(&final($u,$server,$newname));
387 &alarm("sending 'quit' to $server",'');
388 $0 = "$av0 - sending 'quit' to $server";
398 $0 = "$av0 - printing final results";
399 print "----------\n" if $vw;
401 for $f (sort @final) {
404 unlink("/tmp/expn$$");
408 # abandon all attempts deliver to $server
409 # register the current addresses as the final ones
412 local($redirect_okay,$reason,$user) = @_;
413 local($us,@so,$nh,@remaining_users);
414 local($pk,$file,$line);
415 ($pk, $file, $line) = caller;
417 $0 = "$av0 - giving up on $server: $reason";
419 # add back a user if we gave up in the middle
421 push(@users,$user) if $user;
423 # don't bother with this system anymore
425 unless ($giveup{$server}) {
426 $giveup{$server} = $reason;
427 print STDERR "$reason\n";
429 print "Giveup at $file:$line!!! redirect okay = $redirect_okay; $reason\n" if $debug;
432 # Before giving up, see if there is a chance that
433 # there is another host to redirect to!
434 # (Kids, don't do this at home! Hacking is a dangerous
435 # crime and you could end up behind bars.)
438 if ($redirect_okay =~ /\bmx\b/) {
439 next if &try_fallback('mx',$u,*server,
441 *already_mx_fellback);
443 if ($redirect_okay =~ /\bdomainify\b/) {
444 next if &try_fallback('domainify',$u,*server,
446 *already_domainify_fellback);
448 push(@remaining_users,$u);
450 @users = @remaining_users;
452 print &compact($u,$server)." ->\n" if ($verbose && $valid && $u);
453 &verbose(&final($u,$server,$names{"$u *** $server"},$reason));
457 # This routine is used only within &giveup. It checks to
458 # see if we really have to giveup or if there is a second
459 # chance because we did something before that can be
462 # %fallback{"$user *** $host"} tracks what is able to fallback
463 # %fellback{"$user *** $host"} tracks what has fallen back
465 # If there is a valid backtrack, then queue up the new possibility
469 local($method,$user,*host,*fall_table,*fellback) = @_;
470 local($us,$fallhost,$oldhost,$ft,$i);
473 print "Fallback table $method:\n";
474 for $i (sort keys %fall_table) {
475 print "\t'$i'\t\t'$fall_table{$i}'\n";
477 print "Fellback table $method:\n";
478 for $i (sort keys %fellback) {
479 print "\t'$i'\t\t'$fellback{$i}'\n";
481 print "U: $user H: $host\n";
484 $us = "$user *** $host";
485 if (defined $fellback{$us}) {
487 # Undo a previous fallback so that we can try again
488 # Nested fallbacks are avoided because they could
489 # lead to infinite loops
491 $fallhost = $fellback{$us};
492 print "Already $method fell back from $us -> \n" if $debug;
493 $us = "$user *** $fallhost";
494 $oldhost = $fallhost;
495 } elsif (($method eq 'mx') && (defined $mxbacktrace{$us}) && (defined $mx_secondary{$mxbacktrace{$us}})) {
496 print "Fallback an MX expansion $us -> \n" if $debug;
497 $oldhost = $mxbacktrace{$us};
499 print "Oldhost($host, $us) = " if $debug;
502 print "$oldhost\n" if $debug;
503 if (((defined $fall_table{$us}) && ($ft = $us)) || ((defined $fall_table{$oldhost}) && ($ft = $oldhost))) {
504 print "$method Fallback = ".$fall_table{$ft}."\n" if $debug;
506 @so = split(' ',$fall_table{$ft});
507 $newhost = shift(@so);
508 print "Falling back ($method) $us -> $newhost (from $oldhost)\n" if $debug;
509 if ($method eq 'mx') {
510 if (! defined ($mxbacktrace{"$user *** $newhost"})) {
511 if (defined $mxbacktrace{"$user *** $oldhost"}) {
512 print "resetting oldhost $oldhost to the original: " if $debug;
513 $oldhost = $mxbacktrace{"$user *** $oldhost"};
514 print "$oldhost\n" if $debug;
516 $mxbacktrace{"$user *** $newhost"} = $oldhost;
517 print "mxbacktrace $user *** $newhost -> $oldhost\n" if $debug;
519 $mx{&trhost($oldhost)} = $newhost;
521 $temporary_redirect{$us} = $newhost;
524 print "Can still $method $us: @so\n" if $debug;
525 $fall_table{$ft} = join(' ',@so);
527 print "No more fallbacks for $us\n" if $debug;
528 delete $fall_table{$ft};
530 if (defined $create_host_backtrack{$us}) {
531 $create_host_backtrack{"$user *** $newhost"}
532 = $create_host_backtrack{$us};
534 $fellback{"$user *** $newhost"} = $oldhost;
535 &expn($newhost,$user,$names{$us},$level{$us});
538 delete $temporary_redirect{$us};
542 # return 1 if you could send mail to the address as is.
546 $res = &do_validAddr($addr);
547 print "validAddr($addr) = $res\n" if $debug;
553 local($urx) = "[-A-Za-z_.0-9+]+";
556 return 0 if ($addr =~ /^\\/);
558 return 1 if ($addr =~ /.\@$urx$/);
560 return 1 if ($addr =~ /^\@$urx\:./);
562 return 1 if ($addr =~ /^$urx!./);
564 return 1 if ($addr =~ /^$urx$/);
566 print "validAddr($addr) = ???\n" if $debug;
569 # Some systems use expn and vrfy interchangeably. Some only
570 # implement one or the other. Some check expn against mailing
571 # lists and vrfy against users. It doesn't appear to be
574 # So, what do we do? We try everything!
577 # Ranking of result codes: good: 250, 251/551, 252, 550, anything else
579 # Ranking of inputs: best: user@host.domain, okay: user
581 # Return value: $error_string, @responses_from_server
584 local($u,$server) = @_;
585 local(@c) = ('expn', 'vrfy');
589 if (($u =~ /(.+)@(.+)/) && (&trhost($2) eq &trhost($server))) {
595 for $try_u (@try_u) {
596 &alarm("${c}'ing $try_u on $server",'',$u);
601 return "$server: lost connection";
603 if ($s !~ /^(\d+)([- ])/) {
604 return "$server: garbled reply to '$c $try_u'";
609 push(@ret,&read_response($2,$debug));
612 if ($1 == 551 || $1 == 251) {
615 push(@ret,&read_response($2,$debug));
618 if ($1 == 252 && ($code == 0 || $code == 550)) {
621 push(@ret,&read_response($2,$watch));
624 if ($1 == 550 && $code == 0) {
627 push(@ret,&read_response($2,$watch));
630 &read_response($2,$watch);
633 return "$server: expn/vrfy not implemented" unless @ret;
636 # sometimes the old parse routine (now parse2) didn't
637 # reject funky addresses.
640 local($oldaddr,$server,$oldname,$one_to_one) = @_;
641 local($newhost, $newaddr, $newname, $um) = &parse2($oldaddr,$server,$oldname,$one_to_one);
642 if ($newaddr =~ m,^["/],) {
643 return (undef, $oldaddr, $newname) if $valid;
644 return (undef, $um, $newname);
646 return ($newhost, $newaddr, $newname);
649 # returns ($new_smtp_server,$new_address,$new_name)
650 # given a response from a SMTP server ($newaddr), the
651 # current host ($server), the old "name" and a flag that
652 # indicates if it is being called during the initial
653 # command line parsing ($parsing_args)
656 local($newaddr,$context_host,$old_name,$parsing_args) = @_;
657 local(@names) = $old_name;
658 local($urx) = "[-A-Za-z_.0-9+]+";
662 # first, separate out the address part.
666 # [NAME] <ADDR [(NAME)]>
667 # [NAME] <[(NAME)] ADDR
672 if ($newaddr =~ /^\<(.*)\>$/) {
673 print "<A:$1>\n" if $debug;
674 ($newaddr) = &trim($1);
675 print "na = $newaddr\n" if $debug;
677 if ($newaddr =~ /^([^\<\>]*)\<([^\<\>]*)\>([^\<\>]*)$/) {
678 # address has a < > pair in it.
679 print "N:$1 <A:$2> N:$3\n" if $debug;
680 ($newaddr) = &trim($2);
681 unshift(@names, &trim($3,$1));
682 print "na = $newaddr\n" if $debug;
684 if ($newaddr =~ /^([^\(\)]*)\(([^\(\)]*)\)([^\(\)]*)$/) {
685 # address has a ( ) pair in it.
686 print "A:$1 (N:$2) A:$3\n" if $debug;
687 unshift(@names,&trim($2));
688 local($f,$l) = (&trim($1),&trim($3));
689 if (($f && $l) || !($f || $l)) {
690 # address looks like:
691 # foo (bar) baz or (bar)
693 print STDERR "Could not parse $newaddr\n" if $vw;
694 return(undef,$newaddr,&firstname(@names));
698 print "newaddr now = $newaddr\n" if $debug;
707 $unmangle = $newaddr;
708 if ($newaddr =~ /^\@($urx)\:(.+)$/) {
709 print "(\@:)" if $debug;
710 # this is a bit of a cheat, but it seems necessary
711 return (&domainify($1,$context_host,$2),$2,&firstname(@names),$unmangle);
713 if ($newaddr =~ /^(.+)\@($urx)$/) {
714 print "(\@)" if $debug;
715 return (&domainify($2,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
718 if ($newaddr =~ /^($urx)\!(.+)$/) {
719 return (&domainify($1,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
721 if ($newaddr =~ /^($urx)$/) {
722 return ($context_host,$newaddr,&firstname(@names),$unmangle);
724 print STDERR "Could not parse $newaddr\n";
726 print "(?)" if $debug;
727 return(undef,$newaddr,&firstname(@names),$unmangle);
729 # return $u (@$server) unless $u includes reference to $server
732 local($u, $server) = @_;
733 local($se) = $server;
735 $se =~ s/(\W)/\\$1/g;
736 $sp = " (\@$server)";
742 # remove empty (spaces don't count) members from an array
750 push(@r,$v) if ($v =~ /\S/);
754 # using the host part of an address, and the server name, add the
755 # servers' domain to the address if it doesn't already have a
756 # domain. Since this sometimes fails, save a back reference so
757 # it can be unrolled.
760 local($host,$domain_host,$u) = @_;
761 local($domain,$newhost);
763 # cut of trailing dots
765 $domain_host =~ s/\.$//;
767 if ($domain_host !~ /\./) {
769 # domain host isn't, keep $host whatever it is
771 print "domainify($host,$domain_host) = $host\n" if $debug;
776 # There are several weird situtations that need to be
777 # accounted for. They have to do with domain relay hosts.
780 # host server "right answer"
782 # shiva.cs cs.berkeley.edu shiva.cs.berkeley.edu
783 # shiva cs.berkeley.edu shiva.cs.berekley.edu
784 # cumulus reed.edu @reed.edu:cumulus.uucp
785 # tiberius tc.cornell.edu tiberius.tc.cornell.edu
787 # The first try must always be to cut the domain part out of
788 # the server and tack it onto the host.
790 # A reasonable second try is to tack the whole server part onto
791 # the host and for each possible repeated element, eliminate
794 # These extra "guesses" get put into the %domainify_fallback
795 # array. They will be used to give addresses a second chance
796 # in the &giveup routine
802 $long = "$host $domain_host";
803 $long =~ tr/A-Z/a-z/;
804 print "long = $long\n" if $debug;
805 if ($long =~ s/^([^ ]+\.)([^ ]+) \2(\.[^ ]+\.[^ ]+)/$1$2$3/) {
806 # matches shiva.cs cs.berkeley.edu and returns shiva.cs.berkeley.edu
807 print "condensed fallback $host $domain_host -> $long\n" if $debug;
808 $fallback{$long} = 9;
813 while ($fh =~ /\./) {
814 print "FALLBACK $host.$fh = 1\n" if $debug > 7;
815 $fallback{"$host.$fh"} = 1;
816 $fh =~ s/^[^\.]+\.//;
819 $fallback{"$host.$domain_host"} = 2;
821 ($domain = $domain_host) =~ s/^[^\.]+//;
822 $fallback{"$host$domain"} = 6
823 if ($domain =~ /\./);
827 # Host is already okay, but let's look for multiple
830 print "domainify($host,$domain_host) = $host\n" if $debug;
831 delete $fallback{$host};
832 $domainify_fallback{"$u *** $host"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
836 $domain = ".$domain_host"
837 if ($domain !~ /\..*\./);
838 $newhost = "$host$domain";
840 $create_host_backtrack{"$u *** $newhost"} = $domain_host;
841 print "domainify($host,$domain_host) = $newhost\n" if $debug;
842 delete $fallback{$newhost};
843 $domainify_fallback{"$u *** $newhost"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
846 print $domainify_fallback{"$u *** $newhost"}
847 if defined($domainify_fallback{"$u *** $newhost"});
852 # return the first non-empty element of an array
859 return $n if $n =~ /\S/;
863 # queue up more addresses to expand
866 local($host,$addr,$name,$level) = @_;
868 $host = &trhost($host);
870 if (($debug > 3) || (defined $giveup{$host})) {
871 unshift(@hosts,$host) unless $users{$host};
873 push(@hosts,$host) unless $users{$host};
875 $users{$host} .= " $addr";
876 $names{"$addr *** $host"} = $name;
877 $level{"$addr *** $host"} = $level + 1;
878 print "expn($host,$addr,$name)\n" if $debug;
881 return &final($addr,'NONE',$name);
884 # compute the numerical average value of an array
895 # print to the server (also to stdout, if -w)
899 print ">>> $p\n" if $watch;
902 # return case-adjusted name for a host (for comparison purposes)
905 # treat foo.bar as an alias for Foo.BAR
907 local($trhost) = $host;
908 $trhost =~ tr/A-Z/a-z/;
909 if ($trhost{$trhost}) {
910 $host = $trhost{$trhost};
912 $trhost{$trhost} = $host;
916 # re-queue users if an mx record dictates a redirect
917 # don't allow a user to be redirected more than once
920 local($server,*users) = @_;
921 local($u,$nserver,@still_there);
923 $nserver = &mx($server);
925 if (&trhost($nserver) ne &trhost($server)) {
926 $0 = "$av0 - mx redirect $server -> $nserver\n";
928 if (defined $mxbacktrace{"$u *** $nserver"}) {
929 push(@still_there,$u);
931 $mxbacktrace{"$u *** $nserver"} = $server;
932 print "mxbacktrace{$u *** $nserver} = $server\n"
934 &expn($nserver,$u,$names{"$u *** $server"});
937 @users = @still_there;
946 # follow mx records, return a hostname
947 # also follow temporary redirections comming from &domainify and
954 if (defined $mx{&trhost($h)} && $h ne $mx{&trhost($h)}) {
955 $0 = "$av0 - mx expand $h";
956 $h = $mx{&trhost($h)};
960 if (defined $temporary_redirect{"$u *** $h"}) {
961 $0 = "$av0 - internal redirect $h";
962 print "Temporary redirect taken $u *** $h -> " if $debug;
963 $h = $temporary_redirect{"$u *** $h"};
964 print "$h\n" if $debug;
968 if (defined $temporary_redirect{"$u *** $htr"}) {
969 $0 = "$av0 - internal redirect $h";
970 print "temporary redirect taken $u *** $h -> " if $debug;
971 $h = $temporary_redirect{"$u *** $htr"};
972 print "$h\n" if $debug;
979 # look up mx records with the name server.
980 # re-queue expansion requests if possible
981 # optionally give up on this host.
984 local($lastchance,$server,$giveup,*users) = @_;
987 local($nh, $pref,$cpref);
990 local($name,$aliases,$type,$len,$thataddr);
993 return 1 if &mxredirect($server,*users);
995 if ((defined $mx{$server}) || (! $have_nslookup)) {
996 return 0 unless $lastchance;
997 &giveup('mx domainify',$giveup);
1001 $0 = "$av0 - nslookup of $server";
1002 open(T,">/tmp/expn$$") || die "open > /tmp/expn$$: $!\n";
1003 print T "set querytype=MX\n";
1004 print T "$server\n";
1008 open(NSLOOKUP,"nslookup < /tmp/expn$$ 2>&1 |") || die "open nslookup: $!";
1010 print if ($debug > 2);
1011 if (/mail exchanger = ([-A-Za-z_.0-9+]+)/) {
1013 if (/preference = (\d+)/) {
1015 if ($pref < $cpref) {
1019 $fallback{$pref} .= " $nh";
1023 if (/Non-existent domain/) {
1025 # These addresss are hosed. Kaput! Dead!
1026 # However, if we created the address in the
1027 # first place then there is a chance of
1030 1 while(<NSLOOKUP>);
1032 return 0 unless $lastchance;
1033 &giveup('domainify',"$server: Non-existent domain",undef,1);
1039 unlink("/tmp/expn$$");
1041 $0 = "$o0 - finished mxlookup";
1042 return 0 unless $lastchance;
1043 &giveup('mx domainify',"$server: Could not resolve address");
1047 # provide fallbacks in case $nserver doesn't work out
1048 if (defined $fallback{$cpref}) {
1049 $mx_secondary{$server} = $fallback{$cpref};
1052 $0 = "$av0 - gethostbyname($nserver)";
1053 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($nserver);
1055 unless ($thataddr) {
1057 return 0 unless $lastchance;
1058 &giveup('mx domainify',"$nserver: could not resolve address");
1061 print "MX($server) = $nserver\n" if $debug;
1062 print "$server -> $nserver\n" if $vw && !$debug;
1063 $mx{&trhost($server)} = $nserver;
1064 # redeploy the users
1065 unless (&mxredirect($server,*users)) {
1066 return 0 unless $lastchance;
1067 &giveup('mx domainify',"$nserver: only one level of mx redirect allowed");
1070 $0 = "$o0 - finished mxlookup";
1073 # if mx expansion did not help to resolve an address
1074 # (ie: foo@bar became @baz:foo@bar, then undo the
1076 # this is only used by &final
1079 local(*host,*addr) = @_;
1081 print "looking for mxbacktrace{$addr *** $host}\n"
1083 while (defined $mxbacktrace{"$addr *** $host"}) {
1084 print "Unrolling MX expnasion: \@$host:$addr -> "
1085 if ($debug || $verbose);
1086 $host = $mxbacktrace{"$addr *** $host"};
1087 print "\@$host:$addr\n"
1088 if ($debug || $verbose);
1092 $addr = "\@$host:$addr"
1096 # register a completed expnasion. Make the final address as
1097 # simple as possible.
1100 local($addr,$host,$name,$error) = @_;
1105 if ($error =~ /Non-existent domain/) {
1107 # If we created the domain, then let's undo the
1110 if (defined $create_host_backtrack{"$addr *** $host"}) {
1111 while (defined $create_host_backtrack{"$addr *** $host"}) {
1112 print "Un&domainifying($host) = " if $debug;
1113 $host = $create_host_backtrack{"$addr *** $host"};
1114 print "$host\n" if $debug;
1116 $error = "$host: could not locate";
1119 # If we only want valid addresses, toss out
1123 print STDERR "\@$host:$addr ($name) Non-existent domain\n";
1130 $0 = "$av0 - final parsing of \@$host:$addr";
1131 ($he = $host) =~ s/(\W)/\\$1/g;
1133 # addr does not contain any host
1134 $addr = "$addr@$host";
1135 } elsif ($addr !~ /$he/i) {
1136 # if host part really something else, use the something
1138 if ($addr =~ m/(.*)\@([^\@]+)$/) {
1139 ($au,$ah) = ($1,$2);
1140 print "au = $au ah = $ah\n" if $debug;
1141 if (defined $temporary_redirect{"$addr *** $ah"}) {
1142 $addr = "$au\@".$temporary_redirect{"$addr *** $ah"};
1143 print "Rewrite! to $addr\n" if $debug;
1147 # addr does not contain full host
1149 if ($host =~ /^([^\.]+)(\..+)$/) {
1150 # host part has a . in it - foo.bar
1151 ($hb, $hr) = ($1, $2);
1152 if ($addr =~ /\@([^\.\@]+)$/ && ($1 eq $hb)) {
1153 # addr part has not .
1154 # and matches beginning of
1155 # host part -- tack on a
1159 &mxunroll(*host,*addr)
1163 &mxunroll(*host,*addr)
1167 $addr = "${addr}[\@$host]"
1172 $name = "$name " if $name;
1173 $error = " $error" if $error;
1175 push(@final,"$name<$addr>");
1177 push(@final,"$name<$addr>$error");
1179 "\t$name<$addr>$error\n";
1184 local($alarm_action,$alarm_redirect,$alarm_user) = @_;
1186 $SIG{ALRM} = 'handle_alarm';
1188 # this involves one great big ugly hack.
1189 # the "next HOST" unwinds the stack!
1192 &giveup($alarm_redirect,"Timed out during $alarm_action",$alarm_user);
1196 # read the rest of the current smtp daemon's response (and toss it away)
1199 local($done,$watch) = @_;
1202 while(($done eq "-") && ($s = <$S>) && ($s =~ /^\d+([- ])/)) {
1209 # print args if verbose. Return them in any case
1213 print "@tp" if $verbose;
1220 %already_domainify_fellback;
1221 %already_mx_fellback;
1223 ################### BEGIN PERL/TROFF TRANSITION
1230 .\" ############## END PERL/TROFF TRANSITION
1231 .TH EXPN 1 "March 11, 1993"
1234 expn \- recursively expand mail aliases
1242 .IR user [@ hostname ]
1243 .RI [ user [@ hostname ]]...
1250 commands to expand mail aliases.
1251 It will first look up the addresses you provide on the command line.
1252 If those expand into addresses on other systems, it will
1253 connect to the other systems and expand again. It will keep
1254 doing this until no further expansion is possible.
1256 The default output of
1258 can contain many lines which are not valid
1259 email addresses. With the
1261 flag, only expansions that result in legal addresses
1262 are used. Since many mailing lists have an illegal
1263 address or two, the single
1265 address, flag specifies that a few illegal addresses can
1266 be mixed into the results. More
1268 flags vary the ratio. Read the source to track down
1269 the formula. With the
1271 option, you should be able to construct a new mailing
1272 list out of an existing one.
1274 If you wish to limit the number of levels deep that
1276 will recurse as it traces addresses, use the
1280 another level will be traversed. So,
1282 will traverse no more than three levels deep.
1284 The normal mode of operation for
1286 is to do all of its work silently.
1287 The following options make it more verbose.
1288 It is not necessary to make it verbose to see what it is
1289 doing because as it works, it changes its
1291 variable to reflect its current activity.
1292 To see how it is expanding things, the
1294 verbose, flag will cause
1296 to show each address before
1297 and after translation as it works.
1300 watch, flag will cause
1302 to show you its conversations with the mail daemons.
1305 debug, flag will expose many of the inner workings so that
1306 it is possible to eliminate bugs.
1308 No environment variables are used.
1312 .B temporary file used as input to
1318 RFC 823, and RFC 1123.
1320 Not all mail daemons will implement
1324 It is not possible to verify addresses that are served
1327 When attempting to connect to a system to verify an address,
1329 only tries one IP address. Most mail daemons
1332 It is assumed that you are running domain names and that
1335 program is available. If not,
1337 will not be able to verify many addresses. It will also pause
1338 for a long time unless you change the code where it says
1339 .I $have_nslookup = 1
1346 does not handle every valid address. If you have an example,
1347 please submit a bug report.
1349 In 1986 or so, Jon Broome wrote a program of the same name
1350 that did about the same thing. It has since suffered bit rot
1351 and Jon Broome has dropped off the face of the earth!
1352 (Jon, if you are out there, drop me a line)
1354 The latest version of
1356 is available through anonymous ftp at
1357 .IR ftp://ftp.idiom.com/pub/muir-programs/expn .
1359 .I David Muir Sharnoff\ \ \ \ <muir@idiom.com>