lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / PluginManager.pm

package Lire::PluginManager;

use strict;

use vars qw/ $instance %plugin_types /;

use Carp;

use Lire::Config;
use Lire::Error qw/ file_not_readable /;
use Lire::OldDlfAdapter;
use Lire::Utils qw/ file_content check_param check_object_param /;

$instance = new Lire::PluginManager();

%plugin_types = ( 'output_format' => 'Lire::OutputFormat',
                  'chart_type'     => 'Lire::ChartType',
                  'dlf_analyser'  => 'Lire::DlfAnalyser',
                  'dlf_converter' => 'Lire::DlfConverter', );

sub new {
    return bless {  'output_format' => {},
                    'dlf_analyser'  => {},
                    'dlf_converter' => {},
                    'chart_type'    => {},
                 }, shift;
}

=pod

=head1 NAME

Lire::PluginManager - Manages the Lire plugins.


=head1 SYNOPSIS

  use Lire::PluginManager;

  Lire::PluginManager->register_default_plugins();

  my $plugin = new MyDlfConverter();
  Lire::PluginManager->register_plugin( $plufin );

  my $plugins = Lire::PluginManager->plugins( 'dlf_analyser' );

  my $converter = Lire::PluginManager->get_plugin('dlf_analyser', 'combined');

=head1 DESCRIPTION

All method can be called as class method on the Lire::PlugingManager
module or on an instance.

=head2 PLUGIN TYPES

There are four kind of plugins defined in Lire: dlf_analyser,
dlf_converter, chart_type and output_format.

=head2 instance()

Returns the singleton instance of the PluginManager

=cut

sub instance {
    return $instance;
}

sub check_type {
    my ( $type ) = @_;

    check_param( $type, 'type' );
    return 1 if exists $plugin_types{$type};

    my @types = map { "'$_'" } sort keys %plugin_types;
    croak "'type' parameter should be one of " . join ( ", ", @types[0..$#types-1] ) . " or $types[-1]: '$type'";
}

=pod

=head2 plugin_names( $type )

Returns an array reference containing the names of all registered
plugin of type $type.

=cut

sub plugin_names {
    my ( $self, $type ) = @_;
    $self = $instance unless ref $self;

    check_type( $type );

    return [ keys %{$self->{$type}} ];
}

=pod

=head2 plugins( $type )

Returns an array reference containing all the Plugin objects registerd
for $type.

=cut

sub plugins {
    my ( $self, $type ) = @_;
    $self = $instance unless ref $self;

    check_type( $type );

    return [ values %{$self->{$type}} ];
}

=pod

=head2 has_plugin( $type, $name )

Returns true if there is a Lire::Plugin named $name registered for type
$type.

=cut

sub has_plugin {
    my ( $self, $type, $name ) = @_;
    $self = $instance unless ref $self;

    check_param( $name, 'name' );
    check_type( $type );

    return exists $self->{$type}{$name};
}

=pod

=head2 get_plugin( $type, $name )

Returns the Lire::Plugin object named $name of type $type. Croaks when
there is no plugin registerd under that name.

=cut

sub get_plugin {
    my ( $self, $type, $name ) = @_;
    $self = $instance unless ref $self;

    check_param( $name, 'name' );
    check_type( $type );

    croak "no '$type' plugin '$name' registered"
      unless $self->has_plugin( $type, $name );

    return $self->{$type}{$name};
}

=pod

=head2 register_plugin( $plugin )

Registers the Lire::Plugin $plugin. The type and name of the plugin
are queried using the Lire::Plugin interface. An error will be thrown
if there is already a plugin registered under the same name and type.

=cut

sub register_plugin {
    my ( $self, $plugin ) = @_;
    $self = $instance unless ref $self;

    check_object_param( $plugin, 'plugin', 'Lire::Plugin',  );

    my $type = $plugin->type();

    croak( "plugin '", $plugin->name(), "' has an unknown type: '$type'" )
      unless exists $plugin_types{$type};

    croak( "'$type' plugin should be a '$plugin_types{$type}' instance: '",
           ref($plugin), "'" )
      unless UNIVERSAL::isa( $plugin, $plugin_types{$type} );

    croak( "there is already a '$type' plugin registered under name '",
           $plugin->name(), "'" )
      if $self->has_plugin( $type, $plugin->name() );

    $self->{$type}{$plugin->name()} = $plugin;

    return;
}

=pod

=head2 unregister_plugin( $type, $name )

Unregister the plugin $name of type $type. The method will dies if
there is no such plugin.

=cut

sub unregister_plugin {
    my ( $self, $type, $name) = @_;
    $self = $instance unless ref $self;

    check_param( $name, 'name' );
    check_type( $type );

    croak "no '$type' plugin '$name' registered"
      unless $self->has_plugin( $type, $name );

    delete $self->{$type}{$name};

    return;
}

=pod

=head2 analysers_by_src( $schema )

Returns in an array reference all the analysers that declare $schema
as their src_schema().

=cut

sub analysers_by_src {
    my ( $self, $schema ) = @_;

    check_param( $schema, 'schema' );

    my @result = ();
    foreach my $analyser ( @{$self->plugins( 'dlf_analyser' )} ) {
        push @result, $analyser
          if $analyser->src_schema() eq $schema;
    }
    return \@result;
}

=pod

=head2 analysers_by_dst( $schema )

Returns in an array reference all the analysers that declare $schema
as their dst_schema().

=cut

sub analysers_by_dst {
    my ( $self, $schema ) = @_;

    check_param( $schema, 'schema' );

    my @result = ();
    foreach my $analyser ( @{$self->plugins( 'dlf_analyser' )} ) {
        push @result, $analyser
          if $analyser->dst_schema() eq $schema;
    }

    return \@result;
}

=pod 

=head2 register_default_plugins()

This method will load and initialize all the plugins available. The
plugins are registered by executing all the perl scripts found in the
directories listed in the 'plugins_init_path' configuration variable.

These scripts should call Lire::PluginManager->register_plugin() to
register the plugins.

For compatibility with previous versions of Lire, it will also
registers the DlfConverters initialized using older mechanism.

=cut

sub register_default_plugins {
    my $self = $_[0];
    $self = $instance unless ref $self;

    my $init_files =
      $self->_init_files( Lire::Config->get( 'plugins_init_path' ) );
    foreach my $init_file ( @$init_files ) {
        eval file_content( $init_file );
        warn( "error in initialiser '$init_file': $@\n" )
          if $@;
    }

    $self->_create_old_dlf_adapters();
    $self->_load_dlf_adapters();

    return;
}

sub _create_old_dlf_adapters {
    my $self = $_[0];

    my $convertors_dir = Lire::Config->get( 'lr_old_convertors_dir' );
    my $address_file = Lire::Config->get( 'lr_old_address_file' );
    my $service2schema = $self->_parse_old_map_file( $address_file );
    while ( my ($service, $schema) = each %$service2schema ) {
        unless ( Lire::DlfSchema->has_superservice( $schema )) {
            warn "invalid superservice '$schema' assigned to service '$service'\n";
            next;
        }
        my $script = $convertors_dir .'/' . $service . '2dlf';
        if ( -x $script ) {
            my $adapter = new Lire::OldDlfAdapter( $schema, $script );
            $self->register_plugin( $adapter );
        } else {
            warn "can't find executable $service" . "2dlf in $convertors_dir\n";
        }
    }
}

sub _parse_old_map_file {
    my ($self, $file) = @_;

    my %map = ();

    open my $fh, $file
      or croak( file_not_readable( $file ) );
    my $line;
    while ( defined($line = <$fh>) ) {
        next if $line =~ /^#/;       # Skip comments
        next if $line =~ /^\s*$/;    # Skip empty lines
        my ($key, $value) = $line =~ /^(\S+)\s+(\S+)\s*(#.*)?$/
          or warn "can't parse line $. of file '$file'\n";
        $map{$key} = $value
          if defined $key;
    }
    close $fh;

    return \%map;
}

sub _load_dlf_adapters {
    my $self = $_[0];

    my $init_files =
      $self->_init_files( Lire::Config->get( 'lr_converters_init_path' ) );
    foreach my $init_file ( @$init_files )
    {
        my $initializer = eval {  file_content( $init_file ) };
        if ( $@ ) {
            warn "error reading DLF converter initializer file '$init_file': $@\n";
            next;
        }
        my @converters = eval $initializer;
        if ( $@ ) {
            warn "error while running initializer in '$init_file': $@\n";
            next;
        }
        foreach my $c ( @converters ) {
            if ( UNIVERSAL::isa( $c, 'Lire::DlfConverter' ) ) {
                $self->register_plugin( $c );
            } else {
                warn "initializaer '$init_file' didn't return a Lire::DlfConverter object: $c\n";
            }
        }
    }
}

sub _init_files {
    my ( $self, $dirs ) = @_;

    my @initializers = ();
    my %dirs;
    foreach my $dir ( @$dirs ) {
        next if exists $dirs{$dir};
        $dirs{$dir} = 'done';
        opendir my $dh, $dir
          or croak "opendir failed '$dir': $!";
        foreach my $file ( map { "$dir/$_" } readdir $dh ) {
            next unless -f $file;
            push @initializers, $file;
        }
        closedir $dh;
    }

    return \@initializers;
}

# keep perl happy
1;

__END__

=pod

=head1 SEE ALSO

Lire::Plugin(3pm), Lire::OutputFormat(3pm), Lire::DlfAnalyser(3pm),
Lire::DlfConverter(3pm)

=head1 AUTHOR

  Francis J. Lacoste <flacoste@logreport.org>

=head1 VERSION

$Id: PluginManager.pm,v 1.8 2006/07/23 13:16:29 vanbaal Exp $

=head1 COPYRIGHT

Copyright (C) 2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html.

=cut