perl/ForkingServer.pm

   1 #!/usr/bin/perl -w
   2 #
   3 # This is a forking server class (ofcourse it is :-)
   4 #
   5 # You can only have one of these running at a time, so there!
   6 #
   7 # I am not using AUTOLOAD at the moment in a general spirit
   8 # of 'inat' (a wonderfully succinct serbo-croat word and state
   9 # of being) - So there! Yah boo sucks! Won't! Nurps!
  10 #
  11 # Can I just say (as a policy statement) that I hope I never have
  12 # to write any more C code (other than to extend or interface to perl).
  13 #
  14 # Copyright (c) 1999 - Dirk Koopman, Tobit Computer Co Ltd
  15 #
  16 #
  17 #
  18
  19 package ForkingServer;
  20
  21 use strict;
  22
  23 use IO::File;
  24 use IO::Socket;
  25 use Net::hostent;
  26
  27 use Carp;
  28
  29 sub new
  30 {
  31         my $type = shift;
  32         my $self = {};
  33         my $s = shift;
  34         if ($s) {
  35                 if (ref $s) {
  36                         $self->{child} = $s;
  37                 } else {
  38                         $self->{child} = eval $s;
  39                         confess $@ if $@;
  40                 }
  41         }
  42         $self->{port} = shift || 9000;
  43         $self->{sort} = 'tcp';
  44         $self->{sorry} = "Bog OFF!\n";
  45         $self->{allow} = [ '^localhost\$', '^127.0.0' ];
  46         return bless $self, $type;
  47 }
  48
  49 sub port
  50 {
  51         my $self = shift;
  52         my $port = shift;
  53         $self->{port} = $port;
  54 }
  55
  56 sub sort
  57 {
  58         my $self = shift;
  59         my $sort = shift;
  60         confess "sort must be tcp or udp" unless $sort eq 'tcp' || $sort eq 'udp';
  61         $self->{sort} = $sort;
  62 }
  63
  64 sub allow
  65 {
  66         my $self = shift;
  67         $self->{allow} = ref $_[0] ? shift : [ @_ ];
  68 }
  69
  70 sub deny
  71 {
  72         my $self = shift;
  73         $self->{deny} = ref $_[0] ? shift : [ @_ ];
  74 }
  75
  76 sub sorry
  77 {
  78         my $self = shift;
  79         $self->{sorry} = shift;
  80 }
  81
  82 sub quiet
  83 {
  84         my $self = shift;
  85         $self->{quiet} = shift;
  86 }
  87
  88 sub is_parent
  89 {
  90         my $self = shift;
  91         return $self->{parent};
  92 }
  93
  94 sub run {
  95         my $self = shift;
  96
  97         my $server = IO::Socket::INET->new( Proto     => $self->{sort},
  98                                                                                 LocalPort => $self->{port},
  99                                                                                 Listen    => SOMAXCONN,
 100                                                                                 Reuse     => 1);
 101
 102         my $client;
 103
 104         confess "bot: can't setup server $!" unless $server;
 105         print "[Server $0 accepting clients on port $self->{port}]\n" unless $self->{quiet};
 106
 107         $SIG{CHLD} = \&reaper;
 108         $self->{parent} = 1;
 109
 110         while ($client = $server->accept()) {
 111                 $client->autoflush(1);
 112                 my $hostinfo = gethostbyaddr($client->peeraddr);
 113                 my $hostname = $hostinfo->name;
 114                 my $ipaddr = $client->peerhost;
 115                 unless ($self->{quiet}) {
 116                         printf ("[Connect from %s %s]\n", $hostname, $ipaddr);
 117                 }
 118                 if ($self->{allow} && @{$self->{allow}}) {
 119                         unless ((grep { $hostname =~ /$_/ } @{$self->{allow}}) || (grep { $ipaddr =~ /$_/ } @{$self->{allow}})) {
 120                                 print "{failed on allow}\n" unless $self->{quiet};
 121                                 $client->print($self->{sorry});
 122                                 $client->close;
 123                                 next;
 124                         }
 125                 }
 126                 if ($self->{deny} && @{$self->{deny}}) {
 127                         if ((grep { $hostname =~ /$_/ } @{$self->{deny}}) || (grep { $ipaddr =~ /$_/ } @{$self->{deny}})) {
 128                                 print "{failed on deny}\n" unless $self->{quiet};
 129                                 $client->print($self->{sorry});
 130                                 $client->close;
 131                                 next;
 132                         }
 133                 }
 134
 135                 # fork off a copy of myself, we don't exec, merely carry on regardless
 136                 # in the forked program, that should mean that we use the minimum of extra
 137                 # resources 'cos we are sharing everything already.
 138                 my $pid = fork();
 139                 die "bot: can't fork" unless defined $pid;
 140                 if ($pid) {
 141
 142                         # in parent
 143                         print "{child $pid created}\n" unless $self->{quiet};
 144                         close $client;
 145                 } else {
 146
 147                         # in child
 148                         $SIG{'INT'} = $SIG{'TERM'} = $SIG{CHLD} = 'DEFAULT';
 149                         $server->close;
 150                         delete $self->{parent};
 151                         die "No Child function defined" unless $self->{child} && ref $self->{child};
 152                         &{$self->{child}}($client);
 153                         $client->close;
 154                         return;
 155                 }
 156         }
 157 }
 158
 159 sub reaper {
 160         my $child;
 161         $child = wait;
 162         $SIG{CHLD} = \&reaper;  # still loathe sysV
 163 }
 164
 165 1;
 166
 167
 168
 169