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