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