File Coverage

lib/Badger/Class/Config.pm

Criterion	Covered	Total	%
statement	60	60	100.0
branch	17	20	85.0
condition	4	7	57.1
subroutine	13	13	100.0
pod	9	9	100.0
total	103	109	94.5

#========================================================================
#
# Badger::Class::Config
#
# DESCRIPTION
#   Class mixin module for adding code onto a class for configuration.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Class::Config;

use Carp;
use Badger::Debug ':dump';
use Badger::Config::Schema;
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Exporter Badger::Base',
    import    => 'class CLASS',
    words     => 'CONFIG_SCHEMA CONFIG_ITEMS',
    constants => 'HASH ARRAY DELIMITER',
    constant  => {
        SCHEMA        => 'Badger::Config::Schema',
        CONFIG_METHOD => 'configure',
        VALUE         => 1,
        NOTHING       => 0,
    },
    messages => {
        bad_type   => 'Invalid type prefix specified for %s: %s',
        bad_method => 'Missing method for the %s %s configuration item: %s',
    };


sub export {
    my $class  = shift;
    my $target = shift;
    $class->debug("export to $target: ", join(', ', @_)) if DEBUG;
    my $params = @_ == 1 ? shift : { @_ };
    my $schema = $class->schema($target, $params);
    my $items  = $schema->items;

    $class->debug(
        "exporting CONFIG_SCHEMA to $target: $schema"
    ) if DEBUG;

    $class->export_symbol(
        $target,
        CONFIG_SCHEMA,
        \$schema
    );

    $class->debug(
        "export CONFIG_ITEMS to $target: ",
        $class->dump_data($items)
    ) if DEBUG;

    $class->export_symbol(
        $target,
        CONFIG_ITEMS,
        \$items,
    );

    $class->export_symbol(
        $target,
        CONFIG_METHOD,
        $class->can(CONFIG_METHOD)    # subclass might redefine method
    );
}

sub schema {
    my $class  = shift;
    my $target = shift;
    my $config = @_ == 1 ? (ref $_[0] eq ARRAY ? [@{$_[0]}] : shift) : [ @_ ];

    $class->debug("Generating schema from config: ", $class->dump_data($config))
        if DEBUG;

    $config = [ split(DELIMITER, $config) ]
        unless ref $config;

    # inherit any other items define in base classes
    my $items = class($target)->list_vars(CONFIG_ITEMS);

    $class->SCHEMA->new(
        class    => $target,
        schema   => $config,
        fallback => $class,
        extend   => $items,
    );
}

sub fallback {
    my ($self, $name, $type, $data) = @_;
    my $code = $self->can('configure_' . $type) || return;
    return [ $code, $data ];
}


#-----------------------------------------------------------------------
# this method is mixed into the target module
#-----------------------------------------------------------------------

sub configure {
    my ($self, $config, $target) = @_;
    my $class  = class($self);
    my $schema = $class->any_var(CONFIG_SCHEMA);

    # if a specific $target isn't defined then we default to updating $self
    $schema->configure($config, $target || $self, $self)
        || return $self->error($schema->reason->info);

    return $self;
}


#-----------------------------------------------------------------------
# These handlers implement the various fallback types for providing
# configuration data.  The schema() method maps fallacks specified as
# 'pkg:FOO' and 'class:BAR', for example, to the configure_pkg() and
# configure_class() handlers, passing the token following the colon as
# an argument.  They are called as code refs, but the class of the
# object that they're configuring is passed as the first argument, $class.
# So they look like class methods, but they're not exported into the
# object's namespace.  The $target is usually the object that's being
# configured, e.g. when $self->configure($config) is called, but it might
# also be a bare hash, e.g. $target = { }; $self->configure($config, $target)
#-----------------------------------------------------------------------

# TODO: move these into Badger::Config::Item or somewhere else

sub configure_pkg {
    my ($class, $name, $config, $target, $var) = @_;
    my $value = class($class)->var($var);

    $class->debug(
        "Looking for \$$var package variable in $class to set $name: ",
        defined $value ? $value : ''
    ) if DEBUG;

    return defined $value
        ? (VALUE => $value)
        : (NOTHING);
}

sub configure_class {
    my ($class, $name, $config, $target, $var) = @_;
    my $value = class($class)->any_var_in( split(':', $var) );

    $class->debug(
        "Looking for \$$var class variable in $class to set $name: ",
        defined $value ? $value : ''
    ) if DEBUG;

    return defined $value
        ? (VALUE => $value)
        : (NOTHING);
}

sub configure_env {
    my ($class, $name, $config, $target, $var) = @_;
    my $value = $ENV{ $var };

    $class->debug(
        "Looking for $var environment variable to set $name: ",
        defined $value ? $value : ''
    ) if DEBUG;

    return defined $value
        ? (VALUE => $value)
        : (NOTHING);
}

sub configure_method {
    my ($class, $name, $config, $target, $method) = @_;

    # see if the object has the required method - note we must call
    # error_msg against CLASS (Badger::Class::Config) to use the 'bad_method'
    # message defined above.
    my $code = $class->can($method)
        || return CLASS->error_msg( bad_method => class($class), $name, $method );

    # call the code and do the usual shuffle
    my $value = $code->($class);

    $class->debug(
        "Called $method() method to set $name: ",
        defined $value ? $value : ''
    ) if DEBUG;

    return defined $value
        ? (VALUE => $value)
        : (NOTHING);
}

sub configure_target {
    my ($class, $name, $config, $target, $var) = @_;

    my $value = $target->{ $var };

    $class->debug(
        "Looking for $var in $class target $target to set $name: ",
        defined $value ? $value : ''
    ) if DEBUG;

    return defined $value
        ? (VALUE => $value)
        : (NOTHING);
}



1;

__END__