expn.pl
上传用户:xu_441
上传日期:2007-01-04
资源大小:1640k
文件大小:36k
- #!/usr/bin/perl
- 'di ';
- 'ds 00 \"';
- 'ig 00 ';
- #
- # THIS PROGRAM IS ITS OWN MANUAL PAGE. INSTALL IN man & bin.
- #
- use 5.001;
- use IO::Socket;
- # system requirements:
- # must have 'nslookup' and 'hostname' programs.
- # $OrigHeader: /home/muir/bin/RCS/expn,v 3.11 1997/09/10 08:14:02 muir Exp muir $
- # TODO:
- # less magic should apply to command-line addresses
- # less magic should apply to local addresses
- # add magic to deal with cross-domain cnames
- # disconnect & reconnect after 25 commands to the same sendmail 8.8.* host
- # Checklist: (hard addresses)
- # 250 Kimmo Suominen <"|/usr/local/mh/lib/slocal -user kim"@grendel.tac.nyc.ny.us>
- # harry@hofmann.cs.Berkeley.EDU -> harry@tenet (.berkeley.edu) [dead]
- # bks@cs.berkeley.edu -> shiva.CS (.berkeley.edu) [dead]
- # dan@tc.cornell.edu -> brown@tiberius (.tc.cornell.edu)
- #############################################################################
- #
- # Copyright (c) 1993 David Muir Sharnoff
- # All rights reserved.
- #
- # Redistribution and use in source and binary forms, with or without
- # modification, are permitted provided that the following conditions
- # are met:
- # 1. Redistributions of source code must retain the above copyright
- # notice, this list of conditions and the following disclaimer.
- # 2. Redistributions in binary form must reproduce the above copyright
- # notice, this list of conditions and the following disclaimer in the
- # documentation and/or other materials provided with the distribution.
- # 3. All advertising materials mentioning features or use of this software
- # must display the following acknowledgement:
- # This product includes software developed by the David Muir Sharnoff.
- # 4. The name of David Sharnoff may not be used to endorse or promote products
- # derived from this software without specific prior written permission.
- #
- # THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND
- # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- # ARE DISCLAIMED. IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE
- # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- # SUCH DAMAGE.
- #
- # This copyright notice derrived from material copyrighted by the Regents
- # of the University of California.
- #
- # Contributions accepted.
- #
- #############################################################################
- # overall structure:
- # in an effort to not trace each address individually, but rather
- # ask each server in turn a whole bunch of questions, addresses to
- # be expanded are queued up.
- #
- # This means that all accounting w.r.t. an address must be stored in
- # various arrays. Generally these arrays are indexed by the
- # string "$addr *** $server" where $addr is the address to be
- # expanded "foo" or maybe "foo@bar" and $server is the hostname
- # of the SMTP server to contact.
- #
- # important global variables:
- #
- # @hosts : list of servers still to be contacted
- # $server : name of the current we are currently looking at
- # @users = $users{@hosts[0]} : addresses to expand at this server
- # $u = $users[0] : the current address being expanded
- # $names{"$users[0] *** $server"} : the 'name' associated with the address
- # $mxbacktrace{"$users[0] *** $server"} : record of mx expansion
- # $mx_secondary{$server} : other mx relays at the same priority
- # $domainify_fallback{"$users[0] *** $server"} : alternative names to try
- # instead of $server if $server doesn't work
- # $temporary_redirect{"$users[0] *** $server"} : when trying alternates,
- # temporarily channel all tries along current path
- # $giveup{$server} : do not bother expanding addresses at $server
- # $verbose : -v
- # $watch : -w
- # $vw : -v or -w
- # $debug : -d
- # $valid : -a
- # $levels : -1
- # $S : the socket connection to $server
- $have_nslookup = 1; # we have the nslookup program
- $port = 'smtp';
- $av0 = $0;
- $ENV{'PATH'} .= ":/usr/etc" unless $ENV{'PATH'} =~ m,/usr/etc,;
- $ENV{'PATH'} .= ":/usr/ucb" unless $ENV{'PATH'} =~ m,/usr/ucb,;
- select(STDERR);
- $0 = "$av0 - running hostname";
- chop($name = `hostname || uname -n`);
- $0 = "$av0 - lookup host FQDN and IP addr";
- ($hostname,$aliases,$type,$len,$thisaddr) = gethostbyname($name);
- $0 = "$av0 - parsing args";
- $usage = "Usage: $av0 [-1avwd] user[@host] [user2[host2] ...]";
- for $a (@ARGV) {
- die $usage if $a eq "-";
- while ($a =~ s/^(-.*)([1avwd])/$1/) {
- eval '$'."flag_$2 += 1";
- }
- next if $a eq "-";
- die $usage if $a =~ /^-/;
- &expn(&parse($a,$hostname,undef,1));
- }
- $verbose = $flag_v;
- $watch = $flag_w;
- $vw = $flag_v + $flag_w;
- $debug = $flag_d;
- $valid = $flag_a;
- $levels = $flag_1;
- die $usage unless @hosts;
- if ($valid) {
- if ($valid == 1) {
- $validRequirement = 0.8;
- } elsif ($valid == 2) {
- $validRequirement = 1.0;
- } elsif ($valid == 3) {
- $validRequirement = 0.9;
- } else {
- $validRequirement = (1 - (1/($valid-3)));
- print "validRequirement = $validRequirementn" if $debug;
- }
- }
- HOST:
- while (@hosts) {
- $server = shift(@hosts);
- @users = split(' ',$users{$server});
- delete $users{$server};
- # is this server already known to be bad?
- $0 = "$av0 - looking up $server";
- if ($giveup{$server}) {
- &giveup('mx domainify',$giveup{$server});
- next;
- }
- # do we already have an mx record for this host?
- next HOST if &mxredirect($server,*users);
- # look it up, or try for an mx.
- $0 = "$av0 - gethostbyname($server)";
- ($name,$aliases,$type,$len,$thataddr) = gethostbyname($server);
- # if we can't get an A record, try for an MX record.
- unless($thataddr) {
- &mxlookup(1,$server,"$server: could not resolve name",*users);
- next HOST;
- }
-
- # get a connection, or look for an mx
- $0 = "$av0 - socket to $server";
- $S = new IO::Socket::INET (
- 'PeerAddr' => $server,
- 'PeerPort' => $port,
- 'Proto' => 'tcp');
- if (! $S || ($debug == 10 && $server =~ /relayd.UU.NET$/i)) {
- $0 = "$av0 - $server: could not connect: $!n";
- $emsg = $!;
- unless (&mxlookup(0,$server,"$server: could not connect: $!",*users)) {
- &giveup('mx',"$server: Could not connect: $emsg");
- }
- next HOST;
- }
- $S->autoflush(1);
- # read the greeting
- $0 = "$av0 - talking to $server";
- &alarm("greeting with $server",'');
- while(<$S>) {
- alarm(0);
- print if $watch;
- if (/^(d+)([- ])/) {
- if ($1 != 220) {
- $0 = "$av0 - bad numeric response from $server";
- &alarm("giving up after bad response from $server",'');
- &read_response($2,$watch);
- alarm(0);
- print STDERR "$server: NOT 220 greeting: $_"
- if ($debug || $vw);
- if (&mxlookup(0,$server,"$server: did not respond with a 220 greeting",*users)) {
- close($S);
- next HOST;
- }
- }
- last if ($2 eq " ");
- } else {
- $0 = "$av0 - bad response from $server";
- print STDERR "$server: NOT 220 greeting: $_"
- if ($debug || $vw);
- unless (&mxlookup(0,$server,"$server: did not respond with SMTP codes",*users)) {
- &giveup('',"$server: did not talk SMTP");
- }
- close($S);
- next HOST;
- }
- &alarm("greeting with $server",'');
- }
- alarm(0);
-
- # if this causes problems, remove it
- $0 = "$av0 - sending helo to $server";
- &alarm("sending helo to $server","");
- &ps("helo $hostname");
- while(<$S>) {
- print if $watch;
- last if /^d+ /;
- }
- alarm(0);
- # try the users, one by one
- USER:
- while(@users) {
- $u = shift(@users);
- $0 = "$av0 - expanding $u [@$server]";
- # do we already have a name for this user?
- $oldname = $names{"$u *** $server"};
- print &compact($u,$server)." ->n" if ($verbose && ! $valid);
- if ($valid) {
- #
- # when running with -a, we delay taking any action
- # on the results of our query until we have looked
- # at the complete output. @toFinal stores expansions
- # that will be final if we take them. @toExpn stores
- # expnansions that are not final. @isValid keeps
- # track of our ability to send mail to each of the
- # expansions.
- #
- @isValid = ();
- @toFinal = ();
- @toExpn = ();
- }
- # ($ecode,@expansion) = &expn_vrfy($u,$server);
- (@foo) = &expn_vrfy($u,$server);
- ($ecode,@expansion) = @foo;
- if ($ecode) {
- &giveup('',$ecode,$u);
- last USER;
- }
- for $s (@expansion) {
- $s =~ s/[nr]//g;
- $0 = "$av0 - parsing $server: $s";
- $skipwatch = $watch;
- if ($s =~ /^[25]51([- ]).*<(.+)>/) {
- print "$s" if $watch;
- print "(pretending 250$1<$2>)" if ($debug && $watch);
- print "n" if $watch;
- $s = "250$1<$2>";
- $skipwatch = 0;
- }
- if ($s =~ /^250([- ])(.+)/) {
- print "$sn" if $skipwatch;
- ($done,$addr) = ($1,$2);
- ($newhost, $newaddr, $newname) = &parse($addr,$server,$oldname, $#expansion == 0);
- print "($newhost, $newaddr, $newname) = &parse($addr, $server, $oldname)n" if $debug;
- if (! $newhost) {
- # no expansion is possible w/o a new server to call
- if ($valid) {
- push(@isValid, &validAddr($newaddr));
- push(@toFinal,$newaddr,$server,$newname);
- } else {
- &verbose(&final($newaddr,$server,$newname));
- }
- } else {
- $newmxhost = &mx($newhost,$newaddr);
- print "$newmxhost = &mx($newhost)n"
- if ($debug && $newhost ne $newmxhost);
- $0 = "$av0 - parsing $newaddr [@$newmxhost]";
- print "levels = $levels, level{$u *** $server} = ".$level{"$u *** $server"}."n" if ($debug > 1);
- # If the new server is the current one,
- # it would have expanded things for us
- # if it could have. Mx records must be
- # followed to compare server names.
- # We are also done if the recursion
- # count has been exceeded.
- if (&trhost($newmxhost) eq &trhost($server) || ($levels && $level{"$u *** $server"} >= $levels)) {
- if ($valid) {
- push(@isValid, &validAddr($newaddr));
- push(@toFinal,$newaddr,$newmxhost,$newname);
- } else {
- &verbose(&final($newaddr,$newmxhost,$newname));
- }
- } else {
- # more work to do...
- if ($valid) {
- push(@isValid, &validAddr($newaddr));
- push(@toExpn,$newmxhost,$newaddr,$newname,$level{"$u *** $server"});
- } else {
- &verbose(&expn($newmxhost,$newaddr,$newname,$level{"$u *** $server"}));
- }
- }
- }
- last if ($done eq " ");
- next;
- }
- # 550 is a known code... Should the be
- # included in -a output? Might be a bug
- # here. Does it matter? Can assume that
- # there won't be UNKNOWN USER responses
- # mixed with valid users?
- if ($s =~ /^(550)([- ])/) {
- if ($valid) {
- print STDERR "@$server:$u ($oldname) USER UNKNOWNn";
- } else {
- &verbose(&final($u,$server,$oldname,"USER UNKNOWN"));
- }
- last if ($2 eq " ");
- next;
- }
- # 553 is a known code...
- if ($s =~ /^(553)([- ])/) {
- if ($valid) {
- print STDERR "@$server:$u ($oldname) USER AMBIGUOUSn";
- } else {
- &verbose(&final($u,$server,$oldname,"USER AMBIGUOUS"));
- }
- last if ($2 eq " ");
- next;
- }
- # 252 is a known code...
- if ($s =~ /^(252)([- ])/) {
- if ($valid) {
- print STDERR "@$server:$u ($oldname) REFUSED TO VRFYn";
- } else {
- &verbose(&final($u,$server,$oldname,"REFUSED TO VRFY"));
- }
- last if ($2 eq " ");
- next;
- }
- &giveup('',"$server: did not grok '$s'",$u);
- last USER;
- }
- if ($valid) {
- #
- # now we decide if we are going to take these
- # expansions or roll them back.
- #
- $avgValid = &average(@isValid);
- print "avgValid = $avgValidn" if $debug;
- if ($avgValid >= $validRequirement) {
- print &compact($u,$server)." ->n" if $verbose;
- while (@toExpn) {
- &verbose(&expn(splice(@toExpn,0,4)));
- }
- while (@toFinal) {
- &verbose(&final(splice(@toFinal,0,3)));
- }
- } else {
- print "Tossing some valid to avoid invalid ".&compact($u,$server)."n" if ($avgValid > 0.0 && ($vw || $debug));
- print &compact($u,$server)." ->n" if $verbose;
- &verbose(&final($u,$server,$newname));
- }
- }
- }
- &alarm("sending 'quit' to $server",'');
- $0 = "$av0 - sending 'quit' to $server";
- &ps("quit");
- while(<$S>) {
- print if $watch;
- last if /^d+ /;
- }
- close($S);
- alarm(0);
- }
- $0 = "$av0 - printing final results";
- print "----------n" if $vw;
- select(STDOUT);
- for $f (sort @final) {
- print "$fn";
- }
- unlink("/tmp/expn$$");
- exit(0);
- # abandon all attempts deliver to $server
- # register the current addresses as the final ones
- sub giveup
- {
- local($redirect_okay,$reason,$user) = @_;
- local($us,@so,$nh,@remaining_users);
- local($pk,$file,$line);
- ($pk, $file, $line) = caller;
- $0 = "$av0 - giving up on $server: $reason";
- #
- # add back a user if we gave up in the middle
- #
- push(@users,$user) if $user;
- #
- # don't bother with this system anymore
- #
- unless ($giveup{$server}) {
- $giveup{$server} = $reason;
- print STDERR "$reasonn";
- }
- print "Giveup at $file:$line!!! redirect okay = $redirect_okay; $reasonn" if $debug;
- #
- # Wait!
- # Before giving up, see if there is a chance that
- # there is another host to redirect to!
- # (Kids, don't do this at home! Hacking is a dangerous
- # crime and you could end up behind bars.)
- #
- for $u (@users) {
- if ($redirect_okay =~ /bmxb/) {
- next if &try_fallback('mx',$u,*server,
- *mx_secondary,
- *already_mx_fellback);
- }
- if ($redirect_okay =~ /bdomainifyb/) {
- next if &try_fallback('domainify',$u,*server,
- *domainify_fallback,
- *already_domainify_fellback);
- }
- push(@remaining_users,$u);
- }
- @users = @remaining_users;
- for $u (@users) {
- print &compact($u,$server)." ->n" if ($verbose && $valid && $u);
- &verbose(&final($u,$server,$names{"$u *** $server"},$reason));
- }
- }
- #
- # This routine is used only within &giveup. It checks to
- # see if we really have to giveup or if there is a second
- # chance because we did something before that can be
- # backtracked.
- #
- # %fallback{"$user *** $host"} tracks what is able to fallback
- # %fellback{"$user *** $host"} tracks what has fallen back
- #
- # If there is a valid backtrack, then queue up the new possibility
- #
- sub try_fallback
- {
- local($method,$user,*host,*fall_table,*fellback) = @_;
- local($us,$fallhost,$oldhost,$ft,$i);
- if ($debug > 8) {
- print "Fallback table $method:n";
- for $i (sort keys %fall_table) {
- print "t'$i'tt'$fall_table{$i}'n";
- }
- print "Fellback table $method:n";
- for $i (sort keys %fellback) {
- print "t'$i'tt'$fellback{$i}'n";
- }
- print "U: $user H: $hostn";
- }
-
- $us = "$user *** $host";
- if (defined $fellback{$us}) {
- #
- # Undo a previous fallback so that we can try again
- # Nested fallbacks are avoided because they could
- # lead to infinite loops
- #
- $fallhost = $fellback{$us};
- print "Already $method fell back from $us -> n" if $debug;
- $us = "$user *** $fallhost";
- $oldhost = $fallhost;
- } elsif (($method eq 'mx') && (defined $mxbacktrace{$us}) && (defined $mx_secondary{$mxbacktrace{$us}})) {
- print "Fallback an MX expansion $us -> n" if $debug;
- $oldhost = $mxbacktrace{$us};
- } else {
- print "Oldhost($host, $us) = " if $debug;
- $oldhost = $host;
- }
- print "$oldhostn" if $debug;
- if (((defined $fall_table{$us}) && ($ft = $us)) || ((defined $fall_table{$oldhost}) && ($ft = $oldhost))) {
- print "$method Fallback = ".$fall_table{$ft}."n" if $debug;
- local(@so,$newhost);
- @so = split(' ',$fall_table{$ft});
- $newhost = shift(@so);
- print "Falling back ($method) $us -> $newhost (from $oldhost)n" if $debug;
- if ($method eq 'mx') {
- if (! defined ($mxbacktrace{"$user *** $newhost"})) {
- if (defined $mxbacktrace{"$user *** $oldhost"}) {
- print "resetting oldhost $oldhost to the original: " if $debug;
- $oldhost = $mxbacktrace{"$user *** $oldhost"};
- print "$oldhostn" if $debug;
- }
- $mxbacktrace{"$user *** $newhost"} = $oldhost;
- print "mxbacktrace $user *** $newhost -> $oldhostn" if $debug;
- }
- $mx{&trhost($oldhost)} = $newhost;
- } else {
- $temporary_redirect{$us} = $newhost;
- }
- if (@so) {
- print "Can still $method $us: @son" if $debug;
- $fall_table{$ft} = join(' ',@so);
- } else {
- print "No more fallbacks for $usn" if $debug;
- delete $fall_table{$ft};
- }
- if (defined $create_host_backtrack{$us}) {
- $create_host_backtrack{"$user *** $newhost"}
- = $create_host_backtrack{$us};
- }
- $fellback{"$user *** $newhost"} = $oldhost;
- &expn($newhost,$user,$names{$us},$level{$us});
- return 1;
- }
- delete $temporary_redirect{$us};
- $host = $oldhost;
- return 0;
- }
- # return 1 if you could send mail to the address as is.
- sub validAddr
- {
- local($addr) = @_;
- $res = &do_validAddr($addr);
- print "validAddr($addr) = $resn" if $debug;
- $res;
- }
- sub do_validAddr
- {
- local($addr) = @_;
- local($urx) = "[-A-Za-z_.0-9+]+";
- # u
- return 0 if ($addr =~ /^\/);
- # ?@h
- return 1 if ($addr =~ /.@$urx$/);
- # @h:?
- return 1 if ($addr =~ /^@$urx:./);
- # h!u
- return 1 if ($addr =~ /^$urx!./);
- # u
- return 1 if ($addr =~ /^$urx$/);
- # ?
- print "validAddr($addr) = ???n" if $debug;
- return 0;
- }
- # Some systems use expn and vrfy interchangeably. Some only
- # implement one or the other. Some check expn against mailing
- # lists and vrfy against users. It doesn't appear to be
- # consistent.
- #
- # So, what do we do? We try everything!
- #
- #
- # Ranking of result codes: good: 250, 251/551, 252, 550, anything else
- #
- # Ranking of inputs: best: user@host.domain, okay: user
- #
- # Return value: $error_string, @responses_from_server
- sub expn_vrfy
- {
- local($u,$server) = @_;
- local(@c) = ('expn', 'vrfy');
- local(@try_u) = $u;
- local(@ret,$code);
- if (($u =~ /(.+)@(.+)/) && (&trhost($2) eq &trhost($server))) {
- push(@try_u,$1);
- }
- TRY:
- for $c (@c) {
- for $try_u (@try_u) {
- &alarm("${c}'ing $try_u on $server",'',$u);
- &ps("$c $try_u");
- alarm(0);
- $s = <$S>;
- if ($s eq '') {
- return "$server: lost connection";
- }
- if ($s !~ /^(d+)([- ])/) {
- return "$server: garbled reply to '$c $try_u'";
- }
- if ($1 == 250) {
- $code = 250;
- @ret = ("",$s);
- push(@ret,&read_response($2,$debug));
- return (@ret);
- }
- if ($1 == 551 || $1 == 251) {
- $code = $1;
- @ret = ("",$s);
- push(@ret,&read_response($2,$debug));
- next;
- }
- if ($1 == 252 && ($code == 0 || $code == 550)) {
- $code = 252;
- @ret = ("",$s);
- push(@ret,&read_response($2,$watch));
- next;
- }
- if ($1 == 550 && $code == 0) {
- $code = 550;
- @ret = ("",$s);
- push(@ret,&read_response($2,$watch));
- next;
- }
- &read_response($2,$watch);
- }
- }
- return "$server: expn/vrfy not implemented" unless @ret;
- return @ret;
- }
- # sometimes the old parse routine (now parse2) didn't
- # reject funky addresses.
- sub parse
- {
- local($oldaddr,$server,$oldname,$one_to_one) = @_;
- local($newhost, $newaddr, $newname, $um) = &parse2($oldaddr,$server,$oldname,$one_to_one);
- if ($newaddr =~ m,^["/],) {
- return (undef, $oldaddr, $newname) if $valid;
- return (undef, $um, $newname);
- }
- return ($newhost, $newaddr, $newname);
- }
- # returns ($new_smtp_server,$new_address,$new_name)
- # given a response from a SMTP server ($newaddr), the
- # current host ($server), the old "name" and a flag that
- # indicates if it is being called during the initial
- # command line parsing ($parsing_args)
- sub parse2
- {
- local($newaddr,$context_host,$old_name,$parsing_args) = @_;
- local(@names) = $old_name;
- local($urx) = "[-A-Za-z_.0-9+]+";
- local($unmangle);
- #
- # first, separate out the address part.
- #
- #
- # [NAME] <ADDR [(NAME)]>
- # [NAME] <[(NAME)] ADDR
- # ADDR [(NAME)]
- # (NAME) ADDR
- # [(NAME)] <ADDR>
- #
- if ($newaddr =~ /^<(.*)>$/) {
- print "<A:$1>n" if $debug;
- ($newaddr) = &trim($1);
- print "na = $newaddrn" if $debug;
- }
- if ($newaddr =~ /^([^<>]*)<([^<>]*)>([^<>]*)$/) {
- # address has a < > pair in it.
- print "N:$1 <A:$2> N:$3n" if $debug;
- ($newaddr) = &trim($2);
- unshift(@names, &trim($3,$1));
- print "na = $newaddrn" if $debug;
- }
- if ($newaddr =~ /^([^()]*)(([^()]*))([^()]*)$/) {
- # address has a ( ) pair in it.
- print "A:$1 (N:$2) A:$3n" if $debug;
- unshift(@names,&trim($2));
- local($f,$l) = (&trim($1),&trim($3));
- if (($f && $l) || !($f || $l)) {
- # address looks like:
- # foo (bar) baz or (bar)
- # not allowed!
- print STDERR "Could not parse $newaddrn" if $vw;
- return(undef,$newaddr,&firstname(@names));
- }
- $newaddr = $f if $f;
- $newaddr = $l if $l;
- print "newaddr now = $newaddrn" if $debug;
- }
- #
- # @foo:bar
- # j%k@l
- # a@b
- # b!a
- # a
- #
- $unmangle = $newaddr;
- if ($newaddr =~ /^@($urx):(.+)$/) {
- print "(@:)" if $debug;
- # this is a bit of a cheat, but it seems necessary
- return (&domainify($1,$context_host,$2),$2,&firstname(@names),$unmangle);
- }
- if ($newaddr =~ /^(.+)@($urx)$/) {
- print "(@)" if $debug;
- return (&domainify($2,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
- }
- if ($parsing_args) {
- if ($newaddr =~ /^($urx)!(.+)$/) {
- return (&domainify($1,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
- }
- if ($newaddr =~ /^($urx)$/) {
- return ($context_host,$newaddr,&firstname(@names),$unmangle);
- }
- print STDERR "Could not parse $newaddrn";
- }
- print "(?)" if $debug;
- return(undef,$newaddr,&firstname(@names),$unmangle);
- }
- # return $u (@$server) unless $u includes reference to $server
- sub compact
- {
- local($u, $server) = @_;
- local($se) = $server;
- local($sp);
- $se =~ s/(W)/\$1/g;
- $sp = " (@$server)";
- if ($u !~ /$se/i) {
- return "$u$sp";
- }
- return $u;
- }
- # remove empty (spaces don't count) members from an array
- sub trim
- {
- local(@v) = @_;
- local($v,@r);
- for $v (@v) {
- $v =~ s/^s+//;
- $v =~ s/s+$//;
- push(@r,$v) if ($v =~ /S/);
- }
- return(@r);
- }
- # using the host part of an address, and the server name, add the
- # servers' domain to the address if it doesn't already have a
- # domain. Since this sometimes fails, save a back reference so
- # it can be unrolled.
- sub domainify
- {
- local($host,$domain_host,$u) = @_;
- local($domain,$newhost);
- # cut of trailing dots
- $host =~ s/.$//;
- $domain_host =~ s/.$//;
- if ($domain_host !~ /./) {
- #
- # domain host isn't, keep $host whatever it is
- #
- print "domainify($host,$domain_host) = $hostn" if $debug;
- return $host;
- }
- #
- # There are several weird situtations that need to be
- # accounted for. They have to do with domain relay hosts.
- #
- # Examples:
- # host server "right answer"
- #
- # shiva.cs cs.berkeley.edu shiva.cs.berkeley.edu
- # shiva cs.berkeley.edu shiva.cs.berekley.edu
- # cumulus reed.edu @reed.edu:cumulus.uucp
- # tiberius tc.cornell.edu tiberius.tc.cornell.edu
- #
- # The first try must always be to cut the domain part out of
- # the server and tack it onto the host.
- #
- # A reasonable second try is to tack the whole server part onto
- # the host and for each possible repeated element, eliminate
- # just that part.
- #
- # These extra "guesses" get put into the %domainify_fallback
- # array. They will be used to give addresses a second chance
- # in the &giveup routine
- #
- local(%fallback);
- local($long);
- $long = "$host $domain_host";
- $long =~ tr/A-Z/a-z/;
- print "long = $longn" if $debug;
- if ($long =~ s/^([^ ]+.)([^ ]+) 2(.[^ ]+.[^ ]+)/$1$2$3/) {
- # matches shiva.cs cs.berkeley.edu and returns shiva.cs.berkeley.edu
- print "condensed fallback $host $domain_host -> $longn" if $debug;
- $fallback{$long} = 9;
- }
- local($fh);
- $fh = $domain_host;
- while ($fh =~ /./) {
- print "FALLBACK $host.$fh = 1n" if $debug > 7;
- $fallback{"$host.$fh"} = 1;
- $fh =~ s/^[^.]+.//;
- }
- $fallback{"$host.$domain_host"} = 2;
- ($domain = $domain_host) =~ s/^[^.]+//;
- $fallback{"$host$domain"} = 6
- if ($domain =~ /./);
- if ($host =~ /./) {
- #
- # Host is already okay, but let's look for multiple
- # interpretations
- #
- print "domainify($host,$domain_host) = $hostn" if $debug;
- delete $fallback{$host};
- $domainify_fallback{"$u *** $host"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
- return $host;
- }
- $domain = ".$domain_host"
- if ($domain !~ /..*./);
- $newhost = "$host$domain";
- $create_host_backtrack{"$u *** $newhost"} = $domain_host;
- print "domainify($host,$domain_host) = $newhostn" if $debug;
- delete $fallback{$newhost};
- $domainify_fallback{"$u *** $newhost"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
- if ($debug) {
- print "fallback = ";
- print $domainify_fallback{"$u *** $newhost"}
- if defined($domainify_fallback{"$u *** $newhost"});
- print "n";
- }
- return $newhost;
- }
- # return the first non-empty element of an array
- sub firstname
- {
- local(@names) = @_;
- local($n);
- while(@names) {
- $n = shift(@names);
- return $n if $n =~ /S/;
- }
- return undef;
- }
- # queue up more addresses to expand
- sub expn
- {
- local($host,$addr,$name,$level) = @_;
- if ($host) {
- $host = &trhost($host);
- if (($debug > 3) || (defined $giveup{$host})) {
- unshift(@hosts,$host) unless $users{$host};
- } else {
- push(@hosts,$host) unless $users{$host};
- }
- $users{$host} .= " $addr";
- $names{"$addr *** $host"} = $name;
- $level{"$addr *** $host"} = $level + 1;
- print "expn($host,$addr,$name)n" if $debug;
- return "t$addrn";
- } else {
- return &final($addr,'NONE',$name);
- }
- }
- # compute the numerical average value of an array
- sub average
- {
- local(@e) = @_;
- return 0 unless @e;
- local($e,$sum);
- for $e (@e) {
- $sum += $e;
- }
- $sum / @e;
- }
- # print to the server (also to stdout, if -w)
- sub ps
- {
- local($p) = @_;
- print ">>> $pn" if $watch;
- print $S "$pn";
- }
- # return case-adjusted name for a host (for comparison purposes)
- sub trhost
- {
- # treat foo.bar as an alias for Foo.BAR
- local($host) = @_;
- local($trhost) = $host;
- $trhost =~ tr/A-Z/a-z/;
- if ($trhost{$trhost}) {
- $host = $trhost{$trhost};
- } else {
- $trhost{$trhost} = $host;
- }
- $trhost{$trhost};
- }
- # re-queue users if an mx record dictates a redirect
- # don't allow a user to be redirected more than once
- sub mxredirect
- {
- local($server,*users) = @_;
- local($u,$nserver,@still_there);
- $nserver = &mx($server);
- if (&trhost($nserver) ne &trhost($server)) {
- $0 = "$av0 - mx redirect $server -> $nservern";
- for $u (@users) {
- if (defined $mxbacktrace{"$u *** $nserver"}) {
- push(@still_there,$u);
- } else {
- $mxbacktrace{"$u *** $nserver"} = $server;
- print "mxbacktrace{$u *** $nserver} = $servern"
- if ($debug > 1);
- &expn($nserver,$u,$names{"$u *** $server"});
- }
- }
- @users = @still_there;
- if (! @users) {
- return $nserver;
- } else {
- return undef;
- }
- }
- return undef;
- }
- # follow mx records, return a hostname
- # also follow temporary redirections comming from &domainify and
- # &mxlookup
- sub mx
- {
- local($h,$u) = @_;
- for (;;) {
- if (defined $mx{&trhost($h)} && $h ne $mx{&trhost($h)}) {
- $0 = "$av0 - mx expand $h";
- $h = $mx{&trhost($h)};
- return $h;
- }
- if ($u) {
- if (defined $temporary_redirect{"$u *** $h"}) {
- $0 = "$av0 - internal redirect $h";
- print "Temporary redirect taken $u *** $h -> " if $debug;
- $h = $temporary_redirect{"$u *** $h"};
- print "$hn" if $debug;
- next;
- }
- $htr = &trhost($h);
- if (defined $temporary_redirect{"$u *** $htr"}) {
- $0 = "$av0 - internal redirect $h";
- print "temporary redirect taken $u *** $h -> " if $debug;
- $h = $temporary_redirect{"$u *** $htr"};
- print "$hn" if $debug;
- next;
- }
- }
- return $h;
- }
- }
- # look up mx records with the name server.
- # re-queue expansion requests if possible
- # optionally give up on this host.
- sub mxlookup
- {
- local($lastchance,$server,$giveup,*users) = @_;
- local(*T);
- local(*NSLOOKUP);
- local($nh, $pref,$cpref);
- local($o0) = $0;
- local($nserver);
- local($name,$aliases,$type,$len,$thataddr);
- local(%fallback);
- return 1 if &mxredirect($server,*users);
- if ((defined $mx{$server}) || (! $have_nslookup)) {
- return 0 unless $lastchance;
- &giveup('mx domainify',$giveup);
- return 0;
- }
- $0 = "$av0 - nslookup of $server";
- open(T,">/tmp/expn$$") || die "open > /tmp/expn$$: $!n";
- print T "set querytype=MXn";
- print T "$servern";
- close(T);
- $cpref = 1.0E12;
- undef $nserver;
- open(NSLOOKUP,"nslookup < /tmp/expn$$ 2>&1 |") || die "open nslookup: $!";
- while(<NSLOOKUP>) {
- print if ($debug > 2);
- if (/mail exchanger = ([-A-Za-z_.0-9+]+)/) {
- $nh = $1;
- if (/preference = (d+)/) {
- $pref = $1;
- if ($pref < $cpref) {
- $nserver = $nh;
- $cpref = $pref;
- } elsif ($pref) {
- $fallback{$pref} .= " $nh";
- }
- }
- }
- if (/Non-existent domain/) {
- #
- # These addresss are hosed. Kaput! Dead!
- # However, if we created the address in the
- # first place then there is a chance of
- # salvation.
- #
- 1 while(<NSLOOKUP>);
- close(NSLOOKUP);
- return 0 unless $lastchance;
- &giveup('domainify',"$server: Non-existent domain",undef,1);
- return 0;
- }
-
- }
- close(NSLOOKUP);
- unlink("/tmp/expn$$");
- unless ($nserver) {
- $0 = "$o0 - finished mxlookup";
- return 0 unless $lastchance;
- &giveup('mx domainify',"$server: Could not resolve address");
- return 0;
- }
- # provide fallbacks in case $nserver doesn't work out
- if (defined $fallback{$cpref}) {
- $mx_secondary{$server} = $fallback{$cpref};
- }
- $0 = "$av0 - gethostbyname($nserver)";
- ($name,$aliases,$type,$len,$thataddr) = gethostbyname($nserver);
- unless ($thataddr) {
- $0 = $o0;
- return 0 unless $lastchance;
- &giveup('mx domainify',"$nserver: could not resolve address");
- return 0;
- }
- print "MX($server) = $nservern" if $debug;
- print "$server -> $nservern" if $vw && !$debug;
- $mx{&trhost($server)} = $nserver;
- # redeploy the users
- unless (&mxredirect($server,*users)) {
- return 0 unless $lastchance;
- &giveup('mx domainify',"$nserver: only one level of mx redirect allowed");
- return 0;
- }
- $0 = "$o0 - finished mxlookup";
- return 1;
- }
- # if mx expansion did not help to resolve an address
- # (ie: foo@bar became @baz:foo@bar, then undo the
- # expansion).
- # this is only used by &final
- sub mxunroll
- {
- local(*host,*addr) = @_;
- local($r) = 0;
- print "looking for mxbacktrace{$addr *** $host}n"
- if ($debug > 1);
- while (defined $mxbacktrace{"$addr *** $host"}) {
- print "Unrolling MX expnasion: @$host:$addr -> "
- if ($debug || $verbose);
- $host = $mxbacktrace{"$addr *** $host"};
- print "@$host:$addrn"
- if ($debug || $verbose);
- $r = 1;
- }
- return 1 if $r;
- $addr = "@$host:$addr"
- if ($host =~ /./);
- return 0;
- }
- # register a completed expnasion. Make the final address as
- # simple as possible.
- sub final
- {
- local($addr,$host,$name,$error) = @_;
- local($he);
- local($hb,$hr);
- local($au,$ah);
- if ($error =~ /Non-existent domain/) {
- #
- # If we created the domain, then let's undo the
- # damage...
- #
- if (defined $create_host_backtrack{"$addr *** $host"}) {
- while (defined $create_host_backtrack{"$addr *** $host"}) {
- print "Un&domainifying($host) = " if $debug;
- $host = $create_host_backtrack{"$addr *** $host"};
- print "$hostn" if $debug;
- }
- $error = "$host: could not locate";
- } else {
- #
- # If we only want valid addresses, toss out
- # bad host names.
- #
- if ($valid) {
- print STDERR "@$host:$addr ($name) Non-existent domainn";
- return "";
- }
- }
- }
- MXUNWIND: {
- $0 = "$av0 - final parsing of @$host:$addr";
- ($he = $host) =~ s/(W)/\$1/g;
- if ($addr !~ /@/) {
- # addr does not contain any host
- $addr = "$addr@$host";
- } elsif ($addr !~ /$he/i) {
- # if host part really something else, use the something
- # else.
- if ($addr =~ m/(.*)@([^@]+)$/) {
- ($au,$ah) = ($1,$2);
- print "au = $au ah = $ahn" if $debug;
- if (defined $temporary_redirect{"$addr *** $ah"}) {
- $addr = "$au@".$temporary_redirect{"$addr *** $ah"};
- print "Rewrite! to $addrn" if $debug;
- next MXUNWIND;
- }
- }
- # addr does not contain full host
- if ($valid) {
- if ($host =~ /^([^.]+)(..+)$/) {
- # host part has a . in it - foo.bar
- ($hb, $hr) = ($1, $2);
- if ($addr =~ /@([^.@]+)$/ && ($1 eq $hb)) {
- # addr part has not .
- # and matches beginning of
- # host part -- tack on a
- # domain name.
- $addr .= $hr;
- } else {
- &mxunroll(*host,*addr)
- && redo MXUNWIND;
- }
- } else {
- &mxunroll(*host,*addr)
- && redo MXUNWIND;
- }
- } else {
- $addr = "${addr}[@$host]"
- if ($host =~ /./);
- }
- }
- }
- $name = "$name " if $name;
- $error = " $error" if $error;
- if ($valid) {
- push(@final,"$name<$addr>");
- } else {
- push(@final,"$name<$addr>$error");
- }
- "t$name<$addr>$errorn";
- }
- sub alarm
- {
- local($alarm_action,$alarm_redirect,$alarm_user) = @_;
- alarm(3600);
- $SIG{ALRM} = 'handle_alarm';
- }
- # this involves one great big ugly hack.
- # the "next HOST" unwinds the stack!
- sub handle_alarm
- {
- &giveup($alarm_redirect,"Timed out during $alarm_action",$alarm_user);
- next HOST;
- }
- # read the rest of the current smtp daemon's response (and toss it away)
- sub read_response
- {
- local($done,$watch) = @_;
- local(@resp);
- print $s if $watch;
- while(($done eq "-") && ($s = <$S>) && ($s =~ /^d+([- ])/)) {
- print $s if $watch;
- $done = $1;
- push(@resp,$s);
- }
- return @resp;
- }
- # print args if verbose. Return them in any case
- sub verbose
- {
- local(@tp) = @_;
- print "@tp" if $verbose;
- }
- # to pass perl -w:
- @tp;
- $flag_a;
- $flag_d;
- $flag_1;
- %already_domainify_fellback;
- %already_mx_fellback;
- &handle_alarm;
- ################### BEGIN PERL/TROFF TRANSITION
- .00 ;
- 'di
- .nr nl 0-1
- .nr % 0
- .\"'; __END__
- ." ############## END PERL/TROFF TRANSITION
- .TH EXPN 1 "March 11, 1993"
- .AT 3
- .SH NAME
- expn - recursively expand mail aliases
- .SH SYNOPSIS
- .B expn
- .RI [ -a ]
- .RI [ -v ]
- .RI [ -w ]
- .RI [ -d ]
- .RI [ -1 ]
- .IR user [@ hostname ]
- .RI [ user [@ hostname ]]...
- .SH DESCRIPTION
- .B expn
- will use the SMTP
- .B expn
- and
- .B vrfy
- commands to expand mail aliases.
- It will first look up the addresses you provide on the command line.
- If those expand into addresses on other systems, it will
- connect to the other systems and expand again. It will keep
- doing this until no further expansion is possible.
- .SH OPTIONS
- The default output of
- .B expn
- can contain many lines which are not valid
- email addresses. With the
- .I -aa
- flag, only expansions that result in legal addresses
- are used. Since many mailing lists have an illegal
- address or two, the single
- .IR -a ,
- address, flag specifies that a few illegal addresses can
- be mixed into the results. More
- .I -a
- flags vary the ratio. Read the source to track down
- the formula. With the
- .I -a
- option, you should be able to construct a new mailing
- list out of an existing one.
- .LP
- If you wish to limit the number of levels deep that
- .B expn
- will recurse as it traces addresses, use the
- .I -1
- option. For each
- .I -1
- another level will be traversed. So,
- .I -111
- will traverse no more than three levels deep.
- .LP
- The normal mode of operation for
- .B expn
- is to do all of its work silently.
- The following options make it more verbose.
- It is not necessary to make it verbose to see what it is
- doing because as it works, it changes its
- .BR argv [0]
- variable to reflect its current activity.
- To see how it is expanding things, the
- .IR -v ,
- verbose, flag will cause
- .B expn
- to show each address before
- and after translation as it works.
- The
- .IR -w ,
- watch, flag will cause
- .B expn
- to show you its conversations with the mail daemons.
- Finally, the
- .IR -d ,
- debug, flag will expose many of the inner workings so that
- it is possible to eliminate bugs.
- .SH ENVIRONMENT
- No enviroment variables are used.
- .SH FILES
- .PD 0
- .B /tmp/expn$$
- .B temporary file used as input to
- .BR nslookup .
- .SH SEE ALSO
- .BR aliases (5),
- .BR sendmail (8),
- .BR nslookup (8),
- RFC 823, and RFC 1123.
- .SH BUGS
- Not all mail daemons will implement
- .B expn
- or
- .BR vrfy .
- It is not possible to verify addresses that are served
- by such daemons.
- .LP
- When attempting to connect to a system to verify an address,
- .B expn
- only tries one IP address. Most mail daemons
- will try harder.
- .LP
- It is assumed that you are running domain names and that
- the
- .BR nslookup (8)
- program is available. If not,
- .B expn
- will not be able to verify many addresses. It will also pause
- for a long time unless you change the code where it says
- .I $have_nslookup = 1
- to read
- .I $have_nslookup =
- .IR 0 .
- .LP
- Lastly,
- .B expn
- does not handle every valid address. If you have an example,
- please submit a bug report.
- .SH CREDITS
- In 1986 or so, Jon Broome wrote a program of the same name
- that did about the same thing. It has since suffered bit rot
- and Jon Broome has dropped off the face of the earth!
- (Jon, if you are out there, drop me a line)
- .SH AVAILABILITY
- The latest version of
- .B expn
- is available through anonymous ftp at
- .IR ftp://ftp.idiom.com/pub/muir-programs/expn .
- .SH AUTHOR
- .I David Muir Sharnoff <muir@idiom.com>