| blob | 9f33c8c8fc45d1b79453f7aa0fc5d5633b71eb18 |
1 #!@PERL@
2 'di ';
3 'ds 00 \\"';
4 'ig 00 ';
5 #
6 # THIS PROGRAM IS ITS OWN MANUAL PAGE. INSTALL IN man & bin.
7 #
9 # hardcoded constants, should work fine for BSD-based systems
10 #require 'sys/socket.ph'; # perl 4
11 use Socket; # perl 5
12 $AF_INET = &AF_INET;
13 $SOCK_STREAM = &SOCK_STREAM;
15 # system requirements:
16 # must have 'nslookup' and 'hostname' programs.
18 # Header: /home/ezk/proj/amd/GIT/cvs/am-utils/scripts/expn.in,v 1.5 2002/07/11 14:28:20 ezk Exp
20 # TODO:
21 # less magic should apply to command-line addresses
22 # less magic should apply to local addresses
23 # add magic to deal with cross-domain cnames
25 # Checklist: (hard addresses)
26 # 250 Kimmo Suominen <"|/usr/local/mh/lib/slocal -user kim"@grendel.tac.nyc.ny.us>
27 # harry@hofmann.cs.Berkeley.EDU -> harry@tenet (.berkeley.edu) [dead]
28 # bks@cs.berkeley.edu -> shiva.CS (.berkeley.edu) [dead]
29 # dan@tc.cornell.edu -> brown@tiberius (.tc.cornell.edu)
31 #############################################################################
32 #
33 # Copyright (c) 1993 David Muir Sharnoff
34 # All rights reserved.
35 #
36 # Redistribution and use in source and binary forms, with or without
37 # modification, are permitted provided that the following conditions
38 # are met:
39 # 1. Redistributions of source code must retain the above copyright
40 # notice, this list of conditions and the following disclaimer.
41 # 2. Redistributions in binary form must reproduce the above copyright
42 # notice, this list of conditions and the following disclaimer in the
43 # documentation and/or other materials provided with the distribution.
44 # 3. All advertising materials mentioning features or use of this software
45 # must display the following acknowledgement:
46 # This product includes software developed by the David Muir Sharnoff.
47 # 4. The name of David Sharnoff may not be used to endorse or promote products
48 # derived from this software without specific prior written permission.
49 #
50 # THIS SOFTWARE IS PROVIDED BY THE DAVID MUIR SHARNOFF ``AS IS'' AND
51 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
52 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
53 # ARE DISCLAIMED. IN NO EVENT SHALL DAVID MUIR SHARNOFF BE LIABLE
54 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
55 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
56 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
57 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
58 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
59 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
60 # SUCH DAMAGE.
61 #
62 # This copyright notice derived from material copyrighted by the Regents
63 # of the University of California.
64 #
65 # Contributions accepted.
66 #
67 #############################################################################
69 # overall structure:
70 # in an effort to not trace each address individually, but rather
71 # ask each server in turn a whole bunch of questions, addresses to
72 # be expanded are queued up.
73 #
74 # This means that all accounting w.r.t. an address must be stored in
75 # various arrays. Generally these arrays are indexed by the
76 # string "$addr *** $server" where $addr is the address to be
77 # expanded "foo" or maybe "foo@bar" and $server is the hostname
78 # of the SMTP server to contact.
79 #
81 # important global variables:
82 #
83 # @hosts : list of servers still to be contacted
84 # $server : name of the current we are currently looking at
85 # @users = $users{@hosts[0]} : addresses to expand at this server
86 # $u = $users[0] : the current address being expanded
87 # $names{"$users[0] *** $server"} : the 'name' associated with the address
88 # $mxbacktrace{"$users[0] *** $server"} : record of mx expansion
89 # $mx_secondary{$server} : other mx relays at the same priority
90 # $domainify_fallback{"$users[0] *** $server"} : alternative names to try
91 # instead of $server if $server doesn't work
92 # $temporary_redirect{"$users[0] *** $server"} : when trying alternates,
93 # temporarily channel all tries along current path
94 # $giveup{$server} : do not bother expanding addresses at $server
95 # $verbose : -v
96 # $watch : -w
97 # $vw : -v or -w
98 # $debug : -d
99 # $valid : -a
100 # $levels : -1
101 # S : the socket connection to $server
103 $have_nslookup = 1; # we have the nslookup program
104 $port = 'smtp';
105 $av0 = $0;
106 $ENV{'PATH'} .= ":/usr/etc" unless $ENV{'PATH'} =~ m,/usr/etc,;
107 $ENV{'PATH'} .= ":/usr/ucb" unless $ENV{'PATH'} =~ m,/usr/ucb,;
108 select(STDERR);
110 $0 = "$av0 - running hostname";
111 chop($name = `hostname || uname -n`);
113 $0 = "$av0 - lookup host FQDN and IP addr";
114 ($hostname,$aliases,$type,$len,$thisaddr) = gethostbyname($name);
116 $0 = "$av0 - parsing args";
117 $usage = "Usage: $av0 [-1avwd] user[\@host] [user2[\@host2] ...]";
118 for $a (@ARGV) {
119 die $usage if $a eq "-";
120 while ($a =~ s/^(-.*)([1avwd])/$1/) {
121 eval '$'."flag_$2 += 1";
122 }
123 next if $a eq "-";
124 die $usage if $a =~ /^-/;
125 &expn(&parse($a,$hostname,undef,1));
126 }
127 $verbose = $flag_v;
128 $watch = $flag_w;
129 $vw = $flag_v + $flag_w;
130 $debug = $flag_d;
131 $valid = $flag_a;
132 $levels = $flag_1;
134 die $usage unless @hosts;
135 if ($valid) {
136 if ($valid == 1) {
137 $validRequirement = 0.8;
138 } elsif ($valid == 2) {
139 $validRequirement = 1.0;
140 } elsif ($valid == 3) {
141 $validRequirement = 0.9;
142 } else {
143 $validRequirement = (1 - (1/($valid-3)));
144 print "validRequirement = $validRequirement\n" if $debug;
145 }
146 }
148 $0 = "$av0 - building local socket";
149 ($name,$aliases,$proto) = getprotobyname('tcp');
150 ($name,$aliases,$port) = getservbyname($port,'tcp')
151 unless $port =~ /^\d+/;
152 $this = sockaddr_in(0, $thisaddr);
154 HOST:
155 while (@hosts) {
156 $server = shift(@hosts);
157 @users = split(' ',$users{$server});
158 delete $users{$server};
160 # is this server already known to be bad?
161 $0 = "$av0 - looking up $server";
162 if ($giveup{$server}) {
163 &giveup('mx domainify',$giveup{$server});
164 next;
165 }
167 # do we already have an mx record for this host?
168 next HOST if &mxredirect($server,*users);
170 # look it up, or try for an mx.
171 $0 = "$av0 - gethostbyname($server)";
173 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($server);
174 # if we can't get an A record, try for an MX record.
175 unless($thataddr) {
176 &mxlookup(1,$server,"$server: could not resolve name",*users);
177 next HOST;
178 }
180 # get a connection, or look for an mx
181 $0 = "$av0 - socket to $server";
182 $that = sockaddr_in($port, $thataddr);
183 socket(S, &AF_INET, &SOCK_STREAM, $proto)
184 || die "socket: $!";
185 $0 = "$av0 - bind to $server";
186 bind(S, $this)
187 || die "bind $hostname,0: $!";
188 $0 = "$av0 - connect to $server";
189 print "debug = $debug server = $server\n" if $debug > 8;
190 if (! connect(S, $that) || ($debug == 10 && $server =~ /relay\d.UU.NET$/i)) {
191 $0 = "$av0 - $server: could not connect: $!\n";
192 $emsg = $!;
193 unless (&mxlookup(0,$server,"$server: could not connect: $!",*users)) {
194 &giveup('mx',"$server: Could not connect: $emsg");
195 }
196 next HOST;
197 }
198 select((select(S),$| = 1)[0]); # don't buffer output to S
200 # read the greeting
201 $0 = "$av0 - talking to $server";
202 &alarm("greeting with $server",'');
203 while(<S>) {
204 alarm(0);
205 print if $watch;
206 if (/^(\d+)([- ])/) {
207 if ($1 != 220) {
208 $0 = "$av0 - bad numeric response from $server";
209 &alarm("giving up after bad response from $server",'');
210 &read_response($2,$watch);
211 alarm(0);
212 print STDERR "$server: NOT 220 greeting: $_"
213 if ($debug || $vw);
214 if (&mxlookup(0,$server,"$server: did not respond with a 220 greeting",*users)) {
215 close(S);
216 next HOST;
217 }
218 }
219 last if ($2 eq " ");
220 } else {
221 $0 = "$av0 - bad response from $server";
222 print STDERR "$server: NOT 220 greeting: $_"
223 if ($debug || $vw);
224 unless (&mxlookup(0,$server,"$server: did not respond with SMTP codes",*users)) {
225 &giveup('',"$server: did not talk SMTP");
226 }
227 close(S);
228 next HOST;
229 }
230 &alarm("greeting with $server",'');
231 }
232 alarm(0);
234 # if this causes problems, remove it
235 $0 = "$av0 - sending helo to $server";
236 &alarm("sending helo to $server","");
237 &ps("helo $hostname");
238 while(<S>) {
239 print if $watch;
240 last if /^\d+ /;
241 }
242 alarm(0);
244 # try the users, one by one
245 USER:
246 while(@users) {
247 $u = shift(@users);
248 $0 = "$av0 - expanding $u [\@$server]";
250 # do we already have a name for this user?
251 $oldname = $names{"$u *** $server"};
253 print &compact($u,$server)." ->\n" if ($verbose && ! $valid);
254 if ($valid) {
255 #
256 # when running with -a, we delay taking any action
257 # on the results of our query until we have looked
258 # at the complete output. @toFinal stores expansions
259 # that will be final if we take them. @toExpn stores
260 # expansions that are not final. @isValid keeps
261 # track of our ability to send mail to each of the
262 # expansions.
263 #
264 @isValid = ();
265 @toFinal = ();
266 @toExpn = ();
267 }
269 # ($ecode,@expansion) = &expn_vrfy($u,$server);
270 (@foo) = &expn_vrfy($u,$server);
271 ($ecode,@expansion) = @foo;
272 if ($ecode) {
273 &giveup('',$ecode,$u);
274 last USER;
275 }
277 for $s (@expansion) {
278 $s =~ s/[\n\r]//g;
279 $0 = "$av0 - parsing $server: $s";
281 $skipwatch = $watch;
283 if ($s =~ /^[25]51([- ]).*<(.+)>/) {
284 print "$s" if $watch;
285 print "(pretending 250$1<$2>)" if ($debug && $watch);
286 print "\n" if $watch;
287 $s = "250$1<$2>";
288 $skipwatch = 0;
289 }
291 if ($s =~ /^250([- ])(.+)/) {
292 print "$s\n" if $skipwatch;
293 ($done,$addr) = ($1,$2);
294 ($newhost, $newaddr, $newname) = &parse($addr,$server,$oldname, $#expansion == 0);
295 print "($newhost, $newaddr, $newname) = &parse($addr, $server, $oldname)\n" if $debug;
296 if (! $newhost) {
297 # no expansion is possible w/o a new server to call
298 if ($valid) {
299 push(@isValid, &validAddr($newaddr));
300 push(@toFinal,$newaddr,$server,$newname);
301 } else {
302 &verbose(&final($newaddr,$server,$newname));
303 }
304 } else {
305 $newmxhost = &mx($newhost,$newaddr);
306 print "$newmxhost = &mx($newhost)\n"
307 if ($debug && $newhost ne $newmxhost);
308 $0 = "$av0 - parsing $newaddr [@$newmxhost]";
309 print "levels = $levels, level{$u *** $server} = ".$level{"$u *** $server"}."\n" if ($debug > 1);
310 # If the new server is the current one,
311 # it would have expanded things for us
312 # if it could have. Mx records must be
313 # followed to compare server names.
314 # We are also done if the recursion
315 # count has been exceeded.
316 if (&trhost($newmxhost) eq &trhost($server) || ($levels && $level{"$u *** $server"} >= $levels)) {
317 if ($valid) {
318 push(@isValid, &validAddr($newaddr));
319 push(@toFinal,$newaddr,$newmxhost,$newname);
320 } else {
321 &verbose(&final($newaddr,$newmxhost,$newname));
322 }
323 } else {
324 # more work to do...
325 if ($valid) {
326 push(@isValid, &validAddr($newaddr));
327 push(@toExpn,$newmxhost,$newaddr,$newname,$level{"$u *** $server"});
328 } else {
329 &verbose(&expn($newmxhost,$newaddr,$newname,$level{"$u *** $server"}));
330 }
331 }
332 }
333 last if ($done eq " ");
334 next;
335 }
336 # 550 is a known code... Should the be
337 # included in -a output? Might be a bug
338 # here. Does it matter? Can assume that
339 # there won't be UNKNOWN USER responses
340 # mixed with valid users?
341 if ($s =~ /^(550)([- ])/) {
342 if ($valid) {
343 print STDERR "\@$server:$u ($oldname) USER UNKNOWN\n";
344 } else {
345 &verbose(&final($u,$server,$oldname,"USER UNKNOWN"));
346 }
347 last if ($2 eq " ");
348 next;
349 }
350 # 553 is a known code...
351 if ($s =~ /^(553)([- ])/) {
352 if ($valid) {
353 print STDERR "\@$server:$u ($oldname) USER AMBIGUOUS\n";
354 } else {
355 &verbose(&final($u,$server,$oldname,"USER AMBIGUOUS"));
356 }
357 last if ($2 eq " ");
358 next;
359 }
360 # 252 is a known code...
361 if ($s =~ /^(252)([- ])/) {
362 if ($valid) {
363 print STDERR "\@$server:$u ($oldname) REFUSED TO VRFY\n";
364 } else {
365 &verbose(&final($u,$server,$oldname,"REFUSED TO VRFY"));
366 }
367 last if ($2 eq " ");
368 next;
369 }
370 &giveup('',"$server: did not grok '$s'",$u);
371 last USER;
372 }
374 if ($valid) {
375 #
376 # now we decide if we are going to take these
377 # expansions or roll them back.
378 #
379 $avgValid = &average(@isValid);
380 print "avgValid = $avgValid\n" if $debug;
381 if ($avgValid >= $validRequirement) {
382 print &compact($u,$server)." ->\n" if $verbose;
383 while (@toExpn) {
384 &verbose(&expn(splice(@toExpn,0,4)));
385 }
386 while (@toFinal) {
387 &verbose(&final(splice(@toFinal,0,3)));
388 }
389 } else {
390 print "Tossing some valid to avoid invalid ".&compact($u,$server)."\n" if ($avgValid > 0.0 && ($vw || $debug));
391 print &compact($u,$server)." ->\n" if $verbose;
392 &verbose(&final($u,$server,$newname));
393 }
394 }
395 }
397 &alarm("sending 'quit' to $server",'');
398 $0 = "$av0 - sending 'quit' to $server";
399 &ps("quit");
400 while(<S>) {
401 print if $watch;
402 last if /^\d+ /;
403 }
404 close(S);
405 alarm(0);
406 }
408 $0 = "$av0 - printing final results";
409 print "----------\n" if $vw;
410 select(STDOUT);
411 for $f (sort @final) {
412 print "$f\n";
413 }
414 unlink("/tmp/expn$$");
415 exit(0);
418 # abandon all attempts deliver to $server
419 # register the current addresses as the final ones
420 sub giveup
421 {
422 local($redirect_okay,$reason,$user) = @_;
423 local($us,@so,$nh,@remaining_users);
424 local($pk,$file,$line);
425 ($pk, $file, $line) = caller;
427 $0 = "$av0 - giving up on $server: $reason";
428 #
429 # add back a user if we gave up in the middle
430 #
431 push(@users,$user) if $user;
432 #
433 # don't bother with this system anymore
434 #
435 unless ($giveup{$server}) {
436 $giveup{$server} = $reason;
437 print STDERR "$reason\n";
438 }
439 print "Giveup at $file:$line!!! redirect okay = $redirect_okay; $reason\n" if $debug;
440 #
441 # Wait!
442 # Before giving up, see if there is a chance that
443 # there is another host to redirect to!
444 # (Kids, don't do this at home! Hacking is a dangerous
445 # crime and you could end up behind bars.)
446 #
447 for $u (@users) {
448 if ($redirect_okay =~ /\bmx\b/) {
449 next if &try_fallback('mx',$u,*server,
450 *mx_secondary,
451 *already_mx_fellback);
452 }
453 if ($redirect_okay =~ /\bdomainify\b/) {
454 next if &try_fallback('domainify',$u,*server,
455 *domainify_fallback,
456 *already_domainify_fellback);
457 }
458 push(@remaining_users,$u);
459 }
460 @users = @remaining_users;
461 for $u (@users) {
462 print &compact($u,$server)." ->\n" if ($verbose && $valid && $u);
463 &verbose(&final($u,$server,$names{"$u *** $server"},$reason));
464 }
465 }
466 #
467 # This routine is used only within &giveup. It checks to
468 # see if we really have to giveup or if there is a second
469 # chance because we did something before that can be
470 # backtracked.
471 #
472 # %fallback{"$user *** $host"} tracks what is able to fallback
473 # %fellback{"$user *** $host"} tracks what has fallen back
474 #
475 # If there is a valid backtrack, then queue up the new possibility
476 #
477 sub try_fallback
478 {
479 local($method,$user,*host,*fall_table,*fellback) = @_;
480 local($us,$fallhost,$oldhost,$ft,$i);
482 if ($debug > 8) {
483 print "Fallback table $method:\n";
484 for $i (sort keys %fall_table) {
485 print "\t'$i'\t\t'$fall_table{$i}'\n";
486 }
487 print "Fellback table $method:\n";
488 for $i (sort keys %fellback) {
489 print "\t'$i'\t\t'$fellback{$i}'\n";
490 }
491 print "U: $user H: $host\n";
492 }
494 $us = "$user *** $host";
495 if (defined $fellback{$us}) {
496 #
497 # Undo a previous fallback so that we can try again
498 # Nested fallbacks are avoided because they could
499 # lead to infinite loops
500 #
501 $fallhost = $fellback{$us};
502 print "Already $method fell back from $us -> \n" if $debug;
503 $us = "$user *** $fallhost";
504 $oldhost = $fallhost;
505 } elsif (($method eq 'mx') && (defined $mxbacktrace{$us}) && (defined $mx_secondary{$mxbacktrace{$us}})) {
506 print "Fallback an MX expansion $us -> \n" if $debug;
507 $oldhost = $mxbacktrace{$us};
508 } else {
509 print "Oldhost($host, $us) = " if $debug;
510 $oldhost = $host;
511 }
512 print "$oldhost\n" if $debug;
513 if (((defined $fall_table{$us}) && ($ft = $us)) || ((defined $fall_table{$oldhost}) && ($ft = $oldhost))) {
514 print "$method Fallback = ".$fall_table{$ft}."\n" if $debug;
515 local(@so,$newhost);
516 @so = split(' ',$fall_table{$ft});
517 $newhost = shift(@so);
518 print "Falling back ($method) $us -> $newhost (from $oldhost)\n" if $debug;
519 if ($method eq 'mx') {
520 if (! defined ($mxbacktrace{"$user *** $newhost"})) {
521 if (defined $mxbacktrace{"$user *** $oldhost"}) {
522 print "resetting oldhost $oldhost to the original: " if $debug;
523 $oldhost = $mxbacktrace{"$user *** $oldhost"};
524 print "$oldhost\n" if $debug;
525 }
526 $mxbacktrace{"$user *** $newhost"} = $oldhost;
527 print "mxbacktrace $user *** $newhost -> $oldhost\n" if $debug;
528 }
529 $mx{&trhost($oldhost)} = $newhost;
530 } else {
531 $temporary_redirect{$us} = $newhost;
532 }
533 if (@so) {
534 print "Can still $method $us: @so\n" if $debug;
535 $fall_table{$ft} = join(' ',@so);
536 } else {
537 print "No more fallbacks for $us\n" if $debug;
538 delete $fall_table{$ft};
539 }
540 if (defined $create_host_backtrack{$us}) {
541 $create_host_backtrack{"$user *** $newhost"}
542 = $create_host_backtrack{$us};
543 }
544 $fellback{"$user *** $newhost"} = $oldhost;
545 &expn($newhost,$user,$names{$us},$level{$us});
546 return 1;
547 }
548 delete $temporary_redirect{$us};
549 $host = $oldhost;
550 return 0;
551 }
552 # return 1 if you could send mail to the address as is.
553 sub validAddr
554 {
555 local($addr) = @_;
556 $res = &do_validAddr($addr);
557 print "validAddr($addr) = $res\n" if $debug;
558 $res;
559 }
560 sub do_validAddr
561 {
562 local($addr) = @_;
563 local($urx) = "[-A-Za-z_.0-9+]+";
565 # \u
566 return 0 if ($addr =~ /^\\/);
567 # ?@h
568 return 1 if ($addr =~ /.\@$urx$/);
569 # @h:?
570 return 1 if ($addr =~ /^\@$urx\:./);
571 # h!u
572 return 1 if ($addr =~ /^$urx!./);
573 # u
574 return 1 if ($addr =~ /^$urx$/);
575 # ?
576 print "validAddr($addr) = ???\n" if $debug;
577 return 0;
578 }
579 # Some systems use expn and vrfy interchangeably. Some only
580 # implement one or the other. Some check expn against mailing
581 # lists and vrfy against users. It doesn't appear to be
582 # consistent.
583 #
584 # So, what do we do? We try everything!
585 #
586 #
587 # Ranking of result codes: good: 250, 251/551, 252, 550, anything else
588 #
589 # Ranking of inputs: best: user@host.domain, okay: user
590 #
591 # Return value: $error_string, @responses_from_server
592 sub expn_vrfy
593 {
594 local($u,$server) = @_;
595 local(@c) = ('expn', 'vrfy');
596 local(@try_u) = $u;
597 local(@ret,$code);
599 if (($u =~ /(.+)@(.+)/) && (&trhost($2) eq &trhost($server))) {
600 push(@try_u,$1);
601 }
603 TRY:
604 for $c (@c) {
605 for $try_u (@try_u) {
606 &alarm("${c}'ing $try_u on $server",'',$u);
607 &ps("$c $try_u");
608 alarm(0);
609 $s = <S>;
610 if ($s eq '') {
611 return "$server: lost connection";
612 }
613 if ($s !~ /^(\d+)([- ])/) {
614 return "$server: garbled reply to '$c $try_u'";
615 }
616 if ($1 == 250) {
617 $code = 250;
618 @ret = ("",$s);
619 push(@ret,&read_response($2,$debug));
620 return (@ret);
621 }
622 if ($1 == 551 || $1 == 251) {
623 $code = $1;
624 @ret = ("",$s);
625 push(@ret,&read_response($2,$debug));
626 next;
627 }
628 if ($1 == 252 && ($code == 0 || $code == 550)) {
629 $code = 252;
630 @ret = ("",$s);
631 push(@ret,&read_response($2,$watch));
632 next;
633 }
634 if ($1 == 550 && $code == 0) {
635 $code = 550;
636 @ret = ("",$s);
637 push(@ret,&read_response($2,$watch));
638 next;
639 }
640 &read_response($2,$watch);
641 }
642 }
643 return "$server: expn/vrfy not implemented" unless @ret;
644 return @ret;
645 }
646 # sometimes the old parse routine (now parse2) didn't
647 # reject funky addresses.
648 sub parse
649 {
650 local($oldaddr,$server,$oldname,$one_to_one) = @_;
651 local($newhost, $newaddr, $newname, $um) = &parse2($oldaddr,$server,$oldname,$one_to_one);
652 if ($newaddr =~ m,^["/],) {
653 return (undef, $oldaddr, $newname) if $valid;
654 return (undef, $um, $newname);
655 }
656 return ($newhost, $newaddr, $newname);
657 }
659 # returns ($new_smtp_server,$new_address,$new_name)
660 # given a response from a SMTP server ($newaddr), the
661 # current host ($server), the old "name" and a flag that
662 # indicates if it is being called during the initial
663 # command line parsing ($parsing_args)
664 sub parse2
665 {
666 local($newaddr,$context_host,$old_name,$parsing_args) = @_;
667 local(@names) = $old_name;
668 local($urx) = "[-A-Za-z_.0-9+]+";
669 local($unmangle);
671 #
672 # first, separate out the address part.
673 #
675 #
676 # [NAME] <ADDR [(NAME)]>
677 # [NAME] <[(NAME)] ADDR
678 # ADDR [(NAME)]
679 # (NAME) ADDR
680 # [(NAME)] <ADDR>
681 #
682 if ($newaddr =~ /^\<(.*)\>$/) {
683 print "<A:$1>\n" if $debug;
684 ($newaddr) = &trim($1);
685 print "na = $newaddr\n" if $debug;
686 }
687 if ($newaddr =~ /^([^\<\>]*)\<([^\<\>]*)\>([^\<\>]*)$/) {
688 # address has a < > pair in it.
689 print "N:$1 <A:$2> N:$3\n" if $debug;
690 ($newaddr) = &trim($2);
691 unshift(@names, &trim($3,$1));
692 print "na = $newaddr\n" if $debug;
693 }
694 if ($newaddr =~ /^([^\(\)]*)\(([^\(\)]*)\)([^\(\)]*)$/) {
695 # address has a ( ) pair in it.
696 print "A:$1 (N:$2) A:$3\n" if $debug;
697 unshift(@names,&trim($2));
698 local($f,$l) = (&trim($1),&trim($3));
699 if (($f && $l) || !($f || $l)) {
700 # address looks like:
701 # foo (bar) baz or (bar)
702 # not allowed!
703 print STDERR "Could not parse $newaddr\n" if $vw;
704 return(undef,$newaddr,&firstname(@names));
705 }
706 $newaddr = $f if $f;
707 $newaddr = $l if $l;
708 print "newaddr now = $newaddr\n" if $debug;
709 }
710 #
711 # @foo:bar
712 # j%k@l
713 # a@b
714 # b!a
715 # a
716 #
717 $unmangle = $newaddr;
718 if ($newaddr =~ /^\@($urx)\:(.+)$/) {
719 print "(\@:)" if $debug;
720 # this is a bit of a cheat, but it seems necessary
721 return (&domainify($1,$context_host,$2),$2,&firstname(@names),$unmangle);
722 }
723 if ($newaddr =~ /^(.+)\@($urx)$/) {
724 print "(\@)" if $debug;
725 return (&domainify($2,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
726 }
727 if ($parsing_args) {
728 if ($newaddr =~ /^($urx)\!(.+)$/) {
729 return (&domainify($1,$context_host,$newaddr),$newaddr,&firstname(@names),$unmangle);
730 }
731 if ($newaddr =~ /^($urx)$/) {
732 return ($context_host,$newaddr,&firstname(@names),$unmangle);
733 }
734 print STDERR "Could not parse $newaddr\n";
735 }
736 print "(?)" if $debug;
737 return(undef,$newaddr,&firstname(@names),$unmangle);
738 }
739 # return $u (@$server) unless $u includes reference to $server
740 sub compact
741 {
742 local($u, $server) = @_;
743 local($se) = $server;
744 local($sp);
745 $se =~ s/(\W)/\\$1/g;
746 $sp = " (\@$server)";
747 if ($u !~ /$se/i) {
748 return "$u$sp";
749 }
750 return $u;
751 }
752 # remove empty (spaces don't count) members from an array
753 sub trim
754 {
755 local(@v) = @_;
756 local($v,@r);
757 for $v (@v) {
758 $v =~ s/^\s+//;
759 $v =~ s/\s+$//;
760 push(@r,$v) if ($v =~ /\S/);
761 }
762 return(@r);
763 }
764 # using the host part of an address, and the server name, add the
765 # servers' domain to the address if it doesn't already have a
766 # domain. Since this sometimes fails, save a back reference so
767 # it can be unrolled.
768 sub domainify
769 {
770 local($host,$domain_host,$u) = @_;
771 local($domain,$newhost);
773 # cut of trailing dots
774 $host =~ s/\.$//;
775 $domain_host =~ s/\.$//;
777 if ($domain_host !~ /\./) {
778 #
779 # domain host isn't, keep $host whatever it is
780 #
781 print "domainify($host,$domain_host) = $host\n" if $debug;
782 return $host;
783 }
785 #
786 # There are several weird situations that need to be
787 # accounted for. They have to do with domain relay hosts.
788 #
789 # Examples:
790 # host server "right answer"
791 #
792 # shiva.cs cs.berkeley.edu shiva.cs.berkeley.edu
793 # shiva cs.berkeley.edu shiva.cs.berekley.edu
794 # cumulus reed.edu @reed.edu:cumulus.uucp
795 # tiberius tc.cornell.edu tiberius.tc.cornell.edu
796 #
797 # The first try must always be to cut the domain part out of
798 # the server and tack it onto the host.
799 #
800 # A reasonable second try is to tack the whole server part onto
801 # the host and for each possible repeated element, eliminate
802 # just that part.
803 #
804 # These extra "guesses" get put into the %domainify_fallback
805 # array. They will be used to give addresses a second chance
806 # in the &giveup routine
807 #
809 local(%fallback);
811 local($long);
812 $long = "$host $domain_host";
813 $long =~ tr/A-Z/a-z/;
814 print "long = $long\n" if $debug;
815 if ($long =~ s/^([^ ]+\.)([^ ]+) \2(\.[^ ]+\.[^ ]+)/$1$2$3/) {
816 # matches shiva.cs cs.berkeley.edu and returns shiva.cs.berkeley.edu
817 print "condensed fallback $host $domain_host -> $long\n" if $debug;
818 $fallback{$long} = 9;
819 }
821 local($fh);
822 $fh = $domain_host;
823 while ($fh =~ /\./) {
824 print "FALLBACK $host.$fh = 1\n" if $debug > 7;
825 $fallback{"$host.$fh"} = 1;
826 $fh =~ s/^[^\.]+\.//;
827 }
829 $fallback{"$host.$domain_host"} = 2;
831 ($domain = $domain_host) =~ s/^[^\.]+//;
832 $fallback{"$host$domain"} = 6
833 if ($domain =~ /\./);
835 if ($host =~ /\./) {
836 #
837 # Host is already okay, but let's look for multiple
838 # interpretations
839 #
840 print "domainify($host,$domain_host) = $host\n" if $debug;
841 delete $fallback{$host};
842 $domainify_fallback{"$u *** $host"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
843 return $host;
844 }
846 $domain = ".$domain_host"
847 if ($domain !~ /\..*\./);
848 $newhost = "$host$domain";
850 $create_host_backtrack{"$u *** $newhost"} = $domain_host;
851 print "domainify($host,$domain_host) = $newhost\n" if $debug;
852 delete $fallback{$newhost};
853 $domainify_fallback{"$u *** $newhost"} = join(' ',sort {$fallback{$b} <=> $fallback{$a};} keys %fallback) if %fallback;
854 if ($debug) {
855 print "fallback = ";
856 print $domainify_fallback{"$u *** $newhost"}
857 if defined($domainify_fallback{"$u *** $newhost"});
858 print "\n";
859 }
860 return $newhost;
861 }
862 # return the first non-empty element of an array
863 sub firstname
864 {
865 local(@names) = @_;
866 local($n);
867 while(@names) {
868 $n = shift(@names);
869 return $n if $n =~ /\S/;
870 }
871 return undef;
872 }
873 # queue up more addresses to expand
874 sub expn
875 {
876 local($host,$addr,$name,$level) = @_;
877 if ($host) {
878 $host = &trhost($host);
880 if (($debug > 3) || (defined $giveup{$host})) {
881 unshift(@hosts,$host) unless $users{$host};
882 } else {
883 push(@hosts,$host) unless $users{$host};
884 }
885 $users{$host} .= " $addr";
886 $names{"$addr *** $host"} = $name;
887 $level{"$addr *** $host"} = $level + 1;
888 print "expn($host,$addr,$name)\n" if $debug;
889 return "\t$addr\n";
890 } else {
891 return &final($addr,'NONE',$name);
892 }
893 }
894 # compute the numerical average value of an array
895 sub average
896 {
897 local(@e) = @_;
898 return 0 unless @e;
899 local($e,$sum);
900 for $e (@e) {
901 $sum += $e;
902 }
903 $sum / @e;
904 }
905 # print to the server (also to stdout, if -w)
906 sub ps
907 {
908 local($p) = @_;
909 print ">>> $p\n" if $watch;
910 print S "$p\n";
911 }
912 # return case-adjusted name for a host (for comparison purposes)
913 sub trhost
914 {
915 # treat foo.bar as an alias for Foo.BAR
916 local($host) = @_;
917 local($trhost) = $host;
918 $trhost =~ tr/A-Z/a-z/;
919 if ($trhost{$trhost}) {
920 $host = $trhost{$trhost};
921 } else {
922 $trhost{$trhost} = $host;
923 }
924 $trhost{$trhost};
925 }
926 # re-queue users if an mx record dictates a redirect
927 # don't allow a user to be redirected more than once
928 sub mxredirect
929 {
930 local($server,*users) = @_;
931 local($u,$nserver,@still_there);
933 $nserver = &mx($server);
935 if (&trhost($nserver) ne &trhost($server)) {
936 $0 = "$av0 - mx redirect $server -> $nserver\n";
937 for $u (@users) {
938 if (defined $mxbacktrace{"$u *** $nserver"}) {
939 push(@still_there,$u);
940 } else {
941 $mxbacktrace{"$u *** $nserver"} = $server;
942 print "mxbacktrace{$u *** $nserver} = $server\n"
943 if ($debug > 1);
944 &expn($nserver,$u,$names{"$u *** $server"});
945 }
946 }
947 @users = @still_there;
948 if (! @users) {
949 return $nserver;
950 } else {
951 return undef;
952 }
953 }
954 return undef;
955 }
956 # follow mx records, return a hostname
957 # also follow temporary redirections coming from &domainify and
958 # &mxlookup
959 sub mx
960 {
961 local($h,$u) = @_;
963 for (;;) {
964 if (defined $mx{&trhost($h)} && $h ne $mx{&trhost($h)}) {
965 $0 = "$av0 - mx expand $h";
966 $h = $mx{&trhost($h)};
967 return $h;
968 }
969 if ($u) {
970 if (defined $temporary_redirect{"$u *** $h"}) {
971 $0 = "$av0 - internal redirect $h";
972 print "Temporary redirect taken $u *** $h -> " if $debug;
973 $h = $temporary_redirect{"$u *** $h"};
974 print "$h\n" if $debug;
975 next;
976 }
977 $htr = &trhost($h);
978 if (defined $temporary_redirect{"$u *** $htr"}) {
979 $0 = "$av0 - internal redirect $h";
980 print "temporary redirect taken $u *** $h -> " if $debug;
981 $h = $temporary_redirect{"$u *** $htr"};
982 print "$h\n" if $debug;
983 next;
984 }
985 }
986 return $h;
987 }
988 }
989 # look up mx records with the name server.
990 # re-queue expansion requests if possible
991 # optionally give up on this host.
992 sub mxlookup
993 {
994 local($lastchance,$server,$giveup,*users) = @_;
995 local(*T);
996 local(*NSLOOKUP);
997 local($nh, $pref,$cpref);
998 local($o0) = $0;
999 local($nserver);
1000 local($name,$aliases,$type,$len,$thataddr);
1001 local(%fallback);
1003 return 1 if &mxredirect($server,*users);
1005 if ((defined $mx{$server}) || (! $have_nslookup)) {
1006 return 0 unless $lastchance;
1007 &giveup('mx domainify',$giveup);
1008 return 0;
1009 }
1011 $0 = "$av0 - nslookup of $server";
1012 open(T,">/tmp/expn$$") || die "open > /tmp/expn$$: $!\n";
1013 print T "set querytype=MX\n";
1014 print T "$server\n";
1015 close(T);
1016 $cpref = 1.0E12;
1017 undef $nserver;
1018 open(NSLOOKUP,"nslookup < /tmp/expn$$ 2>&1 |") || die "open nslookup: $!";
1019 while(<NSLOOKUP>) {
1020 print if ($debug > 2);
1021 if (/mail exchanger = ([-A-Za-z_.0-9+]+)/) {
1022 $nh = $1;
1023 if (/preference = (\d+)/) {
1024 $pref = $1;
1025 if ($pref < $cpref) {
1026 $nserver = $nh;
1027 $cpref = $pref;
1028 } elsif ($pref) {
1029 $fallback{$pref} .= " $nh";
1030 }
1031 }
1032 }
1033 if (/Non-existent domain/) {
1034 #
1035 # These addresses are hosed. Kaput! Dead!
1036 # However, if we created the address in the
1037 # first place then there is a chance of
1038 # salvation.
1039 #
1040 1 while(<NSLOOKUP>);
1041 close(NSLOOKUP);
1042 return 0 unless $lastchance;
1043 &giveup('domainify',"$server: Non-existent domain",undef,1);
1044 return 0;
1045 }
1047 }
1048 close(NSLOOKUP);
1049 unlink("/tmp/expn$$");
1050 unless ($nserver) {
1051 $0 = "$o0 - finished mxlookup";
1052 return 0 unless $lastchance;
1053 &giveup('mx domainify',"$server: Could not resolve address");
1054 return 0;
1055 }
1057 # provide fallbacks in case $nserver doesn't work out
1058 if (defined $fallback{$cpref}) {
1059 $mx_secondary{$server} = $fallback{$cpref};
1060 }
1062 $0 = "$av0 - gethostbyname($nserver)";
1063 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($nserver);
1065 unless ($thataddr) {
1066 $0 = $o0;
1067 return 0 unless $lastchance;
1068 &giveup('mx domainify',"$nserver: could not resolve address");
1069 return 0;
1070 }
1071 print "MX($server) = $nserver\n" if $debug;
1072 print "$server -> $nserver\n" if $vw && !$debug;
1073 $mx{&trhost($server)} = $nserver;
1074 # redeploy the users
1075 unless (&mxredirect($server,*users)) {
1076 return 0 unless $lastchance;
1077 &giveup('mx domainify',"$nserver: only one level of mx redirect allowed");
1078 return 0;
1079 }
1080 $0 = "$o0 - finished mxlookup";
1081 return 1;
1082 }
1083 # if mx expansion did not help to resolve an address
1084 # (ie: foo@bar became @baz:foo@bar, then undo the
1085 # expansion).
1086 # this is only used by &final
1087 sub mxunroll
1088 {
1089 local(*host,*addr) = @_;
1090 local($r) = 0;
1091 print "looking for mxbacktrace{$addr *** $host}\n"
1092 if ($debug > 1);
1093 while (defined $mxbacktrace{"$addr *** $host"}) {
1094 print "Unrolling MX expansion: \@$host:$addr -> "
1095 if ($debug || $verbose);
1096 $host = $mxbacktrace{"$addr *** $host"};
1097 print "\@$host:$addr\n"
1098 if ($debug || $verbose);
1099 $r = 1;
1100 }
1101 return 1 if $r;
1102 $addr = "\@$host:$addr"
1103 if ($host =~ /\./);
1104 return 0;
1105 }
1106 # register a completed expansion. Make the final address as
1107 # simple as possible.
1108 sub final
1109 {
1110 local($addr,$host,$name,$error) = @_;
1111 local($he);
1112 local($hb,$hr);
1113 local($au,$ah);
1115 if ($error =~ /Non-existent domain/) {
1116 #
1117 # If we created the domain, then let's undo the
1118 # damage...
1119 #
1120 if (defined $create_host_backtrack{"$addr *** $host"}) {
1121 while (defined $create_host_backtrack{"$addr *** $host"}) {
1122 print "Un&domainifying($host) = " if $debug;
1123 $host = $create_host_backtrack{"$addr *** $host"};
1124 print "$host\n" if $debug;
1125 }
1126 $error = "$host: could not locate";
1127 } else {
1128 #
1129 # If we only want valid addresses, toss out
1130 # bad host names.
1131 #
1132 if ($valid) {
1133 print STDERR "\@$host:$addr ($name) Non-existent domain\n";
1134 return "";
1135 }
1136 }
1137 }
1139 MXUNWIND: {
1140 $0 = "$av0 - final parsing of \@$host:$addr";
1141 ($he = $host) =~ s/(\W)/\\$1/g;
1142 if ($addr !~ /@/) {
1143 # addr does not contain any host
1144 $addr = "$addr@$host";
1145 } elsif ($addr !~ /$he/i) {
1146 # if host part really something else, use the something
1147 # else.
1148 if ($addr =~ m/(.*)\@([^\@]+)$/) {
1149 ($au,$ah) = ($1,$2);
1150 print "au = $au ah = $ah\n" if $debug;
1151 if (defined $temporary_redirect{"$addr *** $ah"}) {
1152 $addr = "$au\@".$temporary_redirect{"$addr *** $ah"};
1153 print "Rewrite! to $addr\n" if $debug;
1154 next MXUNWIND;
1155 }
1156 }
1157 # addr does not contain full host
1158 if ($valid) {
1159 if ($host =~ /^([^\.]+)(\..+)$/) {
1160 # host part has a . in it - foo.bar
1161 ($hb, $hr) = ($1, $2);
1162 if ($addr =~ /\@([^\.\@]+)$/ && ($1 eq $hb)) {
1163 # addr part has not .
1164 # and matches beginning of
1165 # host part -- tack on a
1166 # domain name.
1167 $addr .= $hr;
1168 } else {
1169 &mxunroll(*host,*addr)
1170 && redo MXUNWIND;
1171 }
1172 } else {
1173 &mxunroll(*host,*addr)
1174 && redo MXUNWIND;
1175 }
1176 } else {
1177 $addr = "${addr}[\@$host]"
1178 if ($host =~ /\./);
1179 }
1180 }
1181 }
1182 $name = "$name " if $name;
1183 $error = " $error" if $error;
1184 if ($valid) {
1185 push(@final,"$name<$addr>");
1186 } else {
1187 push(@final,"$name<$addr>$error");
1188 }
1189 "\t$name<$addr>$error\n";
1190 }
1192 sub alarm
1193 {
1194 local($alarm_action,$alarm_redirect,$alarm_user) = @_;
1195 alarm(3600);
1196 $SIG{ALRM} = 'handle_alarm';
1197 }
1198 # this involves one great big ugly hack.
1199 # the "next HOST" unwinds the stack!
1200 sub handle_alarm
1201 {
1202 &giveup($alarm_redirect,"Timed out during $alarm_action",$alarm_user);
1203 next HOST;
1204 }
1206 # read the rest of the current smtp daemon's response (and toss it away)
1207 sub read_response
1208 {
1209 local($done,$watch) = @_;
1210 local(@resp);
1211 print $s if $watch;
1212 while(($done eq "-") && ($s = <S>) && ($s =~ /^\d+([- ])/)) {
1213 print $s if $watch;
1214 $done = $1;
1215 push(@resp,$s);
1216 }
1217 return @resp;
1218 }
1219 # print args if verbose. Return them in any case
1220 sub verbose
1221 {
1222 local(@tp) = @_;
1223 print "@tp" if $verbose;
1224 }
1225 # to pass perl -w:
1226 @tp;
1227 $flag_a;
1228 $flag_d;
1229 $flag_1;
1230 %already_domainify_fellback;
1231 %already_mx_fellback;
1232 &handle_alarm;
1233 ################### BEGIN PERL/TROFF TRANSITION
1234 .00 ;
1236 'di
1237 .nr nl 0-1
1238 .nr % 0
1239 .\\"'; __END__
1240 .\" ############## END PERL/TROFF TRANSITION
1241 .TH EXPN 1 "March 11, 1993"
1242 .AT 3
1243 .SH NAME
1244 expn \- recursively expand mail aliases
1245 .SH SYNOPSIS
1246 .B expn
1247 .RI [ -a ]
1248 .RI [ -v ]
1249 .RI [ -w ]
1250 .RI [ -d ]
1251 .RI [ -1 ]
1252 .IR user [@ hostname ]
1253 .RI [ user [@ hostname ]]...
1254 .SH DESCRIPTION
1255 .B expn
1256 will use the SMTP
1257 .B expn
1258 and
1259 .B vrfy
1260 commands to expand mail aliases.
1261 It will first look up the addresses you provide on the command line.
1262 If those expand into addresses on other systems, it will
1263 connect to the other systems and expand again. It will keep
1264 doing this until no further expansion is possible.
1265 .SH OPTIONS
1266 The default output of
1267 .B expn
1268 can contain many lines which are not valid
1269 email addresses. With the
1270 .I -aa
1271 flag, only expansions that result in legal addresses
1272 are used. Since many mailing lists have an illegal
1273 address or two, the single
1274 .IR -a ,
1275 address, flag specifies that a few illegal addresses can
1276 be mixed into the results. More
1277 .I -a
1278 flags vary the ratio. Read the source to track down
1279 the formula. With the
1280 .I -a
1281 option, you should be able to construct a new mailing
1282 list out of an existing one.
1283 .LP
1284 If you wish to limit the number of levels deep that
1285 .B expn
1286 will recurse as it traces addresses, use the
1287 .I -1
1288 option. For each
1289 .I -1
1290 another level will be traversed. So,
1291 .I -111
1292 will traverse no more than three levels deep.
1293 .LP
1294 The normal mode of operation for
1295 .B expn
1296 is to do all of its work silently.
1297 The following options make it more verbose.
1298 It is not necessary to make it verbose to see what it is
1299 doing because as it works, it changes its
1300 .BR argv [0]
1301 variable to reflect its current activity.
1302 To see how it is expanding things, the
1303 .IR -v ,
1304 verbose, flag will cause
1305 .B expn
1306 to show each address before
1307 and after translation as it works.
1308 The
1309 .IR -w ,
1310 watch, flag will cause
1311 .B expn
1312 to show you its conversations with the mail daemons.
1313 Finally, the
1314 .IR -d ,
1315 debug, flag will expose many of the inner workings so that
1316 it is possible to eliminate bugs.
1317 .SH ENVIRONMENT
1318 No environment variables are used.
1319 .SH FILES
1320 .PD 0
1321 .B /tmp/expn$$
1322 .B temporary file used as input to
1323 .BR nslookup .
1324 .SH SEE ALSO
1325 .BR aliases (5),
1326 .BR sendmail (8),
1327 .BR nslookup (8),
1328 RFC 823, and RFC 1123.
1329 .SH BUGS
1330 Not all mail daemons will implement
1331 .B expn
1332 or
1333 .BR vrfy .
1334 It is not possible to verify addresses that are served
1335 by such daemons.
1336 .LP
1337 When attempting to connect to a system to verify an address,
1338 .B expn
1339 only tries one IP address. Most mail daemons
1340 will try harder.
1341 .LP
1342 It is assumed that you are running domain names and that
1343 the
1344 .BR nslookup (8)
1345 program is available. If not,
1346 .B expn
1347 will not be able to verify many addresses. It will also pause
1348 for a long time unless you change the code where it says
1349 .I $have_nslookup = 1
1350 to read
1351 .I $have_nslookup =
1352 .IR 0 .
1353 .LP
1354 Lastly,
1355 .B expn
1356 does not handle every valid address. If you have an example,
1357 please submit a bug report.
1358 .SH CREDITS
1359 In 1986 or so, Jon Broome wrote a program of the same name
1360 that did about the same thing. It has since suffered bit rot
1361 and Jon Broome has dropped off the face of the earth!
1362 (Jon, if you are out there, drop me a line)
1363 .SH AVAILABILITY
1364 The latest version of
1365 .B expn
1366 is available through anonymous ftp at
1367 .IR ftp://ftp.idiom.com/pub/muir-programs/expn .
1368 .SH AUTHOR
1369 .I David Muir Sharnoff\ \ \ \ <muir@idiom.com>