view release on metacpan or  search on metacpan

lib/Class/Plugin/Util.pm  view on Meta::CPAN

                ## 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}++;
        }