6 # THIS PROGRAM IS ITS OWN MANUAL PAGE. INSTALL IN man & bin.
9 # hardcoded constants, should work fine for BSD-based systems
10 #require 'sys/socket.ph'; # perl 4
13 $SOCK_STREAM = &SOCK_STREAM;
14 $sockaddr = 'S n a4 x8';
16 # system requirements:
17 # must have 'nslookup' and 'hostname' programs.
19 # $Header: /proj/bank/cvsroot/am-utils/scripts/expn.1,v 1.1.1.1 1998/11/05 02:04:58 ezk Exp $
22 # less magic should apply to command-line addresses
23 # less magic should apply to local addresses
24 # add magic to deal with cross-domain cnames
26 # Checklist: (hard addresses)
27 # 250 Kimmo Suominen <"|/usr/local/mh/lib/slocal -user kim"@grendel.tac.nyc.ny.us>
28 # harry@hofmann.cs.Berkeley.EDU -> harry@tenet (.berkeley.edu) [dead]
29 # bks@cs.berkeley.edu -> shiva.CS (.berkeley.edu) [dead]
30 # dan@tc.cornell.edu -> brown@tiberius (.tc.cornell.edu)
32 #############################################################################
34 # Copyright (c) 1993 David Muir Sharnoff
35 # All rights reserved.
37 # Redistribution and use in source and binary forms, with or without
38 # modification, are permitted provided that the following conditions
40 # 1. Redistributions of source code must retain the above copyright
41 # notice, this list of conditions and the following disclaimer.
42 # 2. Redistributions in binary form must reproduce the above copyright
43 # notice, this list of conditions and the following disclaimer in the
44 # documentation and/or other materials provided with the distribution.
45 # 3. All advertising materials mentioning features or use of this software
46 # must display the following acknowledgement:
47 # This product includes software developed by the David Muir Sharnoff.
48 # 4. The name of David Sharnoff may not be used to endorse or promote products
49 # derived from this software without specific prior written permission.
51 # THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND
52 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
53 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
54 # ARE DISCLAIMED. IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE
55 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
56 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
57 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
58 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
59 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
60 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
63 # This copyright notice derrived from material copyrighted by the Regents
64 # of the University of California.
66 # Contributions accepted.
68 #############################################################################
71 # in an effort to not trace each address individually, but rather
72 # ask each server in turn a whole bunch of questions, addresses to
73 # be expanded are queued up.
75 # This means that all accounting w.r.t. an address must be stored in
76 # various arrays. Generally these arrays are indexed by the
77 # string "$addr *** $server" where $addr is the address to be
78 # expanded "foo" or maybe "foo@bar" and $server is the hostname
79 # of the SMTP server to contact.
82 # important global variables:
84 # @hosts : list of servers still to be contacted
85 # $server : name of the current we are currently looking at
86 # @users = $users{@hosts[0]} : addresses to expand at this server
87 # $u = $users[0] : the current address being expanded
88 # $names{"$users[0] *** $server"} : the 'name' associated with the address
89 # $mxbacktrace{"$users[0] *** $server"} : record of mx expansion
90 # $mx_secondary{$server} : other mx relays at the same priority
91 # $domainify_fallback{"$users[0] *** $server"} : alternative names to try
92 # instead of $server if $server doesn't work
93 # $temporary_redirect{"$users[0] *** $server"} : when trying alternates,
94 # temporarily channel all tries along current path
95 # $giveup{$server} : do not bother expanding addresses at $server
102 # S : the socket connection to $server
104 $have_nslookup = 1; # we have the nslookup program
107 $ENV{'PATH'} .= ":/usr/etc" unless $ENV{'PATH'} =~ m,/usr/etc,;
108 $ENV{'PATH'} .= ":/usr/ucb" unless $ENV{'PATH'} =~ m,/usr/ucb,;
111 $0 = "$av0 - running hostname";
112 chop($name = `hostname || uname -n`);
114 $0 = "$av0 - lookup host FQDN and IP addr";
115 ($hostname,$aliases,$type,$len,$thisaddr) = gethostbyname($name);
117 $0 = "$av0 - parsing args";
118 $usage = "Usage: $av0 [-1avwd] user[\@host] [user2[host2] ...]";
120 die $usage if $a eq "-";
121 while ($a =~ s/^(-.*)([1avwd])/$1/) {
122 eval '$'."flag_$2 += 1";
125 die $usage if $a =~ /^-/;
126 &expn(&parse($a,$hostname,undef,1));
130 $vw = $flag_v + $flag_w;
135 die $usage unless @hosts;
138 $validRequirement = 0.8;
139 } elsif ($valid == 2) {
140 $validRequirement = 1.0;
141 } elsif ($valid == 3) {
142 $validRequirement = 0.9;
144 $validRequirement = (1 - (1/($valid-3)));
145 print "validRequirement = $validRequirement\n" if $debug;
149 $0 = "$av0 - building local socket";
150 ($name,$aliases,$proto) = getprotobyname('tcp');
151 ($name,$aliases,$port) = getservbyname($port,'tcp')
152 unless $port =~ /^\d+/;
153 $this = pack($sockaddr, &AF_INET, 0, $thisaddr);
157 $server = shift(@hosts);
158 @users = split(' ',$users{$server});
159 delete $users{$server};
161 # is this server already known to be bad?
162 $0 = "$av0 - looking up $server";
163 if ($giveup{$server}) {
164 &giveup('mx domainify',$giveup{$server});
168 # do we already have an mx record for this host?
169 next HOST if &mxredirect($server,*users);
171 # look it up, or try for an mx.
172 $0 = "$av0 - gethostbyname($server)";
174 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($server);
175 # if we can't get an A record, try for an MX record.
177 &mxlookup(1,$server,"$server: could not resolve name",*users);
181 # get a connection, or look for an mx
182 $0 = "$av0 - socket to $server";
183 $that = pack($sockaddr, &AF_INET, $port, $thataddr);
184 socket(S, &AF_INET, &SOCK_STREAM, $proto)
186 $0 = "$av0 - bind to $server";
188 || die "bind $hostname,0: $!";
189 $0 = "$av0 - connect to $server";
190 print "debug = $debug server = $server\n" if $debug > 8;
191 if (! connect(S, $that) || ($debug == 10 && $server =~ /relay\d.UU.NET$/i)) {
192 $0 = "$av0 - $server: could not connect: $!\n";
194 unless (&mxlookup(0,$server,"$server: could not connect: $!",*users)) {
195 &giveup('mx',"$server: Could not connect: $emsg");
199 select((select(S),$| = 1)[0]); # don't buffer output to S
202 $0 = "$av0 - talking to $server";
203 &alarm("greeting with $server",'');
207 if (/^(\d+)([- ])/) {
209 $0 = "$av0 - bad numeric response from $server";
210 &alarm("giving up after bad response from $server",'');
211 &read_response($2,$watch);
213 print STDERR "$server: NOT 220 greeting: $_"
215 if (&mxlookup(0,$server,"$server: did not respond with a 220 greeting",*users)) {
222 $0 = "$av0 - bad response from $server";
223 print STDERR "$server: NOT 220 greeting: $_"
225 unless (&mxlookup(0,$server,"$server: did not respond with SMTP codes",*users)) {
226 &giveup('',"$server: did not talk SMTP");
231 &alarm("greeting with $server",'');
235 # if this causes problems, remove it
236 $0 = "$av0 - sending helo to $server";
237 &alarm("sending helo to $server","");
238 &ps("helo $hostname");
245 # try the users, one by one
249 $0 = "$av0 - expanding $u [\@$server]";
251 # do we already have a name for this user?
252 $oldname = $names{"$u *** $server"};
254 print &compact($u,$server)." ->\n" if ($verbose && ! $valid);
257 # when running with -a, we delay taking any action
258 # on the results of our query until we have looked
259 # at the complete output. @toFinal stores expansions
260 # that will be final if we take them. @toExpn stores
261 # expnansions that are not final. @isValid keeps
262 # track of our ability to send mail to each of the
270 # ($ecode,@expansion) = &expn_vrfy($u,$server);
271 (@foo) = &expn_vrfy($u,$server);
272 ($ecode,@expansion) = @foo;
274 &giveup('',$ecode,$u);
278 for $s (@expansion) {
280 $0 = "$av0 - parsing $server: $s";
284 if ($s =~ /^[25]51([- ]).*<(.+)>/) {
285 print "$s" if $watch;
286 print "(pretending 250$1<$2>)" if ($debug && $watch);
287 print "\n" if $watch;
292 if ($s =~ /^250([- ])(.+)/) {
293 print "$s\n" if $skipwatch;
294 ($done,$addr) = ($1,$2);
295 ($newhost, $newaddr, $newname) = &parse($addr,$server,$oldname, $#expansion == 0);
296 print "($newhost, $newaddr, $newname) = &parse($addr, $server, $oldname)\n" if $debug;
298 # no expansion is possible w/o a new server to call
300 push(@isValid, &validAddr($newaddr));
301 push(@toFinal,$newaddr,$server,$newname);
303 &verbose(&final($newaddr,$server,$newname));
306 $newmxhost = &mx($newhost,$newaddr);
307 print "$newmxhost = &mx($newhost)\n"
308 if ($debug && $newhost ne $newmxhost);
309 $0 = "$av0 - parsing $newaddr [@$newmxhost]";
310 print "levels = $levels, level{$u *** $server} = ".$level{"$u *** $server"}."\n" if ($debug > 1);
311 # If the new server is the current one,
312 # it would have expanded things for us
313 # if it could have. Mx records must be
314 # followed to compare server names.
315 # We are also done if the recursion
316 # count has been exceeded.
317 if (&trhost($newmxhost) eq &trhost($server) || ($levels && $level{"$u *** $server"} >= $levels)) {
319 push(@isValid, &validAddr($newaddr));
320 push(@toFinal,$newaddr,$newmxhost,$newname);
322 &verbose(&final($newaddr,$newmxhost,$newname));
327 push(@isValid, &validAddr($newaddr));
328 push(@toExpn,$newmxhost,$newaddr,$newname,$level{"$u *** $server"});
330 &verbose(&expn($newmxhost,$newaddr,$newname,$level{"$u *** $server"}));
334 last if ($done eq " ");
337 # 550 is a known code... Should the be
338 # included in -a output? Might be a bug
339 # here. Does it matter? Can assume that
340 # there won't be UNKNOWN USER responses
341 # mixed with valid users?
342 if ($s =~ /^(550)([- ])/) {
344 print STDERR "\@$server:$u ($oldname) USER UNKNOWN\n";
346 &verbose(&final($u,$server,$oldname,"USER UNKNOWN"));
351 # 553 is a known code...
352 if ($s =~ /^(553)([- ])/) {
354 print STDERR "\@$server:$u ($oldname) USER AMBIGUOUS\n";
356 &verbose(&final($u,$server,$oldname,"USER AMBIGUOUS"));
361 # 252 is a known code...
362 if ($s =~ /^(252)([- ])/) {
364 print STDERR "\@$server:$u ($oldname) REFUSED TO VRFY\n";
366 &verbose(&final($u,$server,$oldname,"REFUSED TO VRFY"));
371 &giveup('',"$server: did not grok '$s'",$u);
377 # now we decide if we are going to take these
378 # expansions or roll them back.
380 $avgValid = &average(@isValid);
381 print "avgValid = $avgValid\n" if $debug;
382 if ($avgValid >= $validRequirement) {
383 print &compact($u,$server)." ->\n" if $verbose;
385 &verbose(&expn(splice(@toExpn,0,4)));
388 &verbose(&final(splice(@toFinal,0,3)));
391 print "Tossing some valid to avoid invalid ".&compact($u,$server)."\n" if ($avgValid > 0.0 && ($vw || $debug));
392 print &compact($u,$server)." ->\n" if $verbose;
393 &verbose(&final($u,$server,$newname));
398 &alarm("sending 'quit' to $server",'');
399 $0 = "$av0 - sending 'quit' to $server";
409 $0 = "$av0 - printing final results";
410 print "----------\n" if $vw;
412 for $f (sort @final) {
415 unlink("/tmp/expn$$");
419 # abandon all attempts deliver to $server
420 # register the current addresses as the final ones
423 local($redirect_okay,$reason,$user) = @_;
424 local($us,@so,$nh,@remaining_users);
425 local($pk,$file,$line);
426 ($pk, $file, $line) = caller;
428 $0 = "$av0 - giving up on $server: $reason";
430 # add back a user if we gave up in the middle
432 push(@users,$user) if $user;
434 # don't bother with this system anymore
436 unless ($giveup{$server}) {
437 $giveup{$server} = $reason;
438 print STDERR "$reason\n";
440 print "Giveup at $file:$line!!! redirect okay = $redirect_okay; $reason\n" if $debug;
443 # Before giving up, see if there is a chance that
444 # there is another host to redirect to!
445 # (Kids, don't do this at home! Hacking is a dangerous
446 # crime and you could end up behind bars.)
449 if ($redirect_okay =~ /\bmx\b/) {
450 next if &try_fallback('mx',$u,*server,
452 *already_mx_fellback);
454 if ($redirect_okay =~ /\bdomainify\b/) {
455 next if &try_fallback('domainify',$u,*server,
457 *already_domainify_fellback);
459 push(@remaining_users,$u);
461 @users = @remaining_users;
463 print &compact($u,$server)." ->\n" if ($verbose && $valid && $u);
464 &verbose(&final($u,$server,$names{"$u *** $server"},$reason));
468 # This routine is used only within &giveup. It checks to
469 # see if we really have to giveup or if there is a second
470 # chance because we did something before that can be
473 # %fallback{"$user *** $host"} tracks what is able to fallback
474 # %fellback{"$user *** $host"} tracks what has fallen back
476 # If there is a valid backtrack, then queue up the new possibility
480 local($method,$user,*host,*fall_table,*fellback) = @_;
481 local($us,$fallhost,$oldhost,$ft,$i);
484 print "Fallback table $method:\n";
485 for $i (sort keys %fall_table) {
486 print "\t'$i'\t\t'$fall_table{$i}'\n";
488 print "Fellback table $method:\n";
489 for $i (sort keys %fellback) {
490 print "\t'$i'\t\t'$fellback{$i}'\n";
492 print "U: $user H: $host\n";
495 $us = "$user *** $host";
496 if (defined $fellback{$us}) {
498 # Undo a previous fallback so that we can try again
499 # Nested fallbacks are avoided because they could
500 # lead to infinite loops
502 $fallhost = $fellback{$us};
503 print "Already $method fell back from $us -> \n" if $debug;
504 $us = "$user *** $fallhost";
505 $oldhost = $fallhost;
506 } elsif (($method eq 'mx') && (defined $mxbacktrace{$us}) && (defined $mx_secondary{$mxbacktrace{$us}})) {
507 print "Fallback an MX expansion $us -> \n" if $debug;
508 $oldhost = $mxbacktrace{$us};
510 print "Oldhost($host, $us) = " if $debug;
513 print "$oldhost\n" if $debug;
514 if (((defined $fall_table{$us}) && ($ft = $us)) || ((defined $fall_table{$oldhost}) && ($ft = $oldhost))) {
515 print "$method Fallback = ".$fall_table{$ft}."\n" if $debug;
517 @so = split(' ',$fall_table{$ft});
518 $newhost = shift(@so);
519 print "Falling back ($method) $us -> $newhost (from $oldhost)\n" if $debug;
520 if ($method eq 'mx') {
521 if (! defined ($mxbacktrace{"$user *** $newhost"})) {
522 if (defined $mxbacktrace{"$user *** $oldhost"}) {
523 print "resetting oldhost $oldhost to the original: " if $debug;
524 $oldhost = $mxbacktrace{"$user *** $oldhost"};
525 print "$oldhost\n" if $debug;
527 $mxbacktrace{"$user *** $newhost"} = $oldhost;
528 print "mxbacktrace $user *** $newhost -> $oldhost\n" if $debug;
530 $mx{&trhost($oldhost)} = $newhost;
532 $temporary_redirect{$us} = $newhost;
535 print "Can still $method $us: @so\n" if $debug;
536 $fall_table{$ft} = join(' ',@so);
538 print "No more fallbacks for $us\n" if $debug;
539 delete $fall_table{$ft};
541 if (defined $create_host_backtrack{$us}) {
542 $create_host_backtrack{"$user *** $newhost"}
543 = $create_host_backtrack{$us};
545 $fellback{"$user *** $newhost"} = $oldhost;
546 &expn($newhost,$user,$names{$us},$level{$us});
549 delete $temporary_redirect{$us};
553 # return 1 if you could send mail to the address as is.
557 $res = &do_validAddr($addr);
558 print "validAddr($addr) = $res\n" if $debug;
564 local($urx) = "[-A-Za-z_.0-9+]+";
567 return 0 if ($addr =~ /^\\/);
569 return 1 if ($addr =~ /.\@$urx$/);
571 return 1 if ($addr =~ /^\@$urx\:./);
573 return 1 if ($addr =~ /^$urx!./);
575 return 1 if ($addr =~ /^$urx$/);
577 print "validAddr($addr) = ???\n" if $debug;
580 # Some systems use expn and vrfy interchangeably. Some only
581 # implement one or the other. Some check expn against mailing
582 # lists and vrfy against users. It doesn't appear to be
585 # So, what do we do? We try everything!
588 # Ranking of result codes: good: 250, 251/551, 252, 550, anything else
590 # Ranking of inputs: best: user@host.domain, okay: user
592 # Return value: $error_string, @responses_from_server
595 local($u,$server) = @_;
596 local(@c) = ('expn', 'vrfy');
600 if (($u =~ /(.+)@(.+)/) && (&trhost($2) eq &trhost($server))) {
606 for $try_u (@try_u) {
607 &alarm("${c}'ing $try_u on $server",'',$u);
612 return "$server: lost connection";
614 if ($s !~ /^(\d+)([- ])/) {
615 return "$server: garbled reply to '$c $try_u'";
620 push(@ret,&read_response($2,$debug));
623 if ($1 == 551 || $1 == 251) {
626 push(@ret,&read_response($2,$debug));
629 if ($1 == 252 && ($code == 0 || $code == 550)) {
632 push(@ret,&read_response($2,$watch));
635 if ($1 == 550 && $code == 0) {
638 push(@ret,&read_response($2,$watch));
641 &read_response($2,$watch);
644 return "$server: expn/vrfy not implemented" unless @ret;
647 # sometimes the old parse routine (now parse2) didn't
648 # reject funky addresses.
651 local($oldaddr,$server,$oldname,$one_to_one) = @_;
652 local($newhost, $newaddr, $newname, $um) = &parse2($oldaddr,$server,$oldname,$one_to_one);
653 if ($newaddr =~ m,^["/],) {
654 return (undef, $oldaddr, $newname) if $valid;
655 return (undef, $um, $newname);
657 return ($newhost, $newaddr, $newname);
660 # returns ($new_smtp_server,$new_address,$new_name)
661 # given a response from a SMTP server ($newaddr), the
662 # current host ($server), the old "name" and a flag that
663 # indicates if it is being called during the initial
664 # command line parsing ($parsing_args)
667 local($newaddr,$context_host,$old_name,$parsing_args) = @_;
668 local(@names) = $old_name;
669 local($urx) = "[-A-Za-z_.0-9+]+";
673 # first, separate out the address part.
677 # [NAME] <ADDR [(NAME)]>
678 # [NAME] <[(NAME)] ADDR
683 if ($newaddr =~ /^\<(.*)\>$/) {
684 print "<A:$1>\n" if $debug;
685 ($newaddr) = &trim($1);
686 print "na = $newaddr\n" if $debug;
688 if ($newaddr =~ /^([^\<\>]*)\<([^\<\>]*)\>([^\<\>]*)$/) {
689 # address has a < > pair in it.
690 print "N:$1 <A:$2> N:$3\n" if $debug;
691 ($newaddr) = &trim($2);
692 unshift(@names, &trim($3,$1));
693 print "na = $newaddr\n" if $debug;
695 if ($newaddr =~ /^([^\(\)]*)\(([^\(\)]*)\)([^\(\)]*)$/) {
696 # address has a ( ) pair in it.
697 print "A:$1 (N:$2) A:$3\n" if $debug;
698 unshift(@names,&trim($2));
699 local($f,$l) = (&trim($1),&trim($3));
700 if (($f && $l) || !($f || $l)) {
701 # address looks like:
702 # foo (bar) baz or (bar)
704 print STDERR "Could not parse $newaddr\n" if $vw;
705 return(undef,$newaddr,&firstname(@names));
709 print "newaddr now = $newaddr\n" if $debug;
718 $unmangle = $newaddr;
719 if ($newaddr =~ /^\@($urx)\:(.+)$/) {
720 print "(\@:)" if $debug;
721 # this is a bit of a cheat, but it seems necessary
722 return (&domainify($1,$context_host,$2),$2,&firstname(@names),$unmangle);
724 if ($newaddr =~ /^(.+)\@($urx)$/) {
725 print "(\@)" if $debug;
726 return (&domainify($2,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
729 if ($newaddr =~ /^($urx)\!(.+)$/) {
730 return (&domainify($1,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
732 if ($newaddr =~ /^($urx)$/) {
733 return ($context_host,$newaddr,&firstname(@names),$unmangle);
735 print STDERR "Could not parse $newaddr\n";
737 print "(?)" if $debug;
738 return(undef,$newaddr,&firstname(@names),$unmangle);
740 # return $u (@$server) unless $u includes reference to $server
743 local($u, $server) = @_;
744 local($se) = $server;
746 $se =~ s/(\W)/\\$1/g;
747 $sp = " (\@$server)";
753 # remove empty (spaces don't count) members from an array
761 push(@r,$v) if ($v =~ /\S/);
765 # using the host part of an address, and the server name, add the
766 # servers' domain to the address if it doesn't already have a
767 # domain. Since this sometimes fails, save a back reference so
768 # it can be unrolled.
771 local($host,$domain_host,$u) = @_;
772 local($domain,$newhost);
774 # cut of trailing dots
776 $domain_host =~ s/\.$//;
778 if ($domain_host !~ /\./) {
780 # domain host isn't, keep $host whatever it is
782 print "domainify($host,$domain_host) = $host\n" if $debug;
787 # There are several weird situtations that need to be
788 # accounted for. They have to do with domain relay hosts.
791 # host server "right answer"
793 # shiva.cs cs.berkeley.edu shiva.cs.berkeley.edu
794 # shiva cs.berkeley.edu shiva.cs.berekley.edu
795 # cumulus reed.edu @reed.edu:cumulus.uucp
796 # tiberius tc.cornell.edu tiberius.tc.cornell.edu
798 # The first try must always be to cut the domain part out of
799 # the server and tack it onto the host.
801 # A reasonable second try is to tack the whole server part onto
802 # the host and for each possible repeated element, eliminate
805 # These extra "guesses" get put into the %domainify_fallback
806 # array. They will be used to give addresses a second chance
807 # in the &giveup routine
813 $long = "$host $domain_host";
814 $long =~ tr/A-Z/a-z/;
815 print "long = $long\n" if $debug;
816 if ($long =~ s/^([^ ]+\.)([^ ]+) \2(\.[^ ]+\.[^ ]+)/$1$2$3/) {
817 # matches shiva.cs cs.berkeley.edu and returns shiva.cs.berkeley.edu
818 print "condensed fallback $host $domain_host -> $long\n" if $debug;
819 $fallback{$long} = 9;
824 while ($fh =~ /\./) {
825 print "FALLBACK $host.$fh = 1\n" if $debug > 7;
826 $fallback{"$host.$fh"} = 1;
827 $fh =~ s/^[^\.]+\.//;
830 $fallback{"$host.$domain_host"} = 2;
832 ($domain = $domain_host) =~ s/^[^\.]+//;
833 $fallback{"$host$domain"} = 6
834 if ($domain =~ /\./);
838 # Host is already okay, but let's look for multiple
841 print "domainify($host,$domain_host) = $host\n" if $debug;
842 delete $fallback{$host};
843 $domainify_fallback{"$u *** $host"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
847 $domain = ".$domain_host"
848 if ($domain !~ /\..*\./);
849 $newhost = "$host$domain";
851 $create_host_backtrack{"$u *** $newhost"} = $domain_host;
852 print "domainify($host,$domain_host) = $newhost\n" if $debug;
853 delete $fallback{$newhost};
854 $domainify_fallback{"$u *** $newhost"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
857 print $domainify_fallback{"$u *** $newhost"}
858 if defined($domainify_fallback{"$u *** $newhost"});
863 # return the first non-empty element of an array
870 return $n if $n =~ /\S/;
874 # queue up more addresses to expand
877 local($host,$addr,$name,$level) = @_;
879 $host = &trhost($host);
881 if (($debug > 3) || (defined $giveup{$host})) {
882 unshift(@hosts,$host) unless $users{$host};
884 push(@hosts,$host) unless $users{$host};
886 $users{$host} .= " $addr";
887 $names{"$addr *** $host"} = $name;
888 $level{"$addr *** $host"} = $level + 1;
889 print "expn($host,$addr,$name)\n" if $debug;
892 return &final($addr,'NONE',$name);
895 # compute the numerical average value of an array
906 # print to the server (also to stdout, if -w)
910 print ">>> $p\n" if $watch;
913 # return case-adjusted name for a host (for comparison purposes)
916 # treat foo.bar as an alias for Foo.BAR
918 local($trhost) = $host;
919 $trhost =~ tr/A-Z/a-z/;
920 if ($trhost{$trhost}) {
921 $host = $trhost{$trhost};
923 $trhost{$trhost} = $host;
927 # re-queue users if an mx record dictates a redirect
928 # don't allow a user to be redirected more than once
931 local($server,*users) = @_;
932 local($u,$nserver,@still_there);
934 $nserver = &mx($server);
936 if (&trhost($nserver) ne &trhost($server)) {
937 $0 = "$av0 - mx redirect $server -> $nserver\n";
939 if (defined $mxbacktrace{"$u *** $nserver"}) {
940 push(@still_there,$u);
942 $mxbacktrace{"$u *** $nserver"} = $server;
943 print "mxbacktrace{$u *** $nserver} = $server\n"
945 &expn($nserver,$u,$names{"$u *** $server"});
948 @users = @still_there;
957 # follow mx records, return a hostname
958 # also follow temporary redirections comming from &domainify and
965 if (defined $mx{&trhost($h)} && $h ne $mx{&trhost($h)}) {
966 $0 = "$av0 - mx expand $h";
967 $h = $mx{&trhost($h)};
971 if (defined $temporary_redirect{"$u *** $h"}) {
972 $0 = "$av0 - internal redirect $h";
973 print "Temporary redirect taken $u *** $h -> " if $debug;
974 $h = $temporary_redirect{"$u *** $h"};
975 print "$h\n" if $debug;
979 if (defined $temporary_redirect{"$u *** $htr"}) {
980 $0 = "$av0 - internal redirect $h";
981 print "temporary redirect taken $u *** $h -> " if $debug;
982 $h = $temporary_redirect{"$u *** $htr"};
983 print "$h\n" if $debug;
990 # look up mx records with the name server.
991 # re-queue expansion requests if possible
992 # optionally give up on this host.
995 local($lastchance,$server,$giveup,*users) = @_;
998 local($nh, $pref,$cpref);
1001 local($name,$aliases,$type,$len,$thataddr);
1004 return 1 if &mxredirect($server,*users);
1006 if ((defined $mx{$server}) || (! $have_nslookup)) {
1007 return 0 unless $lastchance;
1008 &giveup('mx domainify',$giveup);
1012 $0 = "$av0 - nslookup of $server";
1013 open(T,">/tmp/expn$$") || die "open > /tmp/expn$$: $!\n";
1014 print T "set querytype=MX\n";
1015 print T "$server\n";
1019 open(NSLOOKUP,"nslookup < /tmp/expn$$ 2>&1 |") || die "open nslookup: $!";
1021 print if ($debug > 2);
1022 if (/mail exchanger = ([-A-Za-z_.0-9+]+)/) {
1024 if (/preference = (\d+)/) {
1026 if ($pref < $cpref) {
1030 $fallback{$pref} .= " $nh";
1034 if (/Non-existent domain/) {
1036 # These addresss are hosed. Kaput! Dead!
1037 # However, if we created the address in the
1038 # first place then there is a chance of
1041 1 while(<NSLOOKUP>);
1043 return 0 unless $lastchance;
1044 &giveup('domainify',"$server: Non-existent domain",undef,1);
1050 unlink("/tmp/expn$$");
1052 $0 = "$o0 - finished mxlookup";
1053 return 0 unless $lastchance;
1054 &giveup('mx domainify',"$server: Could not resolve address");
1058 # provide fallbacks in case $nserver doesn't work out
1059 if (defined $fallback{$cpref}) {
1060 $mx_secondary{$server} = $fallback{$cpref};
1063 $0 = "$av0 - gethostbyname($nserver)";
1064 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($nserver);
1066 unless ($thataddr) {
1068 return 0 unless $lastchance;
1069 &giveup('mx domainify',"$nserver: could not resolve address");
1072 print "MX($server) = $nserver\n" if $debug;
1073 print "$server -> $nserver\n" if $vw && !$debug;
1074 $mx{&trhost($server)} = $nserver;
1075 # redeploy the users
1076 unless (&mxredirect($server,*users)) {
1077 return 0 unless $lastchance;
1078 &giveup('mx domainify',"$nserver: only one level of mx redirect allowed");
1081 $0 = "$o0 - finished mxlookup";
1084 # if mx expansion did not help to resolve an address
1085 # (ie: foo@bar became @baz:foo@bar, then undo the
1087 # this is only used by &final
1090 local(*host,*addr) = @_;
1092 print "looking for mxbacktrace{$addr *** $host}\n"
1094 while (defined $mxbacktrace{"$addr *** $host"}) {
1095 print "Unrolling MX expnasion: \@$host:$addr -> "
1096 if ($debug || $verbose);
1097 $host = $mxbacktrace{"$addr *** $host"};
1098 print "\@$host:$addr\n"
1099 if ($debug || $verbose);
1103 $addr = "\@$host:$addr"
1107 # register a completed expnasion. Make the final address as
1108 # simple as possible.
1111 local($addr,$host,$name,$error) = @_;
1116 if ($error =~ /Non-existent domain/) {
1118 # If we created the domain, then let's undo the
1121 if (defined $create_host_backtrack{"$addr *** $host"}) {
1122 while (defined $create_host_backtrack{"$addr *** $host"}) {
1123 print "Un&domainifying($host) = " if $debug;
1124 $host = $create_host_backtrack{"$addr *** $host"};
1125 print "$host\n" if $debug;
1127 $error = "$host: could not locate";
1130 # If we only want valid addresses, toss out
1134 print STDERR "\@$host:$addr ($name) Non-existent domain\n";
1141 $0 = "$av0 - final parsing of \@$host:$addr";
1142 ($he = $host) =~ s/(\W)/\\$1/g;
1144 # addr does not contain any host
1145 $addr = "$addr@$host";
1146 } elsif ($addr !~ /$he/i) {
1147 # if host part really something else, use the something
1149 if ($addr =~ m/(.*)\@([^\@]+)$/) {
1150 ($au,$ah) = ($1,$2);
1151 print "au = $au ah = $ah\n" if $debug;
1152 if (defined $temporary_redirect{"$addr *** $ah"}) {
1153 $addr = "$au\@".$temporary_redirect{"$addr *** $ah"};
1154 print "Rewrite! to $addr\n" if $debug;
1158 # addr does not contain full host
1160 if ($host =~ /^([^\.]+)(\..+)$/) {
1161 # host part has a . in it - foo.bar
1162 ($hb, $hr) = ($1, $2);
1163 if ($addr =~ /\@([^\.\@]+)$/ && ($1 eq $hb)) {
1164 # addr part has not .
1165 # and matches beginning of
1166 # host part -- tack on a
1170 &mxunroll(*host,*addr)
1174 &mxunroll(*host,*addr)
1178 $addr = "${addr}[\@$host]"
1183 $name = "$name " if $name;
1184 $error = " $error" if $error;
1186 push(@final,"$name<$addr>");
1188 push(@final,"$name<$addr>$error");
1190 "\t$name<$addr>$error\n";
1195 local($alarm_action,$alarm_redirect,$alarm_user) = @_;
1197 $SIG{ALRM} = 'handle_alarm';
1199 # this involves one great big ugly hack.
1200 # the "next HOST" unwinds the stack!
1203 &giveup($alarm_redirect,"Timed out during $alarm_action",$alarm_user);
1207 # read the rest of the current smtp daemon's response (and toss it away)
1210 local($done,$watch) = @_;
1213 while(($done eq "-") && ($s = <S>) && ($s =~ /^\d+([- ])/)) {
1220 # print args if verbose. Return them in any case
1224 print "@tp" if $verbose;
1231 %already_domainify_fellback;
1232 %already_mx_fellback;
1234 ################### BEGIN PERL/TROFF TRANSITION
1241 .\" ############## END PERL/TROFF TRANSITION
1242 .TH EXPN 1 "March 11, 1993"
1245 expn \- recursively expand mail aliases
1253 .IR user [@ hostname ]
1254 .RI [ user [@ hostname ]]...
1261 commands to expand mail aliases.
1262 It will first look up the addresses you provide on the command line.
1263 If those expand into addresses on other systems, it will
1264 connect to the other systems and expand again. It will keep
1265 doing this until no further expansion is possible.
1267 The default output of
1269 can contain many lines which are not valid
1270 email addresses. With the
1272 flag, only expansions that result in legal addresses
1273 are used. Since many mailing lists have an illegal
1274 address or two, the single
1276 address, flag specifies that a few illegal addresses can
1277 be mixed into the results. More
1279 flags vary the ratio. Read the source to track down
1280 the formula. With the
1282 option, you should be able to construct a new mailing
1283 list out of an existing one.
1285 If you wish to limit the number of levels deep that
1287 will recurse as it traces addresses, use the
1291 another level will be traversed. So,
1293 will traverse no more than three levels deep.
1295 The normal mode of operation for
1297 is to do all of its work silently.
1298 The following options make it more verbose.
1299 It is not necessary to make it verbose to see what it is
1300 doing because as it works, it changes its
1302 variable to reflect its current activity.
1303 To see how it is expanding things, the
1305 verbose, flag will cause
1307 to show each address before
1308 and after translation as it works.
1311 watch, flag will cause
1313 to show you its conversations with the mail daemons.
1316 debug, flag will expose many of the inner workings so that
1317 it is possible to eliminate bugs.
1319 No enviroment variables are used.
1323 .B temporary file used as input to
1329 RFC 823, and RFC 1123.
1331 Not all mail daemons will implement
1335 It is not possible to verify addresses that are served
1338 When attempting to connect to a system to verify an address,
1340 only tries one IP address. Most mail daemons
1343 It is assumed that you are running domain names and that
1346 program is available. If not,
1348 will not be able to verify many addresses. It will also pause
1349 for a long time unless you change the code where it says
1350 .I $have_nslookup = 1
1357 does not handle every valid address. If you have an example,
1358 please submit a bug report.
1360 In 1986 or so, Jon Broome wrote a program of the same name
1361 that did about the same thing. It has since suffered bit rot
1362 and Jon Broome has dropped off the face of the earth!
1363 (Jon, if you are out there, drop me a line)
1365 The latest version of
1367 is available through anonymous ftp at
1368 .IR ftp://ftp.idiom.com/pub/muir-programs/expn .
1370 .I David Muir Sharnoff\ \ \ \ <muir@idiom.com>