view release on metacpan or  search on metacpan

lib/Badger/Modules.pm  view on Meta::CPAN

use Badger::Debug ':dump';
use Badger::Class
    version     => 0.01,
    debug       => 0,
    base        => 'Badger::Prototype Badger::Exporter',
    import      => 'class',
    utils       => 'plural blessed textlike dotid camel_case',
    accessors   => 'item items',
    words       => 'ITEM ITEMS ISA TOLERANT BADGER_LOADED',
    constants   => 'PKG ARRAY HASH REFS ONCE DEFAULT',
    constant    => {
        OBJECT          => 'object',
        FOUND           => 'found',
        FOUND_REF       => 'found_ref',
        PATH_SUFFIX     => '_PATH',
        NAMES_SUFFIX    => '_NAMES',
        DEFAULT_SUFFIX  => '_DEFAULT',
    },
    methods     => {
        init            => \&init_modules,
        throws          => \&item,
    },
    messages    => {
        no_item     => 'No item(s) specified for factory to manage',
        no_default  => 'No default defined for %s factory',
        bad_ref     => 'Invalid reference for %s factory item %s: %s',
        bad_method  => q{Can't locate object method "%s" via package "%s" at %s line %s},
        failed      => q{Error loading %s module %s as %s: %s},
    };

our $ITEM = 'module';


sub init_modules {
    my ($self, $config) = @_;
    my $class = $self->class;
    my ($item, $items);

    $self->debug("initialising modules: ", $self->dump_data($config)) if DEBUG;

    $config->{ tolerant } = $class->any_var(TOLERANT)
        unless defined $config->{ tolerant };

    # 'item' and 'items' can be specified as config params or we look for
    # $ITEM and $ITEMS variables in the current package or those of any 
    # base classes.  NOTE: $ITEM and $ITEMS must be in the same package
    unless ($item = $config->{ item }) {
        foreach my $pkg ($class->heritage) {
            no strict   REFS;
            no warnings ONCE;
            
            if (defined ($item = ${ $pkg.PKG.ITEM })) {
                $items = ${ $pkg.PKG.ITEMS };
                last;
            }
        }
    }
    return $self->error_msg('no_item')
        unless $item;

    # use 'items' in config, or grokked from $ITEMS, or guess plural
    $items = $config->{ items } || $items || plural($item);

    my $ipath    = $item.PATH_SUFFIX;
    my $inames   = $item.NAMES_SUFFIX;
    my $idefault = $item.DEFAULT_SUFFIX;
    
    # Merge all XXXX_PATH package vars with any 'xxxx_path' or 'path' config 
    # items.  Ditto for XXXX_NAME / 'xxxx_name' / 'aka' and  XXXXS/ 'xxxxs'
    
    my @path  = @$config{ path  => lc $ipath  };
    my @names = @$config{ names => lc $inames };
    $self->{ path     } = $class->list_vars(uc $ipath, @path);
    $self->{ names    } = $class->hash_vars(uc $inames, @names);
    $self->{ $items   } = $class->hash_vars(uc $items, $config->{ $items });        # TODO: this could clash
    $self->{ tolerant } = $config->{ tolerant };
    $self->{ items    } = $items;
    $self->{ item     } = $item;
    $self->{ loaded   } = { };                                                      # TODO: make this the same thing?

    $self->debug(
        " Item: $self->{ item }\n",
        "Items: $self->{ items }\n",
        " Path: ", $ipath, ": ", $self->dump_data($self->{ path }), "\n",
        "Names: ", $inames, ": ", $self->dump_data($self->{ names })
    ) if DEBUG;

    return $self;
}


sub path {
    my $self = shift->prototype;
    return @_ 
        ? ($self->{ path } = ref $_[0] eq ARRAY ? shift : [ @_ ])
        :  $self->{ path };
}


sub names {
    my $self  = shift->prototype;
    my $names = $self->{ names };
    if (@_) {
        my $args = ref $_[0] eq HASH ? shift : { @_ };
        @$names{ keys %$args } = values %$args;
    }
    return $names;
}


sub module_names {
    my $self = shift;
    my @bits = 
        map { camel_case($_) }
        map { split /[\.]+/ } @_;
    my %seen;

    return (
        grep { ! $seen{ $_ }++ }
        join( PKG, map { ucfirst $_ } @bits ),
        join( PKG, @bits )