File Coverage

blib/lib/Search/Mousse.pm

Criterion	Covered	Total	%
statement	51	137	37.2
branch	5	32	15.6
condition	3	8	37.5
subroutine	10	17	58.8
pod	6	6	100.0
total	75	200	37.5

package Search::Mousse;
use strict;
our $VERSION = '0.32';
use base qw(Class::Accessor::Chained::Fast);
__PACKAGE__->mk_accessors(
  qw(directory name stemmer key_to_id id_to_key id_to_value word_to_id
    id_to_related and
  )
);
use CDB_File;
use CDB_File_Thawed;
use List::Uniq qw(uniq);
use Path::Class;
use Search::QueryParser;
use Set::Scalar;

sub new {
  my $class = shift;
  my $self  = {};
  bless $self, $class;

	my %args = @_;
	$self->directory($args{directory});
  $self->name($args{name});
  $self->stemmer(
    $args{stemmer} ||
    sub {
      my $words = lc shift;
      return uniq(split / /, $words);
    }
  );
  $self->and($args{and} || 0);

	$self->_init;
  return $self;
}

sub _init {
  my ($self) = @_;
  my $name   = $self->name;
  my $dir    = $self->directory;

  my $filename = file($dir, "${name}_key_to_id.cdb");
  tie my %cdb1, 'CDB_File', $filename or die "tie failed: $!\n";
  $self->key_to_id(\%cdb1);

  $filename = file($dir, "${name}_id_to_key.cdb");
  tie my %cdb2, 'CDB_File', $filename or die "tie failed: $!\n";
  $self->id_to_key(\%cdb2);

  $filename = file($dir, "${name}_id_to_value.cdb");
  tie my %cdb3, 'CDB_File_Thawed', $filename or die "tie failed: $!\n";
  $self->id_to_value(\%cdb3);

  $filename = file($dir, "${name}_word_to_id.cdb");
  tie my %cdb4, 'CDB_File_Thawed', $filename or die "tie failed: $!\n";
  $self->word_to_id(\%cdb4);

  $filename = file($dir, "${name}_id_to_related.cdb");
  if (-f $filename) {
    tie my %cdb7, 'CDB_File_Thawed', $filename or die "tie failed: $!\n";
    $self->id_to_related(\%cdb7);
  }
}

sub fetch {
  my ($self, $key) = @_;

  my $id = $self->key_to_id->{$key};
  return unless $id;
  return $self->id_to_value->{$id};
}

sub fetch_related {
  my ($self, $key) = @_;
  my $id_to_value = $self->id_to_value;

  my $id = $self->key_to_id->{$key};
  return unless $id;
  my $ids = $self->id_to_related->{$id} || [];
  return map { $id_to_value->{$_} } @$ids;
}

sub fetch_related_keys {
  my ($self, $key) = @_;
  my $id_to_key = $self->id_to_key;

  my $id = $self->key_to_id->{$key};
  return unless $id;
  my $ids = $self->id_to_related->{$id} || [];
  return map { $id_to_key->{$_} } @$ids;
}

sub search {
  my ($self, $words) = @_;

  my @ids = $self->_search_ids($words);

  my @values = map { $self->id_to_value->{$_} } @ids;
  return @values;
}

sub search_keys {
  my ($self, $words) = @_;
  my @ids = $self->_search_ids($words);

  my @keys = map { $self->id_to_key->{$_} } @ids;
  return @keys;
}

sub _search_ids {
  my ($self, $words) = @_;

  my $qp = Search::QueryParser->new;
  my $query = $qp->parse($words);
  return unless $query;

  my @union;
  foreach my $term (@{$query->{""}}) {
    my $value = $term->{value};
    my @values = $self->stemmer->($value);
    push @union, $values[0];
  }

  my @plus;
  foreach my $term (@{$query->{"+"}}) {
    my $value = $term->{value};
    my @values = $self->stemmer->($value);
    push @plus, $values[0];
  }

  my @minus;
  foreach my $term (@{$query->{"-"}}) {
    my $value = $term->{value};
    my @values = $self->stemmer->($value);
    push @minus, $values[0];
  }

  if ($self->and) {
    push @plus, @union;
    @union = ();
  }

  my $s = Set::Scalar->new;

	if (@union) {
    foreach my $word (@union) {
      next unless exists $self->word_to_id->{$word};
      my @ids = @{ $self->word_to_id->{$word} };
      $s->insert(@ids);
    }

    foreach my $word (@plus) {
      return unless exists $self->word_to_id->{$word};
      my @ids = @{ $self->word_to_id->{$word} };
      my $s2 = Set::Scalar->new(@ids);
      $s = $s->intersection($s2);
    }
  } else {
    my $word = pop @plus;
    my @ids = @{ $self->word_to_id->{$word} };
    $s->insert(@ids);

    foreach my $word (@plus) {
      return unless exists $self->word_to_id->{$word};
      my @ids = @{ $self->word_to_id->{$word} };
      my $s2 = Set::Scalar->new(@ids);
      $s = $s->intersection($s2);
    }
  }

  foreach my $word (@minus) {
    next unless exists $self->word_to_id->{$word};
    my @ids = @{ $self->word_to_id->{$word} };
    $s = $s->delete(@ids);
  }

  return $s->members;
}

1;

__END__