File Coverage

blib/lib/Net/Daemon.pm

Criterion	Covered	Total	%
statement	30	288	10.4
branch	0	174	0.0
condition	0	60	0.0
subroutine	10	30	33.3
pod	0	16	0.0
total	40	568	7.0

# -*- perl -*-
#
#   $Id: Daemon.pm,v 1.3 1999/09/26 14:50:12 joe Exp $
#
#   Net::Daemon - Base class for implementing TCP/IP daemons
#
#   Copyright (C) 1998, Jochen Wiedmann
#                       Am Eisteich 9
#                       72555 Metzingen
#                       Germany
#
#                       Phone: [phone]
#                       Email: [e-mail]
#
#   All rights reserved.
#
#   You may distribute this package under the terms of either the GNU
#   General Public License or the Artistic License, as specified in the
#   Perl README file.
#
############################################################################

require 5.004;
use strict;

use Getopt::Long ();
use Symbol ();
use IO::Socket ();
use Config ();
use Net::Daemon::Log ();
use POSIX ();


package Net::Daemon;

$Net::Daemon::VERSION = '0.48';

# Dummy share() in case we're >= 5.10. If we are, require/import of
# threads::shared will replace it appropriately.
my $this_is_510 = $^V ge v5.10.0;
if ($this_is_510) {
    eval { require threads; };
    eval { require threads::shared; };
}


@Net::Daemon::ISA = qw(Net::Daemon::Log);

#
#   Regexps aren't thread safe, as of 5.00502 :-( (See the test script
#   regexp-threads.)
#
$Net::Daemon::RegExpLock = 1;
threads::shared::share(\$Net::Daemon::RegExpLock) if $this_is_510;

use vars qw($exit);

############################################################################
#
#   Name:    Options (Class method)
#
#   Purpose: Returns a hash ref of command line options
#
#   Inputs:  $class - This class
#
#   Result:  Options array; any option is represented by a hash ref;
#            used keys are 'template', a string suitable for describing
#            the option to Getopt::Long::GetOptions and 'description',
#            a string for the Usage message
#
############################################################################

sub Options ($) {
    { 'catchint' => { 'template' => 'catchint!',
		      'description' => '--nocatchint            '
		          . "Try to catch interrupts when calling system\n"
		          . '                        '
		          . 'functions like bind(), recv()), ...'
		    },
      'childs' => { 'template' => 'childs=i',
		    'description' =>  '--childs           '
			. 'Set number of preforked childs, implies mode=single.' },
      'chroot' => { 'template' => 'chroot=s',
		    'description' =>  '--chroot           '
			. 'Change rootdir to given after binding to port.' },
      'configfile' => { 'template' => 'configfile=s',
			'description' =>  '--configfile      '
			    . 'Read options from config file .' },
      'debug' => { 'template' => 'debug',
		   'description' =>  '--debug                 '
		       . 'Turn debugging mode on'},
      'facility' => { 'template' => 'facility=s',
		      'description' => '--facility    '
			  . 'Syslog facility; defaults to \'daemon\'' },
      'group' => { 'template' => 'group=s',
		   'description' => '--group            '
		       . 'Change gid to given group after binding to port.' },
      'help' => { 'template' => 'help',
		  'description' => '--help                  '
		      . 'Print this help message' },
      'localaddr' => { 'template' => 'localaddr=s',
		       'description' => '--localaddr         '
			   . 'IP number to bind to; defaults to INADDR_ANY' },
      'localpath' => { 'template' => 'localpath=s',
		       'description' => '--localpath       '
		           . 'UNIX socket domain path to bind to' },
      'localport' => { 'template' => 'localport=s',
		       'description' => '--localport       '
			   . 'Port number to bind to' },
      'logfile' => { 'template' => 'logfile=s',
		     'description' => '--logfile         '
		         . 'Force logging to ' },
      'loop-child' => { 'template' => 'loop-child',
		       'description' => '--loop-child            '
			      . 'Create a child process for loops' },
      'loop-timeout' => { 'template' => 'loop-timeout=f',
		       'description' => '--loop-timeout    '
			      . 'Looping mode,  seconds per loop' },
      'mode' => { 'template' => 'mode=s',
		  'description' => '--mode            '
		      . 'Operation mode (threads, fork or single)' },
      'pidfile' => { 'template' => 'pidfile=s',
		     'description' => '--pidfile         '
			 . 'Use  as PID file' },
      'proto' => { 'template' => 'proto=s',
		   'description' => '--proto         '
		   . 'transport layer protocol: tcp (default) or unix' },
      'user' => { 'template' => 'user=s',
		  'description' => '--user            '
		      . 'Change uid to given user after binding to port.' },
      'version' => { 'template' => 'version',
		     'description' => '--version               '
			 . 'Print version number and exit' } }
}


############################################################################
#
#   Name:    Version (Class method)
#
#   Purpose: Returns version string
#
#   Inputs:  $class - This class
#
#   Result:  Version string; suitable for printed by "--version"
#
############################################################################

sub Version ($) {
    "Net::Daemon server, Copyright (C) 1998, Jochen Wiedmann";
}


############################################################################
#
#   Name:    Usage (Class method)
#
#   Purpose: Prints usage message
#
#   Inputs:  $class - This class
#
#   Result:  Nothing; aborts with error status
#
############################################################################

sub Usage ($) {
    my($class) = shift;
    my($options) = $class->Options();
    my(@options) = sort (keys %$options);

    print STDERR "Usage: $0 \n\nPossible options are:\n\n";
    my($key);
    foreach $key (sort (keys %$options)) {
	my($o) = $options->{$key};
	print STDERR "  ", $o->{'description'}, "\n" if $o->{'description'};
    }
    print STDERR "\n", $class->Version(), "\n";
    exit(1);
}



############################################################################
#
#   Name:    ReadConfigFile (Instance method)
#
#   Purpose: Reads the config file.
#
#   Inputs:  $self - Instance
#            $file - config file name
#            $options - Hash of command line options; these are not
#                really for being processed by this method. We pass
#                it just in case. The new() method will process them
#                at a later time.
#            $args - Array ref of other command line options.
#
############################################################################

sub ReadConfigFile {
    my($self, $file, $options, $args) = @_;
    if (! -f $file) {
	$self->Fatal("No such config file: $file");
    }
    my $copts = do $file;
    if ($@) {
	$self->Fatal("Error while processing config file $file: $@");
    }
    if (!$copts || ref($copts) ne 'HASH') {
	$self->Fatal("Config file $file did not return a hash ref.");
    }
    # Override current configuration with config file options.
    while (my($var, $val) = each %$copts) {
	$self->{$var} = $val;
    }
}


############################################################################
#
#   Name:    new (Class method)
#
#   Purpose: Constructor
#
#   Inputs:  $class - This class
#            $attr - Hash ref of attributes
#            $args - Array ref of command line arguments
#
#   Result:  Server object for success, error message otherwise
#
############################################################################

sub new ($$;$) {
    my($class, $attr, $args) = @_;
    my($self) = $attr ? \%$attr : {};
    bless($self, (ref($class) || $class));

    my $options = ($self->{'options'} ||= {});
    $self->{'args'} ||= [];
    if ($args) {
	my @optList = map { $_->{'template'} } values(%{$class->Options()});

	local @ARGV = @$args;
	if (!Getopt::Long::GetOptions($options, @optList)) {
	    $self->Usage();
	}
	@{$self->{'args'}} = @ARGV;

	if ($options->{'help'}) {
	    $self->Usage();
	}
	if ($options->{'version'}) {
	    print STDERR $self->Version(), "\n";
	    exit 1;
	}
    }

    my $file = $options->{'configfile'}  ||  $self->{'configfile'};
    if ($file) {
	$self->ReadConfigFile($file, $options, $args);
    }
    while (my($var, $val) = each %$options) {
	$self->{$var} = $val;
    }

    if ($self->{'childs'}) {
	$self->{'mode'} = 'single';
    } elsif (!defined($self->{'mode'})) {
	if (eval { require threads }) {
	    $self->{'mode'} = 'ithreads';
	} elsif (eval { require Thread }) {
	    $self->{'mode'} = 'threads';
	} else {
	    my $fork = 0;
	    if ($^O ne "MSWin32") {
		my $pid = eval { fork() };
		if (defined($pid)) {
		    if (!$pid) { exit; } # Child
		    $fork = 1;
		    wait;
	        }
	    }
	    if ($fork) {
		$self->{'mode'} = 'fork';
	    } else {
		$self->{'mode'} = 'single';
	    }
	}
    }

    if ($self->{'mode'} eq 'ithreads') {
        no warnings 'redefine';
	require threads;
        use warnings 'redefine';
    } elsif ($self->{'mode'} eq 'threads') {
	require Thread;
    } elsif ($self->{'mode'} eq 'fork') {
	# Initialize forking mode ...
    } elsif ($self->{'mode'} eq 'single') {
	# Initialize single mode ...
    } else {
	$self->Fatal("Unknown operation mode: $self->{'mode'}");
    }
    $self->{'catchint'} = 1 unless exists($self->{'catchint'});
    $self->Debug("Server starting in operation mode $self->{'mode'}");
    if ($self->{'childs'}) {
	$self->Debug("Preforking $self->{'childs'} child processes ...");
    }

    $self;
}

sub Clone ($$) {
    my($proto, $client) = @_;
    my $self = { %$proto };
    $self->{'socket'} = $client;
    $self->{'parent'} = $proto;
    bless($self, ref($proto));
    $self;
}


############################################################################
#
#   Name:    Accept (Instance method)
#
#   Purpose: Called for authentication purposes
#
#   Inputs:  $self - Server instance
#
#   Result:  TRUE, if the client has successfully authorized, FALSE
#            otherwise.
#
############################################################################

sub Accept ($) {
    my $self = shift;
    my $socket = $self->{'socket'};
    my $clients = $self->{'clients'};
    my $from = $self->{'proto'} eq 'unix' ?
	"Unix socket" : sprintf("%s, port %s",
				$socket->peerhost(), $socket->peerport());

    # Host based authorization
    if ($self->{'clients'}) {
	my ($name, $aliases, $addrtype, $length, @addrs);
	if ($self->{'proto'} eq 'unix') {
	    ($name, $aliases, $addrtype, $length, @addrs) =
		('localhost', '', Socket::AF_INET(),
		 length(Socket::IN_ADDR_ANY()),
			Socket::inet_aton('127.0.0.1'));
	} else {
	    ($name, $aliases, $addrtype, $length, @addrs) =
		gethostbyaddr($socket->peeraddr(), Socket::AF_INET());
	}
	my @patterns = @addrs ?
	    map { Socket::inet_ntoa($_) } @addrs  :
	    $socket->peerhost();
	push(@patterns, $name)			if ($name);
	push(@patterns, split(/ /, $aliases))	if $aliases;

	my $found;
	OUTER: foreach my $client (@$clients) {
	    if (!$client->{'mask'}) {
		$found = $client;
		last;
	    }
	    my $masks = ref($client->{'mask'}) ?
		$client->{'mask'} : [ $client->{'mask'} ];

	    #
	    # Regular expressions aren't thread safe, as of
	    # 5.00502 :-(
	    #
	    my $lock;
	    $lock = lock($Net::Daemon::RegExpLock)
		if ($self->{'mode'} eq 'threads');
	    foreach my $mask (@$masks) {
		foreach my $alias (@patterns) {
		    if ($alias =~ /$mask/) {
			$found = $client;
			last OUTER;
		    }
		}
	    }
	}

	if (!$found  ||  !$found->{'accept'}) {
	    $self->Error("Access not permitted from $from");
	    return 0;
	}
	$self->{'client'} = $found;
    }

    $self->Debug("Accepting client from $from");
    1;
}


############################################################################
#
#   Name:    Run (Instance method)
#
#   Purpose: Does the real work
#
#   Inputs:  $self - Server instance
#
#   Result:  Nothing; returning will make the connection to be closed
#
############################################################################

sub Run ($) {
}


############################################################################
#
#   Name:    Done (Instance method)
#
#   Purpose: Called by the server before doing an accept(); a TRUE
#            value makes the server terminate.
#
#   Inputs:  $self - Server instance
#
#   Result:  TRUE or FALSE
#
#   Bugs:    Doesn't work in forking mode.
#
############################################################################

sub Done ($;$) {
    my $self = shift;
    $self->{'done'} = shift if @_;
    $self->{'done'}
}


############################################################################
#
#   Name:    Loop (Instance method)
#
#   Purpose: If $self->{'loop-timeout'} option is set, then this method
#            will be called every "loop-timeout" seconds.
#
#   Inputs:  $self - Server instance
#
#   Result:  Nothing; aborts in case of trouble. Note, that this is *not*
#            trapped and forces the server to exit.
#
############################################################################

sub Loop {
}


############################################################################
#
#   Name:    ChildFunc (Instance method)
#
#   Purpose: If possible, spawn a child process which calls a given
#	     method. In server mode single the method is called
#            directly.
#
#   Inputs:  $self - Instance
#            $method - Method name
#            @args - Method arguments
#
#   Returns: Nothing; aborts in case of problems.
#
############################################################################

sub ChildFunc {
    my($self, $method, @args) = @_;
    if ($self->{'mode'} eq 'single') {
	$self->$method(@args);
    } elsif ($self->{'mode'} eq 'threads') {
	my $startfunc = sub {
	    my $self = shift;
	    my $method = shift;
	    $self->$method(@_)
	};
	Thread->new($startfunc, $self, $method, @args)
	    or die "Failed to create a new thread: $!";
    } elsif ($self->{'mode'} eq 'ithreads') {
	my $startfunc = sub {
	    my $self = shift;
	    my $method = shift;
	    $self->$method(@_)
	};
	threads->new($startfunc, $self, $method, @args)
	    or die "Failed to create a new thread: $!";
    } else {
	my $pid = fork();
	die "Cannot fork: $!" unless defined $pid;
	return if $pid;        # Parent
	$self->$method(@args); # Child
	exit(0);
    }
}


############################################################################
#
#   Name:    Bind (Instance method)
#
#   Purpose: Binds to a port; if successfull, it never returns. Instead
#            it accepts connections. For any connection a new thread is
#            created and the Accept method is executed.
#
#   Inputs:  $self - Server instance
#
#   Result:  Error message in case of failure
#
############################################################################

sub HandleChild {
    my $self = shift;
    $self->Debug("New child starting ($self).");
    eval {
	if (!$self->Accept()) {
	    $self->Error('Refusing client');
	} else {
	    $self->Debug('Accepting client');
	    $self->Run();
	}
    };
    $self->Error("Child died: $@") if $@;
    $self->Debug("Child terminating.");
    $self->Close();
};

sub SigChildHandler {
    my $self = shift; my $ref = shift;
    return 'IGNORE' if $self->{'mode'} eq 'fork' || $self->{'childs'};
    return undef; # Don't care for childs.
}

sub Bind ($) {
    my $self = shift;
    my $fh;
    my $child_pid;

    my $reaper = $self->SigChildHandler(\$child_pid);
    $SIG{'CHLD'} = $reaper if $reaper;

    if (!$self->{'socket'}) {
	$self->{'proto'} ||= ($self->{'localpath'}) ? 'unix' : 'tcp';

	if ($self->{'proto'} eq 'unix') {
	    my $path = $self->{'localpath'}
		or $self->Fatal('Missing option: localpath');
	    unlink $path;
	    $self->Fatal("Can't remove stale Unix socket ($path): $!")
		if -e $path;
	    my $old_umask = umask 0;
	    $self->{'socket'} =
		IO::Socket::UNIX->new('Local' => $path,
				      'Listen' => $self->{'listen'} || 10)
		      or $self->Fatal("Cannot create Unix socket $path: $!");
	    umask $old_umask;
	} else {
	    $self->{'socket'} = IO::Socket::INET->new
		( 'LocalAddr' => $self->{'localaddr'},
		  'LocalPort' => $self->{'localport'},
		  'Proto'     => $self->{'proto'} || 'tcp',
		  'Listen'    => $self->{'listen'} || 10,
		  'Reuse'     => 1)
		    or $self->Fatal("Cannot create socket: $!");
	}
    }
    $self->Log('notice', "Server starting");

    if ((my $pidfile = ($self->{'pidfile'} || '')) ne 'none') {
	$self->Debug("Writing PID to $pidfile");
	my $fh = Symbol::gensym();
	$self->Fatal("Cannot write to $pidfile: $!")
	    unless (open (OUT, ">$pidfile")
		    and (print OUT "$$\n")
		    and close(OUT));
    }

    if (my $dir = $self->{'chroot'}) {
	$self->Debug("Changing root directory to $dir");
	if (!chroot($dir)) {
	    $self->Fatal("Cannot change root directory to $dir: $!");
	}
    }
    if (my $group = $self->{'group'}) {
	$self->Debug("Changing GID to $group");
	my $gid;
	if ($group !~ /^\d+$/) {
	    if (defined(my $gid = getgrnam($group))) {
		$group = $gid;
	    } else {
		$self->Fatal("Cannot determine gid of $group: $!");
	    }
	}
	$( = ($) = $group);
    }
    if (my $user = $self->{'user'}) {
	$self->Debug("Changing UID to $user");
	my $uid;
	if ($user !~ /^\d+$/) {
	    if (defined(my $uid = getpwnam($user))) {
		$user = $uid;
	    } else {
		$self->Fatal("Cannot determine uid of $user: $!");
	    }
	}
	$< = ($> = $user);
    }

    if ($self->{'childs'}) {
      my $pid;

      my $childpids = $self->{'childpids'} = {};
      for (my $n = 0; $n < $self->{'childs'}; $n++) {
	$pid = fork();
	die "Cannot fork: $!" unless defined $pid;
	if (!$pid) { #Child
	  $self->{'mode'} = 'single';
	  last;
	}
	# Parent
	$childpids->{$pid} = 1;
      }
      if ($pid) {
	# Parent waits for childs in a loop, then exits ...
	# We could also terminate the parent process, but
	# if the parent is still running we can kill the
	# whole group by killing the childs.
	my $childpid;
	$exit = 0;
	$SIG{'TERM'} = sub { die };
	$SIG{'INT'}  = sub { die };
	eval {
	  do {
	    $childpid = wait;
	    delete $childpids->{$childpid};
	    $self->Debug("Child $childpid has exited");
	  } until ($childpid <= 0 || $exit || keys(%$childpids) == 0);
	};
	my @pids = keys %{$self -> {'childpids'}};
	if (@pids) {
	  $self->Debug("kill TERM childs: " . join(",", @pids));
	  kill 'TERM', @pids if @pids ; # send a TERM to all childs
	}
	exit (0);
      }
    }

    my $time = $self->{'loop-timeout'} ?
	(time() + $self->{'loop-timeout'}) : 0;

    my $client;
    while (!$self->Done()) {
	undef $child_pid;
	my $rin = '';
	vec($rin,$self->{'socket'}->fileno(),1) = 1;
	my($rout, $t);
	if ($time) {
	    my $tm = time();
	    $t = $time - $tm;
	    $t = 0 if $t < 0;
	    $self->Debug("Loop time: time=$time now=$tm, t=$t");
	}
	my($nfound) = select($rout=$rin, undef, undef, $t);
	if ($nfound < 0) {
	    if (!$child_pid  and
		($! != POSIX::EINTR() or !$self->{'catchint'})) {
		$self->Fatal("%s server failed to select(): %s",
			     ref($self), $self->{'socket'}->error() || $!);
	    }
	} elsif ($nfound) {
	    my $client = $self->{'socket'}->accept();
	    if (!$client) {
		if (!$child_pid  and
		    ($! != POSIX::EINTR() or !$self->{'catchint'})) {
		    $self->Error("%s server failed to accept: %s",
				 ref($self), $self->{'socket'}->error() || $!);
		}
	    } else {
		if ($self->{'debug'}) {
		    my $from = $self->{'proto'} eq 'unix' ?
			'Unix socket' :
			sprintf('%s, port %s',
				# SE 19990917: display client data!!
				$client->peerhost(),
				$client->peerport());
		    $self->Debug("Connection from $from");
		}
		my $sth = $self->Clone($client);
		$self->Debug("Child clone: $sth\n");
		$sth->ChildFunc('HandleChild') if $sth;
		if ($self->{'mode'} eq 'fork') {
                    $self->ServClose($client);
		}
	    }
	}
	if ($time) {
	    my $t = time();
	    if ($t >= $time) {
		$time = $t;
		if ($self->{'loop-child'}) {
		    $self->ChildFunc('Loop');
		} else {
		    $self->Loop();
		}
		$time += $self->{'loop-timeout'};
	    }
	}
    }
    $self->Log('notice', "%s server terminating", ref($self));
}

sub Close {
    my $socket = shift->{'socket'};
    $socket->close() if $socket;
}

sub ServClose {
    my $self = shift;
    my $socket = shift;
    $socket->close() if $socket;
}


1;

__END__