File Coverage

blib/lib/Amethyst.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Amethyst;

use strict;
use warnings;
use vars qw(@ISA $VERSION);
use Exporter;
use POE;
use Amethyst::Connection;

$VERSION = '1.00';
@ISA = qw(Exporter);

sub new {
	my $class = shift;
	my $args = ($#_ == 0) ? { %{ (shift) } } : { @_ };

	my %states = map { $_ => "handler_$_" } qw(
					_start _stop _child signal
					add_connection register_connection connect
					add_brain think
					);
	POE::Session->create(
			package_states	=> [ $class => \%states ],
			args			=> [ $args ],
			);
}

sub handler__start {
	my ($kernel, $session, $heap, $args) = @_[KERNEL, SESSION, HEAP, ARG0];
	$heap->{Args} = $args;
	my $name = $args->{Name} || 'amethyst';
	$kernel->alias_set($name);

	print STDERR "Starting Amethyst '$name'\n";

	$heap->{Connections} = { };
	$heap->{Brains} = { };

	$kernel->sig('INT', 'signal');
	$kernel->sig('TERM', 'signal');
}

sub handler_signal {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
	my $signame = $_[ARG0];
	print STDERR "Exiting on signal $signame\n";
	exit;
}

sub handler__stop {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
}

sub handler__child {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
}

sub handler_register_connection {
	my ($kernel, $session, $sender, $heap, $name) =
					@_[KERNEL, SESSION, SENDER, HEAP, ARG0];
	die "No name for connection $sender\n" unless $name;
	$heap->{Connections}->{$name} = $sender->ID;
	print STDERR "Registered connection $name as " . $sender->ID . "\n";
}

sub handler_add_connection {
	my ($kernel, $session, $heap, $package, $args)
			= @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
	eval qq{ require $package; };
	die $@ if $@;
	$package->new($args);
}

# This no longer creates a POE::Session
sub handler_add_brain {
	my ($kernel, $session, $heap, $package, $args)
			= @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
	my $name = $args->{Name} || $package;
	my $priority = $args->{Priority} || 1;

	eval qq{ require $package; };
	if ($@) {
		print STDERR "Amethyst: Failed to add brain $name ($package)\n";
		$heap->{BrainsFailed}->{$name} = 1;
	}
	else {
		my $brain = $package->new($args);
		$heap->{Brains}->{$name} = [ $brain, $name, $priority, ];
		$brain->init();
	}
}

sub handler_connect {
	my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];

	print STDERR "Amethyst: connecting\n";

	unless (%{ $heap->{Brains} }) {
		print STDERR "Amethyst: Warning: No brains!\n";
	}

	foreach (values %{$heap->{Connections}}) {
		print STDERR "Amethyst: Connecting $_\n";
		$kernel->post($_, 'connect');
	}
}

sub handler_think {
	my ($kernel, $session, $heap, $message, $brains, @args) =
			@_[KERNEL, SESSION, HEAP, ARG0 .. $#_];

	my @brains = $brains ? @$brains : keys %{$heap->{Brains}};

	foreach my $name (@brains) {
		if ($heap->{BrainsFailed}->{$name}) {
			print STDERR "Amethyst: Cannot think in brain $name: " .
							"it failed to load at startup\n";
			next;
		}
		my $brain = $heap->{Brains}->{$name};
		if ($heap->{BrainsFailed}->{$name}) {
			print STDERR "Amethyst: Cannot think in brain $name: " .
							"no such brain!\n";
			next;
		}
		last if $brain->[0]->think($message, @args);
	}
}

1;

__END__