File Coverage

lib/Badger/Modules.pm

Criterion	Covered	Total	%
statement	102	114	89.4
branch	18	34	52.9
condition	7	11	63.6
subroutine	13	15	86.6
pod	9	9	100.0
total	149	183	81.4

#========================================================================
#
# Badger::Modules
#
# DESCRIPTION
#   Module for loading and instantiating other modules.
#
# NOTE
#   Badger::Factory is being cleaved in twain.  Badger::Modules will
#   implement the lower level parts related to finding and loading
#   modules.  Badger::Factory will be a subclass specialised for creating
#   object instances.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Modules;

use Carp;
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 )
    );
}


sub modules {
    my $self  = shift->prototype;
    my $items = $self->{ $self->{ items } };
    if (@_) {
        # NOTE: this doesn't have any effect... it's a artefact from
        # Badger::Factory... we need to change $self->{ loaded } to be
        # $self->{ items }
        my $args = ref $_[0] eq HASH ? shift : { @_ };
        @$items{ keys %$args } = values %$args;
    }
    return $items;
}


sub module {
    my $self    = shift->prototype;
    my $name    = shift;
    my $path    = $self->{ path    };
    my $loaded  = $self->{ loaded };
    my ($module, $base, $alias, $found, $file, $symtab, @names, $size);

    # Run the name through the name map to handle any unusual capitalisation,
    # spelling, aliases, etc.
    $name = $self->{ names }->{ $name } || $name;

    # Then expand the name using whatever rules are in effect (e.g. the
    # default which maps foo_bar to FooBar)
    # FIXME: probably shouldn't do this if we found an entry in the names lookup
    @names = $self->module_names($name);

  LOOKUP:
    foreach $base (@$path) {
        foreach $alias (@names) {
            $module = join(PKG, $base, $alias);

            # TODO: look in $self->{ $items } for pre-defined result...

            # See if we've previously loaded a module with this name (true
            # value) or failed to load a module (defined but false value)
            if ($found = $loaded->{ $module }) {
                $self->debug("$module has already been loaded") if DEBUG;
                return $self->found( $name, $module );
            }
            elsif (defined $found) {
                $self->debug("$module has previously been requested but not found") if DEBUG;
                next;
            }

            # Look to see if the module already has a symbol table defined
            no strict REFS;
            $symtab = \%{$module.PKG};

            # We have to be careful because symbols may be defined in a
            # package's symbols table *before* the module is loaded (e.g. the
            # $DEBUG package variable that Badger::Debug uses).  So we only
            # assume that the module is loaded if VERSION or BADGER_LOADED is
            # defined
            if ($symtab->{ VERSION } || $symtab->{ BADGER_LOADED }) {
                $self->debug("found an existing VERSION/BADGER_LOADED in $module symbol table") if DEBUG;
                return $self->found( $name, $module );
            }

            $file = $module;
            $file =~ s/::/\//g;         # TODO: check Perl maps this to OS
            $file .= '.pm';

            $self->debug("Attempting to load $module as $file") if DEBUG;

            eval {
                # We use eval so that we can "use" the module and force any
                # import hooks to run.  But it might be better to load the
                # module with "require" and then manually call import()
                require $file;
            };

            if ($@) {
                $self->debug("Failed to load $module: $@") if DEBUG;
                # Don't confuse "Can't locate A/Module/Used/In/Your/Module.pm"
                # messages with "Can't locate Your/Module.pm".  The former is
                # an error that should be reported, the latter isn't.  We convert the
                # class name to a regex that matches any non-word directory
                # separators, e.g. Your::Module => Your\W+Module
                my $qmfile = quotemeta($file);
                $self->failed($name, $module, $@) if $@ !~ /^Can't locate $qmfile.*? in \@INC/;
                next;
            }

            # Some filesystems are case-insensitive (like Apple's HFS), so an
            # attempt to load Badger::Example::foo may succeed, when the
            # correct package name is actually Badger::Example::Foo.  We
            # double-check by looking to see if anything extra has been added
            # to the symbol table.
            $self->debug("$module symbol table keys: ", join(', ', keys %$symtab)) if DEBUG;
            next unless %$symtab;

            $self->debug("calling $module->import") if DEBUG;

            # now call the import() method to fire any import actions
            $module->import;

            # add the $BADGER_LOADED package variable to indicate that the
            # module has been loaded and add an entry to the internal cache
            ${ $module.PKG.BADGER_LOADED } ||= 1;
            $loaded->{ $module } = $module;

            return $self->found( $name, $module );
        }
    }

    # add entry to indicate module not found
    $loaded->{ $name } = 0;

    return $self->not_found($name);
}


sub found {
    # my ($self, $name, $module) = @_;
    return $_[2];
}


sub not_found {
    my $self = shift;

    return $self->{ tolerant }
        ? $self->decline_msg( not_found => $self->{ item } => @_ )
        : $self->error_msg(   not_found => $self->{ item } => @_ );
}


sub failed {
    my $self = shift;
    $self->error_msg( failed => $self->{ item }, @_ );
}




1;

__END__