File Coverage

lib/Badger/Config.pm

Criterion	Covered	Total	%
statement	63	75	84.0
branch	24	34	70.5
condition	5	10	50.0
subroutine	9	11	81.8
pod	3	8	37.5
total	104	138	75.3

#========================================================================
#
# Badger::Config
#
# DESCRIPTION
#   A central configuration module.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Config;

use Badger::Debug ':dump debugf';
use Badger::Class
    version   => 0.01,
    debug     => 0,
    import    => 'class',
    base      => 'Badger::Prototype',
    utils     => 'blessed numlike extend',
    constants => 'HASH ARRAY CODE DELIMITER',
    auto_can  => 'can_configure',
    alias     => {
        init  => \&init_config,
    },
    messages  => {
        get       => 'Cannot fetch configuration item <1>.<2> (<1> is <3>)',
        no_config => 'No configuration data found for %s',
    };



sub init_config {
    my ($self, $config) = @_;
    my $data  = $self->{ data } = $config->{ data } || { %$config };
    my $class = $self->class;

    # merge all $ITEMS in package variables with those listed in
    # $config->{ items } and all other $config keys.
    my $items = $class->list_vars(
        ITEMS => delete($config->{ items }), keys %$data
    );

    if (DEBUG) {
        $self->debug("[$self] $class ITEMS: ", $self->dump_data($items));
        $self->debug("[$self] $class DATA: ", $self->dump_data($data));
    }

    # store hash lookup table marking valid items
    $items = $self->{ item } = {
        map { $_ => 1 }
        keys %$data,
        map { split DELIMITER }
        @$items
    };

    # load up all the configuration items from package variables
    #
    # TODO: We need different init rules here with fallbacks.  This should
    # be merged in with the code in Badger::Class::Config, or rather B:C:C
    # should define a config schema.
    foreach my $item (keys %$items) {
        next if exists $data->{ $item };
        $data->{ $item } = $config->{ $item }
            || $class->any_var( uc $item );
        $self->debug("config set $item => ", $data->{ $item }, "\n") if DEBUG;
    }

    if (DEBUG) {
        $self->debug("config items: ", $self->dump_data($self->{ item }));
        $self->debug("config data: ", $self->dump_data($self->{ data }));
    }

    return $self;
}


sub get {
    my $self  = shift->prototype;
    my @names = map { ref $_ eq ARRAY ? @$_ : split /\./ } @_;
    my $name  = shift @names;

    $self->debug(
        "get: [",
        join('].[', $name, @names),
        "]"
    ) if DEBUG;

    # fetch the head item
    my $data = $self->head($name);

    if (! defined $data) {
        return $self->decline_msg(
            no_config => $name
        );
    }

    return @names
        ? $self->dot($name, $data, \@names)
        : $data;
}

sub dot {
    my ($self, $name, $data, $dots) = @_;
    my @done = ($name);
    my ($dot, $last, $method);

    $self->debug(
        "dot: [",
        join('].[', $name, @$dots),
        "]"
    ) if DEBUG;


    # resolve any dotted paths after the head
    foreach $dot (@$dots) {
        # call any function reference to return a value
        if (ref $data eq CODE) {
            $data = $data->();
        }

        CHECK: {
            if (ref $data eq HASH) {
                $data = $data->{ $dot };
                last CHECK;
            }
            elsif (ref $data eq ARRAY) {
                if (numlike $dot) {
                    $data = $data->[$dot];
                    last CHECK;
                }
                # else vmethods?
            }
            elsif (blessed $data) {
                if ($method = $data->can($dot)) {
                    $data = $method->($dot);
                    last CHECK;
                }
            }
            return $self->decline_msg(
                no_config => join('.', @done, $dot)
            );
        }

        if (! defined $data) {
            return $self->decline_msg(
                no_config => join('.', @done, $dot)
            );
        }
        push(@done, $dot);
    }

    return $data;
}

sub head {
    my ($self, $name) = @_;
    # subclasses can do something more complicated
    return $self->{ data }->{ $name };
}

sub set {
    my $self = shift->prototype;
    my $name = shift;
    my $data = @_ == 1 ? shift : { @_ };
    $self->{ data }->{ $name }   = $data;
    $self->{ item }->{ $name } ||= 1;
    return $data;
}

sub data {
    my $self = shift->prototype;
    my $data = $self->{ data };
    extend($data, @_) if @_;
    return $data;
}

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

    $self = $self->prototype unless ref $self;

    $self->debug("can_configure($name)") if DEBUG;

    return
        unless $name && $self->has_item($name);

    return sub {
        return @_ > 1
            ? shift->set( $name => @_ )     # set
            : shift->get( $name );
    };
}

sub has_item {
    my $self = shift->prototype;
    my $name = shift;
    my $item = $self->{ item }->{ $name };
    if (defined $item) {
        # A 1/0 entry in the item tells us if an item categorically does or
        # doesn't exist in the config data set (or allowable set - it might
        # be a valid configuration option that simply hasn't been set yet)
        return $item;
    }
    else {
        # Otherwise the existence (or not) of an item in the data set is
        # enough to satisfy us one way or another
        return exists $self->{ data }->{ $name };
    }
}


1;

__END__