Class::Plugin::Util - Utility functions for supporting Plug-ins.

    use Class::Plugin::Util qw( supports doesnt_support factory_new first_available_new)

    use Class::Plugin::Util qw(supports);
    use MyPlugin::XMLSupport;

    # The plugin we want to use has a requires class method that
    # returns an array of modules it needs to function properly:

    my @required_modules = MyPlugin::XMLSupport->requires;

    # The plugin shouldn't use the required modules itself
    # it should only return the modules it needs to use in
    # in the required method above. The supports method checks
    # if the required modules are available and loads the modules
    # for us.

    if (supports( @required_modules )) {
        print 'We have XML support', "\n";

        my $xml = MyPlugin::XMLSupport->new( );

        [ ... ]
    }

    package MyPlugin::XMLSupport;
    {
        sub new {
            return bless { }, shift;
        }

        sub requires {
            return 'XML::Parser';
        }
    }

    my $exporter = MyApp::Export->new({
        format => 'YAML',
    });

    $exporter->export($data);

    package MyApp::Export;
    use strict;
    use warnings;
    use Class::Plugin::Util qw( first_available_new );
    {

        my @LIST_OF_YAML_HANDLERS = qw(
            MyApp::Export::YAML::LibYAML
            MyApp::Export::YAML::Syck
            MyApp::Export::YAML
        );

        my @LIST_OF_JSON_HANDLERS = qw(
            MyApp::Export::JSON::Syck
            MyApp::Export::JSON::PC
            MyApp::Export::JSON
        );

        my %FORMAT_TO_HANDLER = (
            'JSON'  => [ @LIST_OF_JSON_HANDLERS ],
            'YAML'  => [ @LIST_OF_YAML_HANDLERS ],
        ); 

        sub new {
            my ($class, $arg_ref) = @_;

            # The format argument decides which format we choose. 
            my $format = uc( $arg_ref->{format} );
            # Default format is YAML.
            $format  ||= 'YAML',

            my $select_ref = $FORMAT_TO_HANDLER{$format};

            my $object = Class::Plugin::Util::first_available_new($select_ref, $arg_ref);

            return $object;
        } 
    }

    1;

    package MyApp::Export::Base;
    use strict;
    use warnings;
    use Carp;
    use Class::Plugin::Util;
    {
        sub new {
            my ($class, $arg_ref) = @_;

            # All MyApp::Export:: classes should have a requires method which returns
            # a list of all modules it requires to do it's work. 
            my @this_handler_requires = $class->requires;

            # check if we're missing any modules.
            my $missing_module = Class::Plugin::Util::doesnt_support(@this_handler_requires);

            if ($missing_module) {
                carp    "$class requires $missing_module, " .
                        "please install from CPAN."         ;
            }

            my $self = { };
            bless $self, $class;

            return $self; 
        }

        # transform is the function exporters should use to transform the data to it's format.
        sub transform {
            croak 'You cannot use MyApp::Export::Base directly. Subclass it!';
        }

        # the list of modules we require.
        sub requires {
            croak 'You cannot use MyApp::Export::Base directly. Subclass it!';
        }

        sub export {
            my ($self, $data) = @_;
            return if not $data;

            return $self->transform($data);
        }
    }

    1;

    package MyApp::Export::YAML::LibYAML;
    use strict;
    use warnings;
    use base 'MyApp::Export::Base';
    {

        my @MODULES_REQUIRED = qw( YAML::LibYAML );

        sub transform {
            my ($self, $data_ref) = @_;

            return YAML::LibYAML::Dump($data_ref);
        }

        sub requires {
            return @MODULES_REQUIRED;
        }
    }

    1;

    package MyApp::Export::JSON::Syck;
    use strict;
    use warnings;
    use base 'MyApp::Export::Base';
    {

        my @MODULES_REQUIRED = qw( JSON::Syck );

        sub transform {
            my ($self, $data_ref) = @_;

            return JSON::Syck::Dump($data_ref);
        }

        sub requires {
            return @MODULES_REQUIRED;
        }
    }

    1;

    return {
        name    => 'MyPluginName',
        class   => __PACKAGE__,
        aliases => [qw(foo FOO bar BAR)],
    }

    load_plugins();

    sub new {
        my ($class, $wanted_type) = @_;

        my $plugins_ref = get_plugins();
        my $plugin = $plugins_ref->{$wanted_type};

        return $plugin->new();
    }

# $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 <adamk@cpan.org>
    #------------------------------------------------------------------------
    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__

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
# End:
# vim: expandtab tabstop=4 shiftwidth=4 shiftround