home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _dabd7854fc37acda7c52096fa976baa7 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.7 KB  |  97 lines
  1. #!/usr/local/ActivePerl-5.6/bin/perl -w
  2. #
  3. # forker.pl
  4. #
  5. # This script is a simple demonstration of how to use fork()
  6. #
  7. # Author: David Sparks <dave@ActiveState.com>
  8.  
  9. use strict;
  10. use warnings;
  11.  
  12. use constant CLIENTS   => 32;
  13. use constant DEBUG     => 1;
  14. $|=1; #buffering a bad idea when fork()ing
  15.  
  16. my @kids=();
  17. my $pid=$$;
  18. my $parentpid=0;
  19.  
  20.  
  21. #script starts here
  22. SharedInit();
  23.  
  24. Forker(CLIENTS);
  25.  
  26. if ($parentpid) {
  27.     Work();
  28. }
  29. else { #the original parent only does cleanup duty
  30.     Reaper();
  31. }
  32.  
  33. warn "$$ exiting\n" if DEBUG;
  34.  
  35. if ($parentpid) {
  36.     #kids exit here
  37.     exit(0);
  38. }
  39. else {
  40.     #parent exits here
  41.     exit(0);
  42. }
  43. die; #wont happen
  44.  
  45.  
  46. sub Forker {
  47.     my $clients=shift;
  48.     my $i=0;
  49.     while ($i++ < $clients) {
  50.         my $newpid = fork();
  51.         if (! defined $newpid) { #hosed
  52.             die "fork() error: $!\n";
  53.         }
  54.         elsif ($newpid == 0) { #child
  55.             $parentpid = $pid;
  56.             $pid = $$;
  57.             @kids = (); #don't inhert the kids
  58.             warn "$$ child of $parentpid\n" if DEBUG;
  59.             last;
  60.         }
  61.         else { #parent   (defined $newpid)
  62.             warn "$$ spawned $newpid\n" if DEBUG;
  63.             push(@kids, $newpid);
  64.         }
  65.     }
  66. }
  67.  
  68. sub SharedInit {
  69.     warn "Entering SharedInit()\n" if DEBUG;
  70.     
  71.     
  72. }
  73.  
  74. sub Work {
  75.     warn "$$ Entering Work()\n" if DEBUG;
  76.     
  77.  
  78. }
  79.  
  80. sub Reaper {
  81.     while (my $kid = shift(@kids)) {
  82.         warn "$$ to reap $kid\n" if DEBUG;
  83.         my $reaped = waitpid($kid,0);
  84.         unless ($reaped == $kid) {
  85.             warn "waitpid $reaped: $?\n" if DEBUG;
  86.         }
  87.     }
  88. }
  89.  
  90. __END__
  91.  
  92.      use POSIX ":sys_wait_h";
  93.      do {
  94.          $kid = waitpid(-1,&WNOHANG);
  95.      } until $kid == -1;
  96.  
  97.