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