The code is as follows (the forking code is mostly borrowed
from pg.626-627 of
The Perl Cookbook
use Symbol;
use POSIX;
use IPC::Shareable;
use Net::DNS;
$| = 1;
my $ppid = $$;
my %options = (
destroy => 'yes',
create => 'yes',
);
my %mxs;
my $knot = tie %mxs, 'IPC::Shareable', $ppid, { %options } or
die "server: tie failed\n";
my @urls = <>; # Specify a filename on the command line with
# a list of email addresses, one per line.
for (@urls) {
chomp;
my ($username, $domain) = split (/\@/);
push (@{$hash{$domain}}, $_);
};
print "Sorted addresses by domain\n";
my $PREFORK = 25; # number of children to mainta
+in
my %children = (); # keys are current child proces
+s IDs
my $children = 0; # current number of children
my @doms = keys %hash;
# Fork off our children.
for (1 .. $PREFORK) {
my $url = shift(@doms);
make_new_child($url) if $url;
}
# Install signal handlers.
$SIG{CHLD} = \&REAPER;
$SIG{INT} = \&HUNTSMAN;
# And maintain the population.
while (1) {
sleep; # wait for a signal (i.e., child's
+ death)
for ($i = $children; $i < $PREFORK; $i++) {
my $url = shift(@doms);
make_new_child($url) if $url; # top up the child poo
+l
}
last unless @doms;
}
print "Done with URL list, waiting on remaining threads to finish...\n
+";
# Wait for everyone to return
do {
$kid = waitpid(-1,&WNOHANG);
} until $kid == -1;
print "Sorted domains by mx server\n";
open (OUT, ">/tmp/mx.tmp"); # Make a report about what would
# have happened if the rest of the
# program were written
for (keys %mxs) {
my @deliver = ();
my $mx = $_;
my @domains = split(/\n/, $mxs{$mx});
for (@domains) { push (@deliver, @{$hash{$_}}) }
print OUT "Sending to mx server $mx :\n";
print OUT join ("\n", @deliver), "\n";
}
close (OUT);
IPC::Shareable->clean_up;
exit;
sub make_new_child {
my $url = shift;
my $pid;
my $sigset;
# block signal for fork
$sigset = POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset)
or die "Can't block SIGINT for fork: $!\n";
die "fork: $!" unless defined ($pid = fork);
if ($pid) {
# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = 1;
$children++;
return;
} else {
# Child can *not* return from this subroutine.
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did be
+fore
# unblock signals
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
print "Looking up MX server for $url\n";
my @mx = mx($url);
my $mx = join("|", map { $_->exchange} @mx); # Making a key wi
+th
# join instead of references. yuk.
$mx ||= $url;
$knot->shlock;
# push (@{$mxs{$mx}}, $url); # This doesn't work due to tie
# problems with IPC::Shareable
$mxs{$mx} .= "$url\n"; # So we do this instead (bleah)
$knot->shunlock;
print "Found MX servers for $url\n";
exit;
}
}
sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;
my $pid = wait;
$children --;
delete $children{$pid};
}
sub HUNTSMAN { # signal handler for SIGINT
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
kill 'INT' => keys %children;
$knot->destroy;
IPC::Shareable->clean_up;
exit; # clean up with dignity
}
For now I am not worrying about storing the preference of
the MX server. And when a domain like foo.bar.com doesn't
have an MX record, I am just using foo.bar.com as the MX
server. because I don't know how to use Net::DNS recursively.