File Coverage

blib/lib/IO/Socket/INET/Daemon.pm

Criterion	Covered	Total	%
statement	59	62	95.1
branch	16	20	80.0
condition	5	10	50.0
subroutine	13	13	100.0
pod	6	7	85.7
total	99	112	88.3

package IO::Socket::INET::Daemon;

use strict;
use warnings;

our $VERSION = '0.04';

use Carp;

use IO::Socket::INET;
use IO::Select;


sub new {
	my ($class, %rc) = @_;

	croak "Called with no/invalid port.\n" if(!$rc{port} or $rc{port} =~ /\D/);

	return bless {
		port => $rc{port},
		host => $rc{host} || 'localhost',
		callback => $rc{callback} || {},
		timeout => $rc{timeout},
	}, $class;
}


sub callback {
	my ($self, %callback) = @_;

	@{$self->{callback}}{keys %callback} = values %callback;
}


sub run {
	my ($self) = @_;

	# Create server socket.
	my $host = $self->{sck} = new IO::Socket::INET(
		LocalHost => $self->{host},
		LocalPort => $self->{port},
		Proto => 'tcp',
		ReuseAddr => !0,
		Listen => 32,
	) or return;

	$self->{stop} = 0;
	my $select = $self->{select} = new IO::Select($host);

	# The main loop.
	until($self->{stop}) {
		$self->call('tick', undef);

		# Get readable sockets.
		for my $io ($select->can_read($self->{timeout})) {

			# If the server socket is readable, get the pending incoming
			# connection, call the callback and add the peer to our list.
			if($io == $host) {
				my $peer = $io->accept;

				if($self->call('add', $peer)) {
					$select->add($peer);
				}
				else {
					$self->remove($peer);
				}
			}

			# If it's a peer, call the data callback. Remove peer if the
			# callback returns something false or if the connection is dead.
			elsif($io->connected) {
				if(!$self->call('data', $io)) {
					$self->call('remove', $io);
					$self->remove($io);
				}
			}
			else {
				$self->call('remove', $io);
				$self->remove($io);
			}
		}
	}
}

# Call a callback function. For internal use only. Takes the name of the
# callback (add, remove or data) and the socket handle as arguments. Returns
# true if there was no such callback, it returns non-zero by default, otherwise
# the return value of the callback is returned.
sub call {
	my ($self, $callback, $io) = @_;

	my $func = $self->{callback}->{$callback};

	return $func ? &{$func}($io, $self) : !0;
}

# This closes a connection to a peer and removes it from our socket list.
sub remove {
	my ($self, $io) = @_;

	if($io and $io != $self->{sck}) {
		my $select = $self->{select};

		$select->remove($io);

		$io->shutdown(SHUT_RDWR);
		$io->close;
	}
}

# This simply sets a variable to a true value, so the main loop will stop after
# the next cycle.
sub stop {
	my ($self) = @_;
	$self->{stop} = !0;
}

# This closes all connections and the server socket. Can be called to clean up
# manually, but is also called automatically from DESTROY.
sub destroy {
	my ($self) = @_;

	$self->{stop} = !0;

	my $select = $self->{select};

	if($select) {
		$self->remove($_) for($select->handles);
		delete $self->{select};
	}

	my $host = delete $self->{sck};
	if($host) {
		$host->shutdown(SHUT_RDWR);
		$host->close;
	}
}

sub DESTROY {
	my ($self) = @_;
	$self->destroy;
}

!0;


__END__