File Coverage

lib/Sub/Contract/Pool.pm

Criterion	Covered	Total	%
statement	55	61	90.1
branch	12	16	75.0
condition	13	27	48.1
subroutine	14	16	87.5
pod	9	9	100.0
total	103	129	79.8

#
#   Sub::Contract::Pool - The pool of contracts
#
#   $Id: Pool.pm,v 1.15 2009/06/16 12:23:58 erwan_lemonnier Exp $
#

package Sub::Contract::Pool;

use strict;
use warnings;

use Carp qw(croak);

use vars qw($AUTOLOAD);
use accessors qw( _contract_index
		);

use base qw(Exporter);

our $VERSION = '0.12';

our @EXPORT = ();
our @EXPORT_OK = ('get_contract_pool');

#---------------------------------------------------------------
#
#   A singleton pattern with lazy initialization and embedded constructor
#

my $pool;

sub get_contract_pool {
    if (!defined $pool) {
	$pool = bless({},__PACKAGE__);
	$pool->_contract_index({});
    }
    return $pool;
}

#---------------------------------------------------------------
#
#   list_all_contracts - return all contracts registered in the pool
#

sub list_all_contracts {
    my $self = shift;
    return values %{$self->_contract_index};
}

#---------------------------------------------------------------
#
#   has_contract -
#

# TODO: should it be removed? to use find_contract instead? would it be too slow?

sub has_contract {
    my ($self, $contractor) = @_;

    croak "method has_contract() expects a fully qualified function name as argument"
	if ( scalar @_ != 2 ||
	     !defined $contractor ||
	     ref $contractor ne '' ||
	     $contractor !~ /::/
	);

    my $index = $self->_contract_index;
    return exists $index->{$contractor};
}

#---------------------------------------------------------------
#
#   _add_contract
#

sub _add_contract {
    my ($self, $contract) = @_;

    croak "method add_contract() expects only 1 argument"
	if (scalar @_ != 2);
    croak "method add_contract() expects an instance of Sub::contract as argument"
	if (!defined $contract || ref $contract ne 'Sub::Contract');

    my $index = $self->_contract_index;
    my $contractor = $contract->contractor;

    croak "trying to contract function [$contractor] twice"
	if ($self->has_contract($contractor));

    $index->{$contractor} = $contract;

    return $self;
}

################################################################
#
#
#   Operations on contracts during runtime
#
#
################################################################

sub enable_all_contracts {
    my $self = shift;
    map { $_->enable } $self->list_all_contracts;
}

sub disable_all_contracts {
    my $self = shift;
    map { $_->disable } $self->list_all_contracts;
}

sub enable_contracts_matching {
    my $self = shift;
    map { $_->enable } $self->find_contracts_matching(@_);
}

sub disable_contracts_matching {
    my $self = shift;
    map { $_->disable } $self->find_contracts_matching(@_);
}

sub find_contract {
    my ($self, $contractor) = @_;

    croak "method find_contract() expects a fully qualified function name as argument"
	if ( scalar @_ != 2 ||
	     !defined $contractor ||
	     ref $contractor ne '' ||
	     $contractor !~ /::/
	);

    my $index = $self->_contract_index;
    return $index->{$contractor};
}

sub find_contracts_matching {
    my $self = shift;
    my $match = shift;
    my @contracts;

# TODO: fix croak level when called from enable/disable_matching
#    local $Carp::CarpLevel = 2 if ((caller(1))[3] =~ /^Sub::Contract::Pool::(enable|disable)_contracts_matching$/);

    croak "method find_contracts_matching() expects a regular expression"
	if (scalar @_ != 0 || !defined $match || ref $match ne '');

    while ( my ($name,$contract) = each %{$self->_contract_index} ) {
	push @contracts, $contract if ($name =~ /^$match$/);
    }

    return @contracts;
}

1;

__END__