Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

RE: Forking and sharing variables

by httptech (Chaplain)
on May 20, 2000 at 23:01 UTC ( [id://13929]=note: print w/replies, xml ) Need Help??


in reply to Forking and sharing variables

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.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://13929]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others pondering the Monastery: (5)
As of 2024-06-19 13:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?
    erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.