X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FForkingServer.pm;fp=perl%2FForkingServer.pm;h=31e01166e3e31e383dd34e5cdc081a7a4081fd33;hb=9b16ab623efe48723ba472624cf4020b155f683c;hp=0000000000000000000000000000000000000000;hpb=a453254d687774f352822492d500330a09fd7ebe;p=spider.git

diff --git a/perl/ForkingServer.pm b/perl/ForkingServer.pm
new file mode 100755
index 00000000..31e01166
--- /dev/null
+++ b/perl/ForkingServer.pm
@@ -0,0 +1,169 @@
+#!/usr/bin/perl -w
+#
+# This is a forking server class (ofcourse it is :-)
+#
+# You can only have one of these running at a time, so there!
+#
+# I am not using AUTOLOAD at the moment in a general spirit
+# of 'inat' (a wonderfully succinct serbo-croat word and state
+# of being) - So there! Yah boo sucks! Won't! Nurps! 
+#
+# Can I just say (as a policy statement) that I hope I never have
+# to write any more C code (other than to extend or interface to perl).
+#
+# Copyright (c) 1999 - Dirk Koopman, Tobit Computer Co Ltd
+#
+# $Id$
+#
+
+package ForkingServer;
+
+use strict;
+
+use IO::File;
+use IO::Socket;
+use Net::hostent;
+
+use Carp;
+
+sub new
+{
+	my $type = shift;
+	my $self = {};
+	my $s = shift;
+	if ($s) {
+		if (ref $s) {
+			$self->{child} = $s;
+		} else {
+			$self->{child} = eval $s;
+			confess $@ if $@;
+		}
+	}
+	$self->{port} = shift || 9000;
+	$self->{sort} = 'tcp';
+	$self->{sorry} = "Bog OFF!\n";
+	$self->{allow} = [ '^localhost\$', '^127.0.0' ];
+	return bless $self, $type;
+}
+
+sub port
+{
+	my $self = shift;
+	my $port = shift;
+	$self->{port} = $port;
+}
+
+sub sort
+{
+	my $self = shift;
+	my $sort = shift;
+	confess "sort must be tcp or udp" unless $sort eq 'tcp' || $sort eq 'udp'; 
+	$self->{sort} = $sort;
+}
+
+sub allow
+{
+	my $self = shift;
+	$self->{allow} = ref $_[0] ? shift : [ @_ ];
+}
+
+sub deny
+{
+	my $self = shift;
+	$self->{deny} = ref $_[0] ? shift : [ @_ ];
+}
+
+sub sorry
+{
+	my $self = shift;
+	$self->{sorry} = shift;
+}
+
+sub quiet
+{
+	my $self = shift;
+	$self->{quiet} = shift;
+}
+
+sub is_parent
+{
+	my $self = shift;
+	return $self->{parent};
+}
+
+sub run {
+	my $self = shift;
+	
+	my $server = IO::Socket::INET->new( Proto     => $self->{sort},
+										LocalPort => $self->{port},
+										Listen    => SOMAXCONN,
+										Reuse     => 1);
+
+	my $client;
+	
+	confess "bot: can't setup server $!" unless $server;
+	print "[Server $0 accepting clients on port $self->{port}]\n" unless $self->{quiet};
+	
+	$SIG{CHLD} = \&reaper;
+	$self->{parent} = 1;
+	
+	while ($client = $server->accept()) {
+		$client->autoflush(1);
+		my $hostinfo = gethostbyaddr($client->peeraddr);
+		my $hostname = $hostinfo->name;
+		my $ipaddr = $client->peerhost;
+		unless ($self->{quiet}) {
+			printf ("[Connect from %s %s]\n", $hostname, $ipaddr);
+		}
+		if ($self->{allow} && @{$self->{allow}}) {
+			unless ((grep { $hostname =~ /$_/ } @{$self->{allow}}) || (grep { $ipaddr =~ /$_/ } @{$self->{allow}})) {
+				print "{failed on allow}\n" unless $self->{quiet};
+				$client->print($self->{sorry});
+				$client->close;
+				next;
+			}
+		}
+		if ($self->{deny} && @{$self->{deny}}) {
+			if ((grep { $hostname =~ /$_/ } @{$self->{deny}}) || (grep { $ipaddr =~ /$_/ } @{$self->{deny}})) {
+				print "{failed on deny}\n" unless $self->{quiet};
+				$client->print($self->{sorry});
+				$client->close;
+				next;
+			}
+		}
+		
+		# fork off a copy of myself, we don't exec, merely carry on regardless
+		# in the forked program, that should mean that we use the minimum of extra
+		# resources 'cos we are sharing everything already.
+		my $pid = fork();
+		die "bot: can't fork" unless defined $pid;
+		if ($pid) {
+			
+			# in parent
+			print "{child $pid created}\n" unless $self->{quiet};
+			close $client;
+		} else {
+			
+			# in child
+			$SIG{'INT'} = $SIG{'TERM'} = $SIG{CHLD} = 'DEFAULT';
+			$server->close;
+			delete $self->{parent};
+			die "No Child function defined" unless $self->{child} && ref $self->{child};
+			&{$self->{child}}($client);
+			$client->close;
+			return;			
+		}
+	}
+}
+
+sub reaper {
+	my $child;
+	$child = wait;
+	$SIG{CHLD} = \&reaper;  # still loathe sysV
+}
+
+1;
+
+
+
+