File Coverage

blib/lib/Class/Plugin/Util.pm

Criterion	Covered	Total	%
statement	29	142	20.4
branch	0	58	0.0
condition	0	21	0.0
subroutine	10	19	52.6
pod	7	7	100.0
total	46	247	18.6

# $Id: Util.pm,v 1.5 2007/07/11 23:54:29 ask Exp $
# $Source: /opt/CVS/classpluginutil/lib/Class/Plugin/Util.pm,v $
# $Author: ask $
# $HeadURL$
# $Revision: 1.5 $
# $Date: 2007/07/11 23:54:29 $
package Class::Plugin::Util;
use strict;
use warnings;
use warnings::register;
our $VERSION = 0.009;
use 5.006001;
{
    use English qw( -no_match_vars );
    use Module::Find;

    # List of subs to export.
    my %EXPORT = (
        supports                => \&supports,
        doesnt_support          => \&doesnt_support,
        factory_new             => \&factory_new,
        first_available_new     => \&first_available_new,
        require_class           => \&require_class,
        load_plugins            => \&load_plugins,
        get_plugins             => \&get_plugins,
    );

    my $CALL_LEVEL       = 0;

    my $CLASS_SEPARATOR  = q{::};

    # Cache of modules already tested.
    my %probe_cache      = ( );

    # Cache of modules that we know doesn't exist.
    my %probe_fail_cache = ( );

    # Cache of class names to file names.
    my %class_to_filename_cache = ( );

    my %plugins_for_superclass  = ( );

    # To be backward compatible with < 1.0
    BEGIN { ## no critic
        *Class::Plugin::Util::_require_class
            = \&Class::Plugin::Util::require_class;
    }

    #------------------------------------------------------------------------
    # ::import
    #
    # Our own Exporter functionality.
    # We don't wanna load in all the excess code of Exporter.
    #------------------------------------------------------------------------
    sub import {
        shift; ### delete package name from @_.
        my $caller = caller;

        no strict 'refs'; ## no critic
        while (@_) {
            my $export_attr = shift @_;
            my $sub_coderef = $EXPORT{$export_attr};

            if (not $sub_coderef) {
                require Carp;
                Carp->import('croak');

                ## no critic;
                croak("Class::Plugin::Util does not export '$export_attr'");
            }

            my $new_package_address   = join q{::}, ($caller, $export_attr);
            *{ $new_package_address } = $sub_coderef;
        }

        return;
    }

    sub _ensure_hashref {
        my ($orig_ref, $value) = @_;
        return { } if not $orig_ref;
        my %result;
        $value ||= 1;

        if (ref $orig_ref eq 'HASH') {
            %result = %{ $orig_ref };
        }
        elsif (ref $orig_ref eq 'ARRAY') {
            %result = map {$_ => $value} @{ $orig_ref };
        }
        else {
            $result{$orig_ref} = $value;
        }

        return \%result;
    }

    #------------------------------------------------------------------------
    # ::load_plugins( $superclass, @$opt_ignore_ref )
    #
    # Load all modules that is a subclass of superclass and that has
    # a register_plugin method. The register plugin method should return
    # a hashref like this:
    #
    #   return {
    #       name    => 'plugin_name',
    #       class   => __PACKAGE__,
    #       aliases => [ qw(Foo foo bar BAR) ],
    #------------------------------------------------------------------------
    sub load_plugins {
        my ($superclass, $ignore_ref) = @_;
        $superclass  ||= caller;
        return 1 if $plugins_for_superclass{$superclass};

        my @subclasses = Module::Find::findallmod($superclass);

        $ignore_ref = _ensure_hashref($ignore_ref);

        my %plugins;

        SUBCLASS:
        for my $subclass (@subclasses) {
            my $colcol_pos = rindex $subclass, q{::};
            my $last_name  = $colcol_pos >= 0
                ? substr $subclass, $colcol_pos + 2, length $subclass
                : $subclass;
            next SUBCLASS if $ignore_ref->{$last_name};
            my $req_ret = require_class($subclass) ;
            next SUBCLASS if not $req_ret;
            next SUBCLASS if not $subclass->can('register_plugin');

            my $plugin_info           = $subclass->register_plugin( );
            $plugin_info            ||= { };
            $plugin_info->{name}    ||= $last_name;
            $plugin_info->{class}   ||= $subclass;

            my $aliases             = $plugin_info->{aliases};
            $aliases                = _ensure_hashref($aliases, $subclass);
            $aliases->{$last_name}  = $subclass;

            while (my ($alias, $target) = each %{ $aliases }) {
                $plugins_for_superclass{$superclass}{$alias} = $target;
            }

        };

        #$plugins_for_superclass{$superclass} = \%plugins;

        return 1;
    }

    sub get_plugins {
        my ($superclass) = @_;
        $superclass ||= caller;

        my $plugins = $plugins_for_superclass{$superclass};
        return ref $plugins ? $plugins
                            : { };
    }

    #------------------------------------------------------------------------
    # ::supports( @modules )
    #
    # Return true if all the modules are available.
    #------------------------------------------------------------------------
    sub supports {
        my (@modules) = @_;

        return !doesnt_support(@modules);
    }

    #------------------------------------------------------------------------
    # ::doesnt_support( @modules )
    #
    # Return the first module not available.
    #------------------------------------------------------------------------
    sub doesnt_support {
        my (@modules) = @_;

        PROBE:
        for my $required_module (@modules) {
            if (! exists $probe_cache{$required_module}) {
                if (! require_class($required_module)) {
                    return $required_module;
                }
            }
            $probe_cache{$required_module}++;
        }

        # if we made it this far, everything was supported.
        return;
    }

    #------------------------------------------------------------------------
    # ::first_available_new( \@classes_to_try, @arguments_to_new )
    #
    # Return a new instance of the first class in the list of classes to try
    # that are available.
    #------------------------------------------------------------------------
    sub first_available_new {
        my $classes_to_try_ref = shift;

        CLASS:
        for my $class (@{ $classes_to_try_ref }) {
            next CLASS if exists $probe_fail_cache{$class};
            next CLASS if ! _CLASS($class);
            next CLASS if ! require_class($class);

            my $try_this_object = $class->new( @_ );

            if (! $try_this_object) {
                $probe_fail_cache{$class} = 1;
                next CLASS;
            }

            return $try_this_object;
        }

        return;
    }

    #------------------------------------------------------------------------
    # ->factory_new($class, @arguments_to_new)
    #
    # Return new instance of class in variable.
    # The class will be required.
    #------------------------------------------------------------------------
    sub factory_new {
        my $class = shift;

        require_class($class) or return;

        return $class->new(@_);
    }

    #------------------------------------------------------------------------
    # ->require_class($class, $opt_import)
    #
    # Load module by class name.
    # Does not die on error. (like missing file).
    #
    # If $opt_import is set, require_class will behave as new and will
    # import the module into the callers namespace. (@opt_imports specifies
    # what to import).
    #
    #------------------------------------------------------------------------
    sub require_class {
        my ($class, $options_ref) =  @_;
        $options_ref            ||= {  };

        # Must be valid Perl class name.
        if (! _CLASS($class)) {
            require Carp;
            Carp->import('croak');
            ## no critic
            croak("$class is not a valid class name.");
        }

        NOSTRICT: {
            no strict 'refs'; ## no critic;

            # It's already loaded if $VERSION or @ISA is defined in the class.
            return 1 if defined ${"${class}::VERSION"};
            return 1 if defined @{"${class}::ISA"};

            # It's also loaded if we find a function in that class.
            METHOD:
            for my $namespace_entry (keys %{"${class}::"}) {
                if (substr($namespace_entry, -2, 2) eq $CLASS_SEPARATOR) {
                    # It's a subclass, so skip it.
                    next METHOD;
                }
                return 1 if defined &{"${class}::$namespace_entry"};
            }
        }

        # Convert class to filename (Cached).
        # (Does not have to be cross-platform compatible paths
        #  as perl takes care of this in the background).
        my $class_filename = $class_to_filename_cache{$class};
        if (! defined $class_filename) {
            $class_filename =  $class . q{.pm};
            $class_filename =~ s{::}{/}xmsg;
            $class_to_filename_cache{$class} = $class_filename;
        }

        # Load the module if it's not already loaded.
        if (!$INC{$class_filename}) {
            my ($call_pkg, $call_file, $call_line) = caller $CALL_LEVEL;

            my $require_codetext = <<"ENDTEXT"
                #line $call_line "$call_file"
                CORE::require(\$class_filename)
ENDTEXT
;
            if ($options_ref->{'import'}) {
                my @imports;
                if (ref $options_ref->{'import'} eq 'HASH') {
                    @imports = @{ $options_ref->{'import'} };
                }
                $require_codetext .= <<"ENDTEXT"
                    package $call_pkg;
                    \$module->import(\@opt_imports);
ENDTEXT
;
            }
            $require_codetext =~ s/\A\s+//xmsg;
            eval $require_codetext; ## no critic

            if ($EVAL_ERROR) {
                my $error_msg = $EVAL_ERROR;
                if (warnings::enabled) { ## no critic
                    warnings::warn(__PACKAGE__, "load class: $error_msg"); ## no critic
                }
                return;
            }

        }

        return 1;
    }

    #------------------------------------------------------------------------
    # ->_CLASS( $class_name )
    #
    # Copied and pasted from Params::Util.
    # Thanks to Adam Kennedy
    #------------------------------------------------------------------------
    sub _CLASS { ## no critic
        (defined $_[0] and ! ref $_[0] and $_[0]
            =~ m/^[^\W\d]\w*(?:::\w+)*$/s) ? $_[0] : undef; ## no critic;
    } ## no critic

}

1; # keep require happy.

__END__