File Coverage

lib/Badger/Factory.pm

Criterion	Covered	Total	%
statement	135	150	90.0
branch	41	64	64.0
condition	19	37	51.3
subroutine	21	22	95.4
pod	15	16	93.7
total	231	289	79.9

#========================================================================
#
# Badger::Factory
#
# DESCRIPTION
#   Factory module for loading and instantiating other modules.
#
# NOTE
#   This module has grown organically to fit a number of (possibly
#   conflicting) needs.  It needs to be completely refactored, and
#   probably split into a number of different factory modules.  The
#   TT3 code on which this was originally based had separate base class
#   factory modules for modules (that just got loaded), objects (that
#   got loaded and instantiated) and single objects (that got loaded,
#   created and cached).  With hindsight, it was a mistake to try and
#   cram all that functionality into one module.  It should be separated
#   into a base class module/API and a number of specialised subclasses.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Factory;

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',
    words     => 'ITEM ITEMS ISA',
    constants => 'PKG ARRAY HASH REFS ONCE DEFAULT LOADED',
    constant  => {
        OBJECT         => 'object',
        FOUND          => 'found',
        FOUND_REF      => 'found_ref',
        PATH_SUFFIX    => '_PATH',
        NAMES_SUFFIX   => '_NAMES',
        DEFAULT_SUFFIX => '_DEFAULT',
    },
    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 => qq{Can't locate object method "%s" via package "%s" at %s line %s},
    };

our $RUNAWAY = 0;
our $AUTOLOAD;

*init = \&init_factory;


sub init_factory {
    my ($self, $config) = @_;
    my $class = $self->class;
    my ($item, $items, $path, $map, $default);

    # '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 });
    $self->{ items    } = $items;
    $self->{ item     } = $item;
    $self->{ loaded   } = { };
    $self->{ no_cache } = defined $config->{ no_cache }     # quick hack
        ? $config->{ no_cache }
        : $class->any_var('NO_CACHE') || 0;

    # see if a 'xxxx_default' or 'default' configuration option is specified
    # or look for the first XXXX_DEFAULT or DEFAULT package variable.
    $default = $config->{ $idefault }
            || $config->{ default }
            || $class->any_var_in( uc $idefault, uc DEFAULT );
    if ($default) {
        $self->debug("Setting default to $default") if DEBUG;
        $self->{ default } = $self->{ names }->{ default } = $default;
    }

    $self->debug(
        "Initialised $item/$items factory\n",
        " Path: ", $self->dump_data($self->{ path }), "\n",
        "Names: ", $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 default {
    my $self = shift->prototype;
    return @_
        ? ($self->{ default } = $self->{ names }->{ default } = shift)
        :  $self->{ default };
}

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

sub item {
    my $self = shift; $self = $self->prototype unless ref $self;
    my ($type, @args) = $self->type_args(@_);

    # In most cases we're expecting $type to be a name (e.g. Table) which we
    # lookup in the items hash, or tack onto one of the module bases in the
    # path (e.g. Template::Plugin) to create a full module name which we load
    # and instantiate (e.g. Template::Plugin::Table).  However, the name might
    # be explicitly mapped to a  reference of some kind, or the $type passed
    # in could already be a reference (e.g. Template::TT2::Filters allow the
    # first argument to be a code ref or object which implements the required
    # filtering behaviour).  In which case, we bypass any name-based lookup
    # and skip straight onto the "look what I found!" phase

    return $self->found($type, $type, \@args)
        unless textlike $type;

    $type = $type . '';     # auto-stringify any textlike objects

    # OK, so $type is a string.  We'll also create a canonical version of the
    # name (lower case dotted) to provide a case/syntax insensitve fallback
    # (e.g. so "foo.bar" can match against "Foo.Bar", "Foo::Bar" and so on)

    my $items = $self->{ $self->{ items } };
    my $canon = dotid $type;

    $self->debug("Looking for '$type' or '$canon' in $self->{ items }") if DEBUG;
#   $self->debug("types: ", $self->dump_data($self->{ types })) if DEBUG;

    # false but defined entry indicates the item is not found
    return $self->not_found($type, \@args)
        if exists $items->{ $type }
           && not $items->{ $type };

    my $item = $items->{ $type  }
            || $items->{ $canon }
            # TODO: this needs to be defined-or, like //
            # Plugins can return an empty string to indicate that they
            # do nothing.
            # HMMM.... or does it?
            ||  $self->find($type, \@args)
#            ||  $self->default($type, \@args)
            ||  return $self->not_found($type, \@args);

    $items->{ $type } = $item
        unless $self->{ no_cache };

    return $self->found($type, $item, \@args);
}

sub type_args {
    # Simple method to grok $type and @args from argument list.  The only
    # processing it does is to set $type to 'default' if it is undefined or
    # false. Subclasses can re-define this to insert their own type mapping or
    # argument munging, e.g. to inject values into the configuration params
    # for an object
    shift;
    my $type = shift || DEFAULT;
    my @args;

    if (ref $type eq HASH) {
        @args = ($type, @_);
        $type = $type->{ type } || DEFAULT;
    }
    else {
        @args = @_;
    }

    return ($type, @args);
}

sub find {
    my $self   = shift;
    my $type   = shift;
    my $bases  = $self->path;
    my $module;

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

    foreach my $base (@$bases) {
        return $module
            if $module = $self->load( $self->module_names($base, $type) );
    }

    return undef;
}

sub load {
    my $self   = shift;
    my $loaded = $self->{ loaded };

    foreach my $module (@_) {
        # see if we've previously loaded a module with this name (true
        # value) or failed to load a module (defined but false value)

        if ($loaded->{ $module }) {
            $self->debug("$module has been previously loaded") if DEBUG;
            return $module;
        }
        elsif (defined $loaded->{ $module }) {
            next;
        }

        no strict REFS;
        $self->debug("attempting to load $module") if DEBUG;

        # 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 for $VERSION or @ISA.  This is a bit dodgy because we might be
        # loading something that has no ISA.  Need to cross-check with
        # what's going on in Badger::Class _autoload()

        my $loadname;
        if ( ($loadname = class($module)->maybe_load) ) {
            $self->debug("loaded $module") if DEBUG;
            $loaded->{ $module } = $loadname;
            return $module
        }

        $self->debug("failed to load $module") if DEBUG;
    }

    return undef;
}


sub found {
    my ($self, $type, $item, $args) = @_;

    if (ref $item) {
        # if it's a reference we found then forward it onto the appropriate
        # method, e.g found_array(), found_hash(), found_code().  Fall back
        # on found_ref()
        my $iref = blessed($item)
            ? OBJECT
            : lc ref $item;

        $self->debug(
            "Looking for handler methods: ",
            FOUND,'_'.$iref, "() or ",
            FOUND_REF, "()"
        ) if DEBUG;

        my $method
             = $self->can(FOUND . '_' . $iref)
            || $self->can(FOUND_REF)
            || return $self->error_msg( bad_ref => $self->{ item }, $type, $iref );

        $item = $method->($self, $type, $item, $args);
    }
    else {
        # otherwise it's the name of a module
        $item = $self->found_module($type, $item, $args);
    }

    # NOTE: an item can be defined but false, e.g. a Template::Plugin which
    # return '' from its new() method to indicate it does nothing objecty
    return unless defined $item;

    $self->debug("Found result: $type => $item") if DEBUG;

    # TODO: what about caching result?  Do we always leave that to subclasses?
    return $self->result($type, $item, $args);
}

sub found_module {
    # This method is called when a module name is found, either by being
    # predefined in the factory entry table, or loaded on demand from disk.
    # It ensures the module is loaded and and instantiates an object from the
    # class name
    my ($self, $type, $module, $args) = @_;
    $self->debug("Found module: $type => $module") if DEBUG;
    $self->{ loaded }->{ $module } ||= class($module)->load;
    return $self->construct($type, $module, $args);
}

sub found_array {
    # This method is called when an ARRAY reference is found.  We assume that
    # the first item is the module name (which needs to be loaded) and the
    # second item is the class name (which needs to be instantiated).
    my ($self, $type, $item, $args) = @_;
    my ($module, $class) = @$item;
    $self->{ loaded }->{ $module } ||= class($module)->load;
    return $self->construct($type, $class, $args);
}

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

    return $type eq DEFAULT
        ? $self->error_msg( no_default => $self->{ item } )
        : $self->error_msg( not_found => $self->{ item }, $type );
}

sub construct {
    my ($self, $type, $class, $args) = @_;
    $self->debug("constructing class: $type => $class") if DEBUG;
    return $class->new(@$args);
}

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

    return (
        join( PKG, map { ucfirst $_ } @bits ),
        join( PKG, @bits )
    );
}


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

    # upgrade class methods to calls on prototype
    $self = $self->prototype unless ref $self;

    # NOTE: this method can get called before we've called init_factory()
    # to define the item/items members, so we tread carefully.
    if ($self->{ item } && $self->{ item } eq $name) {
        return $self->SUPER::can('item');
    }
    elsif ($self->{ items } && $self->{ items } eq $name) {
        return $self->SUPER::can('items');
    }
    else {
        return $self->SUPER::can($name);
    }
}

sub result {
    $_[2];
}

sub AUTOLOAD {
    my ($self, @args) = @_;
    my ($name) = ($AUTOLOAD =~ /([^:]+)$/ );
    return if $name eq 'DESTROY';

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

    local $RUNAWAY = $RUNAWAY;
    $self->error("AUTOLOAD went runaway on $name")
        if ++$RUNAWAY > 10;

    # upgrade class methods to calls on prototype
    $self = $self->prototype unless ref $self;

    $self->debug("factory item: $self->{ item }") if DEBUG;

    if ($name eq $self->{ item }) {
        $self->class->method( $name => $self->can('item') );
    }
    elsif ($name eq $self->{ items }) {
        $self->class->method( $name => $self->can('items') )
    }
    elsif (my $item = $self->try( item => $name, @args )) {
        return $item;
    }
    else {
        my ($pkg, $file, $line) = caller;
        my $class = ref $self || $self;
        die $self->message( bad_method => $name, $class, $file, $line ), "\n";
    }

    # should be installed now
    $self->$name(@args);
}


1;

__END__