File Coverage

lib/Badger/Hub.pm

Criterion	Covered	Total	%
statement	110	144	76.3
branch	20	50	40.0
condition	16	44	36.3
subroutine	24	29	82.7
pod	11	22	50.0
total	181	289	62.6

#========================================================================
#
# Badger::Hub
#
# DESCRIPTION
#   A hub provides a central configuration and management point for
#   Badger components to access other Badger components.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Hub;

use Badger::Debug ':dump';
use Badger::Config;
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Prototype',
    import    => 'class',
    auto_can  => 'auto_can',
    constants => 'HASH ARRAY REFS PKG',
    utils     => 'blessed params is_object',
    words     => 'COMPONENTS DELEGATES COMP_CACHE DELG_CACHE',
    constant  => {
        CONFIG_MODULE => 'Badger::Config',
    },
    messages => {
        no_module  => 'No %s module defined.',
        bad_method => "Invalid method '%s' called on %s at %s line %s",
    };

our $COMPONENTS    = { };
our $RESOURCES     = { };
our $DELEGATES     = { };
our $LOADED        = { };
#our $COLLECTIONS = [qw( components resources delegates )];


sub init {
    my ($self, $config) = @_;
    $self->init_hub($config);
}

sub init_hub {
    my ($self, $config) = @_;
    $self->init_config($config);
    $self->init_items($config);
    # $self->init_collections($config);     # init on demand
}

sub init_config {
    my ($self, $args) = @_;
    my $class = $self->class;

    # We're looking for a specific 'config' item which the user can provide to
    # points to a master configuration object or class name.  We default to the
    # value in the $CONFIG package variable, which in this case is Badger::Config,
    # but could be re-defined by a subclass to be something else.

    my $config = delete($args->{ config })
        || $self->class->any_var('CONFIG')
        || { };

    my $module = delete($args->{ config_module })
        || $class->any_var('CONFIG_MODULE')
        || $self->CONFIG_MODULE;

    if (is_object($module, $config)) {
        # $config is already a config module object of the right heritage
        $self->debug("config is already a $module object") if DEBUG;
    }
    else {
        if (ref $config eq HASH) {
            # cool
        }
        elsif (! ref $config) {
            # $config is a module name
            $module = $config;
            $config = { };
        }
        else {
            return $self->error_msg( invalid => config => $config );
        }
        $self->debug("loading and instantiating a custom $module config object") if DEBUG;
        class($module)->load;
        $config = $module->new($config);
    }

    $self->{ config } = $config;
    $self->debug("hub config: $self->{ config }\n") if DEBUG;
}

sub init_items {
    my ($self, $args) = @_;

    # merge all values in $CONFIG_ITEMS in with $args->{ items };
    $args->{ items } = $self->class->list_vars(
        CONFIG_ITEMS => delete($args->{ config_items }), $args->{ items }
    );

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

    return $self;
}

sub init_collections {
    my ($self, $config) = @_;
    $self->init_components($config);
    $self->init_resource($config);
    $self->init_delegates($config);
}

sub init_components {
    shift->init_collection( components => @_ );
}

sub init_resources {
    shift->init_collection( resources => @_ );
}

sub init_delegates {
    shift->init_collection( delegates => @_ );
}

sub init_collection {
    my ($self, $type) = @_;
    my $TYPE = uc $type;
    my $cfg  = $self->config($type);
    my $bits = $self->{ $type } = $self->class->hash_vars(
        $TYPE => $self->config($type)
    );
    $self->debug("init_collection: $type: ", $self->dump_data($bits)) if DEBUG;
    return $bits;
}

sub configure {
    my ($self, $config) = self_params(@_);
    my $item;

    if ($item = delete $config->{ components }) {
        $self->components($item);
    }
    if ($item = delete $config->{ resources }) {
        $self->resources($item);
    }
    if ($item = delete $config->{ delegates }) {
        $self->delegates($item);
    }
}

#-----------------------------------------------------------------------------
# comment
#-----------------------------------------------------------------------------

sub components {
    my $self  = shift->prototype;
    my $comps = $self->{ components }
             || $self->init_components;

    if (@_) {
        my $args = ref $_[0] eq HASH ? shift : { @_ };
        @$comps{ keys %$args } = values %$args;
    }

    return $comps;
}


sub component {
    my $self  = shift;
    my $comps = $self->components;
    $self->debug("components: ", $self->dump_data($comps)) if DEBUG;
    return @_
        ? $comps->{ $_[0] }
        : $comps;
}


sub delegates {
    my $self  = shift->prototype;
    my $class = $self->class;
    my $delgs = $self->{ delegates }
             || $self->init_delegates;

    if (@_) {
        my $args = ref $_[0] eq HASH ? shift : { @_ };
        @$delgs{ keys %$args } = values %$args;
    }

    return $delgs;
}


sub delegate {
    my $self   = shift;
    my $delegs = $self->delegates;
    $self->debug("delegates: ", $self->dump_data($delegs)) if DEBUG;
    return @_
        ? $delegs->{ $_[0] }
        : $delegs;
}


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

    if ($target = $self->component($name)) {
        $self->debug("creating component method in $self for $name")  if DEBUG;
        return $self->auto_component( $name => $target );
    }
    elsif ($target = $self->delegate($name)) {
        $self->debug("creating delegate method in $self for $name") if DEBUG;
        return $self->auto_delegate( $name => $target );
    }
    elsif (DEBUG) {
        $self->debug("no component or delegate found in $self for $name");
    }

    return undef;
}


sub auto_component {
    my ($self, $name, $comp) = @_;
    my $class = ref $self || $self;

    $LOADED->{ $name } ||= class($comp)->load;

    return sub {
        my $self = shift;
        my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
        $self = $self->prototype unless ref $self;

        return $self->{ $name }
            ||= $self->construct(
                $name => {
                    # TODO: figure out what's going on here in terms of
                    # possible combinations of configuration options
                    %$args,
                    hub    => $self,
                    module => $comp
                }
            );
    }
}


sub auto_delegate {
    my ($self, $name, $deleg) = @_;
    my $class = ref $self || $self;

    # foo => bar is mapped to $self->bar->foo
    # foo => [bar, baz] is mapped to $self->bar->baz
    my ($m1, $m2) = ref $deleg eq ARRAY ? @$deleg : ($deleg, $name);

    return $self->error("Cannot auto_delegate() a method to itself: $m1 -> $m2")
        if $m1 eq $m2;

    return sub {
        shift->$m1->$m2(@_);
    };
}



# Configure and create a sub-component identified by $name, using
# any configuration items in $params and any values defined locally
# in a configuration hash, object or class.
#
# The $self->{ config } can contain a hash array of configuration
# items, or it can be a Badger::Config object or the class name of a
# Badger::Config object.  We look in the hash, or call the object/class
# method to find $name (e.g. $hash->{ $name }, $object->$name, or
# $class->name()).  This is merged with $params.

sub construct {
    my $self   = shift;
    my $name   = shift;
    my $config = $self->config($name, @_);

    $self->debug("$name module config: ", $self->dump_data($config)) if DEBUG;

    # see if a module name is specified in $args, config hash or use $pkgmod
    my $module = $config->{ module }
        || return $self->error_msg( no_module => $name );

    # load the module
    class($module)->load;

    return $module->new($config);
}

sub config {
    my $self   = shift->prototype;
    my $config = $self->{ config };     return $config unless @_;
    my $name   = shift;
    my $params = params(@_);
    my $defaults;
    my $method;


    if ($config && ref $config eq HASH) {
        # $self->{ config } can be a hash ref with a $name item
        $defaults = $config->{ $name };
    }
    elsif (blessed $config && ($method = $config->can('get'))) {
        # $self->{ config } can be an object with a get($name) method which we call
        $self->debug("calling config->get($name)") if DEBUG;
        $defaults = $method->($config, $name);
    }
    elsif (blessed $config && ($method = $config->can($name))) {
        # $self->{ config } can be an object with a $name method which we call
        $self->debug("calling config->$name") if DEBUG;
        $defaults = $method->($config);
    }
    # no defaults
    return $self->no_config($name, $params)
        unless $defaults;

    $self->debug(
        "config for $name: DEFAULTS: ",
        $self->dump_data($defaults),
        "\nPARAMS: ", $self->dump_data($params)
    ) if DEBUG;

    return {
        %$defaults,
        %$params
    };
}

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

    $self->debug(
        "no_config for $name: ",
        "PARAMS: ", $self->dump_data($params)
    ) if DEBUG;

    # TODO: option to make this a failure
    return  $self->pkgvar_config($name, $params)
        ||  ($params ? { %$params } : { });
}

sub pkgvar_config {
    my ($self, $name, $params) = @_;
    my $pkgvar = $self->class->any_var(uc $name) || return $params;
    my $config;

    if (ref $pkgvar eq HASH) {
        # package variable can be a hash ref of config options
        $config = $pkgvar;
    }
    else {
        # or the name of a module
        $config = {
            module => $pkgvar
        };
    };

    return {
        %$config,
        %$params
    };
}



#------------------------------------------------------------------------
# destroy()
#
# Destroy the hub and cleanup any cache items we may have stored.
#------------------------------------------------------------------------

sub destroy {
    my $self = shift;

    # if called as a class method we cleanup any prototype object
    # stored as a singleton in the $PROTOTYPE package variable
    unless (ref $self) {
        no strict 'refs';
        my $class = $self;
        $self = ${"$class\::PROTOTYPE"} || return;
        $self->debug("deleting hub prototype from \$$class\::PROTOTYPE\n") if DEBUG;
        ${"$class\::PROTOTYPE"} = undef;
    }

    $self->debug("destroying hub: $self\n") if DEBUG;

    # empty content of $self to break any circular references that
    # we may have established with other items that point back to us
    %$self = ();
}


sub DESTROY {
    my $self = shift;
    $self->destroy;
}


1;
__END__