Verby::Config::Data - Verby::Config::Data documentation


Verby documentation Contained in the Verby distribution.

Index


Code Index:

NAME

Top

Verby::Config::Data -

SYNOPSIS

Top

	use Verby::Config::Data;

DESCRIPTION

Top

METHODS

Top

new
set
get
extract
exists
search
derive
data
parents

BUGS

Top

None that we are aware of. Of course, if you find a bug, let us know, and we will be sure to fix it.

CODE COVERAGE

Top

We use Devel::Cover to test the code coverage of the tests, please refer to COVERAGE section of the Verby module for more information.

SEE ALSO

Top

AUTHOR

Top

Yuval Kogman, <nothingmuch@woobling.org>

COPYRIGHT AND LICENSE

Top


Verby documentation Contained in the Verby distribution.

#!/usr/bin/perl

package Verby::Config::Data;
use Moose;

our $VERSION = "0.05";

use List::MoreUtils qw/uniq/;
use Carp qw/croak/;

has data => (
	isa => "HashRef",
	is  => "rw",
	default => sub { return {} },
);

has parents => (
	isa => "ArrayRef",
	is  => "ro",
	auto_deref => 1,
	required   => 1,
);

around new => sub {
	my $next = shift;
	my ( $class, @parents ) = @_;

	$class->$next( parents => [ uniq @parents ] );
};

sub DEMOLISH {
	my $self = shift;
	untie %{ $self->{data} } if tied $self->{data};
}

sub AUTOLOAD {
	(our $AUTOLOAD) =~ /::([^:]+)$/;

	my $field = $1;

	my $sub = sub {
		my $self = shift;
		$self->set($field, @_) if @_;
		$self->get($field);
	};

	{
		no strict;
		*{ $field } = $sub;
	}

	goto &$sub;
}

sub set {
	my $self = shift;
	croak "$self is not mutable";
}

sub get {
	my $self = shift;
	my $key = shift;
	($self->search($key) || return)->extract($key);
}

sub extract {
	my $self = shift;
	my $key = shift;
	$self->data->{$key};
}

sub exists {
	my $self = shift;
	my $key = shift;
	$self->data->{$key} || exists $self->data->{$key}; # XXX workaround for Tie::Memoize
}

sub search {
	my $self = shift;
	my $key = shift;

	if ( $self->exists($key) ) {
		return $self;
	} else {
		my @matches = uniq map { $_->search($key) } $self->parents;
		if ( @matches == 1 ) {
			return $matches[0];
		} else {
			Log::Dispatch::Config->instance->warn("Parents config sources conflict over $key: @matches") if @matches;
			return;
		}
	}
}

sub derive {
	my ( $self, $class ) = @_;
	$class ||= ref $self;

	$class->new($self);
}

__PACKAGE__

__END__