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