File Coverage

blib/lib/Net/Daemon.pm

Criterion	Covered	Total	%
statement	33	282	11.7
branch	0	166	0.0
condition	0	60	0.0
subroutine	11	30	36.6
pod	0	16	0.0
total	44	554	7.9

############################################################################
#
#   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.
#
############################################################################

package Net::Daemon;

use strict;
use warnings;

use Config;

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

our $VERSION = '0.49';
our @ISA = qw(Net::Daemon::Log);

our $RegExpLock = 1;

# Dummy share() in case we're >= 5.10. If we are, require/import of
# threads::shared will replace it appropriately.
# But ONLY if we are built with threads and forks has not already been loaded.
my $use_ithreads = ( $^V ge v5.10.0 && $Config{'useithreads'} && !$INC{'forks.pm'} ) ? 1 : 0;
if ($use_ithreads) {
    eval { require threads; };
    eval { require threads::shared; };
    threads::shared::share( $RegExpLock ) if $forks::threads; # Assuming this isn't threads masquerading as forks.
}

our $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::Spec->rel2abs($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';
        }
        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 '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($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 '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__