File Coverage

blib/lib/Object/Registrar.pm

Criterion	Covered	Total	%
statement	18	78	23.0
branch	0	20	0.0
condition	0	3	0.0
subroutine	6	19	31.5
pod	6	8	75.0
total	30	128	23.4

# ----------------------------------------------------------------------------#
# Object::Registrar                                                           #
#                                                                             #
# Copyright (c) 2001-02 Arun Kumar U .                 #
# All rights reserved.                                                        #
#                                                                             #
# This program is free software; you can redistribute it and/or               #
# modify it under the same terms as Perl itself.                              #
# ----------------------------------------------------------------------------#

package Object::Registrar;

use Object::NotFoundException;
use Object::AlreadyBound;

use strict;
use vars qw($VERSION);

$VERSION = "0.01";

## Ultra safe Class Attribute(s) :-)
{
	my %ClassData =
	(
		'Instance' => undef,
		'Debug'    => 0,
	);

	foreach my $datum	(keys(%ClassData)) {
		no strict 'refs';
		*$datum = sub {
			use strict 'refs';
			my ($self, $newvalue) = @_;
			$ClassData{$datum} = $newvalue if @_ > 1;
			return($ClassData{$datum});
		};
	}
};

sub _newInstance
{
	my ($proto) = shift;
	my ($self, $class);

	$self = {};
	$self->{'registry'} = undef;
	$class = ref($proto) || $proto;

	bless($self, $class);
	return $self;
}

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

	my $instance = $self->Instance();
	if (!defined($instance)) {
		$instance = $self->_newInstance();
		$self->Instance($instance);
	}
	return($instance);
}

sub _store
{
	my ($self, $name, $object) = @_;

	my $registrar = $self->getInstance();
	$registrar->{'registry'}->{$name} = $object;
}

sub _retrieve
{
	my ($self, $name) = @_;

	my $registrar = $self->getInstance();
	return $registrar->{'registry'}->{$name};
}

sub _destroy
{
	my ($self, $name) = @_;

	my $registrar = $self->getInstance();
	$registrar->{'registry'}->{$name} = undef;
	delete $registrar->{'registry'}->{$name};
}

sub exists
{
	my ($self, $name) = @_;

	my $registrar = $self->getInstance();
	if (exists($registrar->{'registry'}->{$name})) { return 1; }
	else { return 0; }
}

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

	my $registrar = $self->getInstance();
	return keys(%{$registrar->{'registry'}});
}

sub bind
{
	my ($self, $name, $object) = @_;

	if ($self->exists($name)) {
		throw Object::AlreadyBound("Object already bound with the name \"$name\"\n");
	}
	else { $self->_store($name, $object); }
	print STDERR "Bound \"$name\" [$object] with Registrar\n" if ($self->Debug());
}

sub rebind
{
	my ($self, $name, $object) = @_;

	$self->_store($name, $object);
	print STDERR "Bound \"$name\" [$object] with Registrar\n" if ($self->Debug());
}

sub unbind
{
	my ($self, $name) = @_;

	$self->_destroy($name);
	print STDERR "Unbound \"$name\" from Registrar\n" if ($self->Debug());
}

sub resolve
{
	my ($self, $name) = @_;

	if (!$self->exists($name)) {
		throw Object::NotFoundException("Object \"$name\" not found\n");
	}

	my $object = $self->_retrieve($name);
	if (!$object) {
		throw Object::NotFoundException("Object \"$name\" not found\n");
	}
	return($object);
}

sub list
{
	my ($self, $pattern) = @_;
	my (%objhash);

	my @keys = $self->getContexts();
	foreach my $key (@keys) {
		if ($key =~ m/^${pattern}$/) {
			$objhash{$key} = $self->_retrieve($key);
		}
	}
	return %objhash;
}

# Just to stop perl -cw from complaining
sub getInstance;
sub register;
sub reregister;
sub unregister;

## Some useful method aliases
*getInstance = \&new;
*register    = \&bind;
*reregister  = \&rebind;
*unregister  = \&unbind;

1;

__END__;