File Coverage

blib/lib/Net/Peep/BC.pm

Criterion	Covered	Total	%
statement	153	266	57.5
branch	24	74	32.4
condition	9	30	30.0
subroutine	29	37	78.3
pod	0	18	0.0
total	215	425	50.5

package Net::Peep::BC;

require 5.00503;
use strict;
# use warnings; # commented out for 5.005 compatibility
use Carp;

require Exporter;

use vars qw{ @ISA %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION };

@ISA = qw(Exporter);
%EXPORT_TAGS = ( 'all' => [ qw( ) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT = qw( );
$VERSION = do { my @r = (q$Revision: 1.10 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

use Socket;
use Sys::Hostname;
use Net::Peep::Parser;
use Net::Peep::Conf;
use Net::Peep::Log;
use Net::Peep::Scheduler;

use vars qw{ %Leases %Servers %Defaults $Scheduler $Alarmtime };

%Leases = %Servers = ();

%Defaults = (
	type => 0,
	location => 128,
	priority => 0,
	volume => 128,
	dither => 0,
	sound => 0
);

$Scheduler = new Net::Peep::Scheduler;

$Alarmtime = 30;

# Peep protocol constants
use constant PROT_MAJORVER => 1;
use constant PROT_MINORVER => 0;
use constant PROT_BCSERVER => 0;
use constant PROT_BCCLIENT => 1;
use constant PROT_SERVERSTILLALIVE => 2;
use constant PROT_CLIENTSTILLALIVE => 3;
use constant PROT_CLIENTEVENT => 4;
use constant PROT_CLASSDELIM => '!';

sub new {

	my $self = shift;
	my $class = ref($self) || $self;
	my $this = {};
	bless $this, $class;

	$this->initialize(@_);

	return $this;

} # end sub new

sub initialize {

	my $self = shift;
	my $client = shift || confess "Error:  Client not found";
	my $configuration = shift || confess "Error:  Configuration not found";

	# put the configuration object in a place where all the other
	# methods can find it
	$self->setConfiguration($configuration);

	my %options = $configuration->getOptionsHash($client);

	# FIXIT: This is silly and redundant.  The object that instantiates
	# the Net::Peep::BC object already has all of the options set and a
	# configuration object.  Net::Peep::BC shouldn't need to build its own
	# stable of options.  Deal with it later ....

	# Populate the object attributes either by the class default
	# attributes or the options arguments passed in

	for my $key (keys %Defaults) {
		if ($key ne 'dither') {
			if (exists $options{$key}) {
				$self->setOption($key,$options{$key});
			} else {
				$self->setOption($key,$Defaults{$key});
			}
		}
	}

	# Make allowances for the two possible meanings of dither
	# dither is based exclusively on the value of 'type'
	$self->getOption('type') ? $self->setOption('dither',255) : $self->setOption('dither',0);

	# Now initialize our socket
	my $port = $configuration->getClientPort($client);
	$self->logger()->debug(7,"Initializing socket on port $port ...");
	my $addr = INADDR_ANY;
	my $proto = getprotobyname('udp');
	my $paddr = sockaddr_in($port, $addr);
	socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) or confess "Socket error: $!";
	if ($configuration->getOption($client,'autodiscovery')) {
		bind(SOCKET, $paddr)                        or confess "Bind error: $!";
	}
	$self->logger()->debug(7,"\tSocket initialized.");

	#Set the socket option for the broadcast
	setsockopt SOCKET, SOL_SOCKET, SO_BROADCAST | SO_REUSEADDR, 1;

	#Let everyone know we're alive
	$self->hello( PROT_BCCLIENT );

	#Start up the alarm. Once this handler gets started, we'll have it
	#work concurrently with the program to handle host lists
	if ($configuration->getOption($client,'autodiscovery')) {
		$Scheduler->schedulerAddEvent(
			$self->getConfiguration()->client(),
			$Alarmtime,
			0.0,
			'client',
			sub { $self->handlealarm( PROT_CLIENTSTILLALIVE ) },
			'',
			1 # 1 => repeated event, 0 => single event
		);
	}

} # end sub initialize

sub hello {

	my $self = shift;
	my $constant = shift;
	my $configuration = $self->getConfiguration() || confess "Error:  Configuration not found";

	# Send out our broadcast to let everybody know we're alive
	# Note - we want to send these broadcasts to the servers within
	# the class definition. So, we use getServer() - Mike
	for my $class ($configuration->getClassList()) {
		$self->logger()->debug(7,"Getting broadcast for class [$class]");
		my $broadcasts = $configuration->getServer($class);

		for my $broadcast (@$broadcasts) {
			my ($zone, $port) = ($broadcast->{'name'}, $broadcast->{'port'});
			$self->logger()->debug(7,"Socketing to zone [$zone] and port [$port] ...");
			my $iaddr = inet_aton($zone);
			my $bcaddr = sockaddr_in($port, $iaddr);

			#Assemble the packet and send it
			my $packet = $self->assemble_bc_packet($constant);
			if (defined($constant) && $constant == PROT_CLIENTSTILLALIVE) {
				$self->logger()->debug(7,"Letting [$zone:$port] know we're still alive ...");
			} else {
				$self->logger()->debug(7,"Sending a friendly hello to address [$zone:$port] ...");
			}
			if (defined(send(SOCKET, $packet, 0, $bcaddr))) {
				$self->logger()->debug(9,"\tPacket of length ".length($packet)." sent.");
			} else {
				$self->logger()->log("Send broadcast error: $!");
			}
		}
	}

} # end sub hello

sub getConfiguration {

	my $self = shift;
	confess "Error retrieving configuration:  The configuration has not been set yet."
	unless exists $self->{"__CONFIGURATOR"};
	return $self->{"__CONFIGURATOR"};

} # end sub getConfiguration

sub setConfiguration {

	my $self = shift;
	if (@_) {
		$self->{"__CONFIGURATOR"} = shift;
	} else {
		confess "Cannot set configuration:  No configuration object found.";
	}
	return 1;

} # end sub setConfiguration

# Function to assemble a broadcast packet with an appropriate
# identifier string
sub assemble_bc_packet {

	my $self = shift;
	my $constant = shift;
	my $configuration = $self->getConfiguration();
	my $identifier = join PROT_CLASSDELIM, ($configuration->getClassList());
	$identifier .= PROT_CLASSDELIM;
	return pack("CCCCA128",
		PROT_MAJORVER,
		PROT_MINORVER,
		$constant,
		0,
		$identifier);

} # end sub assemble_bc_packet

# returns a logging object
sub logger {

	my $self = shift;
	if ( ! exists $self->{'__LOGGER'} ) { $self->{'__LOGGER'} = new Net::Peep::Log }
	return $self->{'__LOGGER'};

} # end sub logger

sub close {

	my $self = shift;
	close SOCKET;

} # end sub close

# Send out a packet
sub send {

	my $self = shift;
	my $client = shift;
	my %options = @_;

	$self->logger()->debug(7,"Sending packet to server(s) ...");

	my $configuration = $self->getConfiguration();

	my $type = exists($options{'type'}) ? $options{'type'} : $self->getOption('type');
	my $location = exists($options{'location'}) ? $options{'location'} : $self->getOption('location');
	my $priority = exists($options{'priority'}) ? $options{'priority'} :  $self->getOption('priority');
	my $volume = exists($options{'volume'}) ? $options{'volume'} : $self->getOption('volume');
	my $dither = exists($options{'dither'}) ? $options{'dither'} : $self->getOption('dither');
	my $sound = exists($options{'sound'}) ? $options{'sound'} : $self->getOption('sound');

	$self->logger()->debug(9,"type=[$type] location=[$location] priority=[$priority] volume=[$volume] dither=[$dither] sound=[$sound]");

	#Now convert the sound name into the number if it isn't a number already
	if ($sound !~ /\d+/) {
		my $hash;
		$hash = $configuration->getEvent($sound) if $configuration->isEvent($sound);
		$hash = $configuration->getState($sound) if $configuration->isState($sound);

		if (ref($hash)) {
			my $index = $hash->{'index'};
			$self->logger()->debug(5,"Sound [$sound] reassigned:  Now it is [$index]");
			$sound = $index;
		} else {
			$self->logger()->log(ref($self),": Warning: Asking Peep to play a non existent sound: [$sound]");
			return;
		}
	}

	if ($configuration->getOption($client,'autodiscovery')) {

		# Now sendout to all the servers in our server list
		for my $server (keys %Servers) {
			my ($serverport,$serverip) = unpack_sockaddr_in($server);
			$serverip = inet_ntoa($serverip);
			$self->logger()->debug(7,"Notifying server [$serverip:$serverport] of event or sound [$sound] ...");
			$self->sendout($type, $sound, $location, $priority, $volume, $dither, $server);
		}

	} else {

		# Just send a packet to the server and port specified on the command-line
		my $port = $configuration->getOption($client,'port') || confess "Error:  Expecting nonzero port!";
		my $host = $configuration->getOption($client,'server') || confess "Error:  Expecting nonzero host!";
		$self->logger()->debug(7,"Notifying server [$host:$port] of event or sound [$sound] ...");
		$host = inet_aton($host);
		my $server = sockaddr_in($port,$host);
		$self->sendout($type, $sound, $location, $priority, $volume, $dither, $server);

	}

} # end sub send

sub sendout {

	my $self = shift;
	my ($type,$sound,$location,$priority,$volume,$dither,$server)
	    = @_;
	my $mix_in_time = 0;

	my ($serverport,$serverip) = unpack_sockaddr_in($server);
	$serverip = inet_ntoa($serverip);
	$self->logger()->debug(7,"type=[$type] sound=[$sound] location=[$location] priority=[$priority] volume=[$volume] dither=[$dither] server=[$serverip:$serverport]") ;

	#Now we need to build the appropriate network packet
	my $packet = pack("CCCCC8",
		PROT_MAJORVER,
		PROT_MINORVER,
		PROT_CLIENTEVENT,
		0,
		$type, $sound, $location, $priority, $volume, $dither);

	if (not defined(CORE::send(SOCKET, $packet, 0, $server))) {
		$self->logger()->debug(7,"Error sending packet to [$serverip:$serverport]:  $!");
		$self->logger()->debug(7,"You may want to check that the server is accepting connections on port [$serverport].");
	}

	return 1;

} # end sub sendout

sub setOption {

	my $self = shift;
	my $option = shift || confess "option not found";
	my $value = shift;
	confess "value not found" unless defined $value;
	$self->{"__OPTIONS"}->{$option} = $value;
	return 1;

} # end sub setOption

sub getOption {

	my $self = shift;
	my $option = shift || confess "option not found";

	if (exists $self->{"__OPTIONS"}->{$option}) {
		return $self->{"__OPTIONS"}->{$option};
	} else {
		confess "Cannot get the option '$option':  It has not yet been set.";
	}

	return 0;

} # end sub setOption

sub handlealarm {

	#Every tick, we wait until we have some input to respond to, then update
	#our server list. Finally, we purge the server list of any impurities and
	#carry on with out business
	my $self = shift;
	my $constant = shift;

	$self->hello($constant);
	$self->updateserverlist();
	$self->purgeserverlist();

	if (scalar(keys %Servers)) {
		$self->logger()->debug(9,"Known servers:");
		for my $server (sort keys %Servers) {
			my ($serverport,$serverip) = unpack_sockaddr_in($server);
			$serverip = inet_ntoa($serverip);
			$self->logger()->debug(9,"\t[$serverip:$serverport]");
		}
	} else {
		$self->logger()->debug(9,"There are currently no known servers.");
	}

	return 1;

} # end sub handlealarm

sub updateserverlist {

	#Poll to see if we've received anything so we can update the server list
	#before we send. Then, send out the packet.
	my $self = shift;

	$self->logger()->debug(9,"Updating server list ...");

	my $rin = "";
	my $rout;
	vec($rin, fileno(SOCKET), 1) = 1;

	if (select($rout = $rin, undef, undef, 0.1)) {
		my $packet;

		$self->logger()->debug(9,"\tReading from socket ...");

		my $server = recv(SOCKET, $packet, 256, 0);  # 256 is safe amount to read
		# Adding a defined argument here because recv can produce errors if
		# a broadcast isn't responded to. Plus, we want to continue anyway.
		if (defined($server) and $server ne '') {
			my ($serverport,$serverip) = unpack_sockaddr_in($server);
			$serverip = inet_ntoa($serverip);

			$self->logger()->debug(7,"\tJust received a packet from [$serverip:$serverport] ...");

			#Verify that this is a server bc packet
			my ($majorver, $minorver, $type, $padding) = unpack("CCCC", $packet);

			$self->addnewserver($server, $packet) if $type == PROT_BCSERVER;
			$self->logger()->debug(7,"\tUpdating server with profile [$majorver:$minorver:$type]") if $type == PROT_SERVERSTILLALIVE;
			$self->updateserver($server, $packet) if $type == PROT_SERVERSTILLALIVE;
		}
	}

} # end updateserverlist

sub purgeserverlist {

	my $self = shift;

	$self->logger()->debug(9,"Purging server list ...");

	for my $server (keys %Servers) {
		if ($Servers{$server}->{'expires'} <= time()) {
			delete $Servers{$server};
			$self->logger()->debug(7,"\tServer purged. Number of known servers: " . scalar (keys %Servers));

			for my $known (keys %Net::Peep::Servers) {
				my ($serverport,$serverip) = unpack_sockaddr_in($server);
				$serverip = inet_ntoa($serverip);
				$self->logger()->debug(7,"\t\t$serverip:$serverport");
			}
		}
	}

} # end sub purgeserverlist

sub addnewserver {

	my $self = shift;

	my ($server, $packet) = @_;

	my $configuration = $self->getConfiguration();

	my ($serverport,$serverip) = unpack_sockaddr_in($server);

	$serverip = inet_ntoa($serverip);

	# Check if this server already exists - because then we shouldn't be
	# doing an add... so abort. This can happen because when the client
	# registers with the server, the server always sends a BC response
	# directly back to the client to make sure that the client really
	# has the server in its hostlist
	if (exists $Servers{$server}) {
		$self->logger()->debug(7,"\tServer [$serverip:$serverport] won't be added to the server list:  It is already in the list.");
		return;
	}

	my ($majorver, $minorver, $type, $padding, $min, $sec, $id) = unpack("CCCCCCA128", $packet);
	my $delim = PROT_CLASSDELIM;

	#Clean up the ID string
	$id =~ /([A-Za-z0-9!\-]*)/;
	my $realid = $1;

	foreach my $class ($configuration->getClassList()) {
		my $str = quotemeta($class.$delim);
		$self->logger()->debug(7,"\tChecking server id [$realid] against class descriptor [$class$delim] ....");

		if ($realid =~ /$str/) {
			$self->logger()->debug(7,"\tMatch found:  Adding server [$serverip:$serverport] to the server list.");
			$self->addserver($server, $min, $sec);
		} else {
			$self->logger()->debug(7,"\tNo match found.  Nothing added to server list.");
		}
	}

	return 1;

} # end sub addnewserver

sub addserver {

	my $self = shift;
	my ($server,$leasemin,$leasesec) = @_;

	$Servers{$server}->{'IP'} = $server;
	$Servers{$server}->{'expires'} = time() + $leasemin*60 + $leasesec;

	$self->logger()->debug(7,"\tServer added. Number of known servers: " . scalar(keys %Servers));
	for my $known (keys %Net::Peep::Servers) {
		my ($serverport,$serverip) = unpack_sockaddr_in($known);
		$serverip = inet_ntoa($serverip);
		$self->logger()->debug(7,"\t\t$serverip:$serverport");
	}

	#Let's send it a "BC" to tell it to add us as well
	my ($serverport,$serverip) = unpack_sockaddr_in($server);
	$serverip = inet_ntoa($serverip);
	$self->logger()->debug(7,"\tSending client BC packet to [$serverip:$serverport] ...");
	defined(CORE::send(SOCKET, $self->assemble_bc_packet(PROT_BCCLIENT), 0, $server)) or confess "Send clientbc error: $!";
	$self->logger()->debug(7,"\tClient BC packet sent successfully.");

	return 1;

} # end sub addserver

sub updateserver {

	my $self = shift;
	my $server = shift;
	my $packet = shift;
	my ($majorver, $minorver, $type, $padding, $min, $sec) = unpack("CCCCCC", $packet);

	$self->logger()->debug(7,"\tServer updated. Number of known servers: " . scalar(keys %Servers));

	$Servers{$server}->{'expires'} = time() + $min*60 + $sec;

	# New send out a client alive
	my $net_packet = pack ("CCCC",
		PROT_MAJORVER,
		PROT_MINORVER,
		PROT_CLIENTSTILLALIVE,
		0);

	$self->logger()->debug(7,"\tSending client still alive packet ...");
	defined(CORE::send(SOCKET, $net_packet, 0, $server)) or confess "Send client still alive error: $!";
	$self->logger()->debug(7,"\tClient still alive packet sent successfully.");

	return 1;

} # end sub updateserver

1;

__END__