view release on metacpan or  search on metacpan

lib/Lingua/Thesaurus/Storage.pm  view on Meta::CPAN

package Lingua::Thesaurus::Storage;
use Moose::Role;
use Moose::Meta::Class;
use namespace::clean -except => 'meta';

#======================================================================
# ATTRIBUTES
#======================================================================

has 'params'           => (is => 'ro', isa => 'HashRef',
                           lazy => 1, builder => '_params',
                           predicate => 'has_params',
         documentation => "params saved in storage");

has 'term_class'       => (is => 'ro', isa => 'ClassName',
                           lazy => 1, builder => '_build_term_class',
                           init_arg => undef,
         documentation => "dynamic class for terms");

has 'relType_class'    => (is => 'ro', isa => 'ClassName',
                           lazy => 1, builder => '_relType_class',
                           init_arg => undef,
         documentation => "class for relTypes");

#======================================================================
# REQUIRED METHODS
#======================================================================

requires 'search_terms';
requires 'fetch_term';
requires 'related';
requires 'rel_types';
requires 'fetch_rel_type';

requires 'do_transaction';
requires 'initialize';
requires 'store_rel_type';
requires 'store_relation';
requires 'store_term';
requires 'finalize';

requires '_params';

#======================================================================
# IMPLEMENTED METHODS
#======================================================================

sub _build_term_class {
  my ($self) = @_;

  # compute subclass name from the list of possible relations
  my @rel_ids       = $self->rel_types;
  my $subclass_name = join "_", "auto", sort @rel_ids;
  my $parent_class  = $self->_parent_term_class;
  my $pkg_name      = "${parent_class}::${subclass_name}";

  # build subclass (only if it does not already exist)
  no strict 'refs';
  unless (%{$pkg_name."::"}) {
    # build a closure for each relation type (NT, BT, etc.)
    my %methods;
    foreach my $rel_id (@rel_ids) {
      $methods{$rel_id} = sub {my $self = shift;
                               my @rel  = map {$_->[1]} $self->related($rel_id);
                               return wantarray ? @rel : $rel[0];};
    }

    # dynamically create a new subclass
    my $meta_subclass = Moose::Meta::Class->create(
      $pkg_name,