The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use 5.006;
use strict;
use warnings;

package Metabase::Index::FlatFile;
# ABSTRACT: Metabase flat-file index
our $VERSION = '1.001'; # VERSION

use Moose;
use Moose::Util::TypeConstraints;

use Carp ();
use Data::Stream::Bulk::Array;
use Fcntl ':flock';
use IO::File ();
use List::AllUtils qw/any all/;
use JSON 2 qw/encode_json decode_json/;
use Regexp::SQL::LIKE 0.001 qw/to_regexp/;
use Tie::File;
use MooseX::Types::Path::Class;

with 'Metabase::Index';

has 'index_file' => (
    is => 'ro',
    isa => 'Path::Class::File',
    coerce => 1,
    required => 1,
);

sub initialize {}

sub add {
    my ($self, $fact) = @_;
    Carp::confess( "can't index a Fact without a GUID" ) unless $fact->guid;

    my $metadata = $self->clone_metadata( $fact );
    my $line = encode_json($metadata);
    my $filename = $self->index_file;
    my $fh = IO::File->new( $filename, "a+" )
        or Carp::confess( "Couldn't append to '$filename': $!" );
    $fh->binmode(':raw');
    flock $fh, LOCK_EX;
    {
        seek $fh, 2, 0; # end
        print {$fh} $line, "\n";
    }
    $fh->close;
}

sub query {
    my ($self, %spec) = @_;

    my $filename = $self->index_file;
    return Data::Stream::Bulk::Array->new( array => [] )
      unless -f $filename;

    my $query = $self->get_native_query( \%spec );
    my $fh = IO::File->new( $filename, "r" )
        or Carp::confess( "Couldn't read from '$filename': $!" );
    $fh->binmode(':raw');
    my @matches;
    flock $fh, LOCK_SH;
    {
        while ( my $line = <$fh> ) {
            my $parsed = decode_json($line);
            push @matches, $parsed if $query->{-where}->($parsed);
        }
    }
    $fh->close;

    # sort
    if ( exists $spec{-order} ) {
      @matches = sort { $spec{-order}->($a, $b) } @matches;
    }

    # limit
    if ( exists $spec{-limit} ) {
      @matches = splice(@matches, 0, $spec{-limit});
    }

    return Data::Stream::Bulk::Array->new(
      array => [ map { $_->{'core.guid'} } @matches ]
    );
}

sub count {
  my ($self, %spec) = @_;
  my $result = [ $self->query(%spec)->all ];
  return scalar @$result;
}

sub delete {
  my ($self, $guid) = @_;

  my @index;
  my $obj = tie @index, 'Tie::File', $self->index_file->stringify;
  $obj->flock(LOCK_EX);
  {
    for my $i ( 0 .. $#index ) {
      my $parsed = decode_json($index[$i]);
      if ($parsed->{'core.guid'} eq $guid ) {
        splice @index, $i, 1; # delete that row
        last;
      }
    }
  }
  undef $obj;
  untie @index;

  return 1;
}

#--------------------------------------------------------------------------#
# required by Metabase::Query
#
# ops return closures that define the necessary logic when called
# with hash of index fields
#--------------------------------------------------------------------------#

sub translate_query {
  my ( $self, $spec ) = @_;

  # translate search query into a coderef
  if ( exists $spec->{-where} ) {
    $spec->{-where} = $self->dispatch_query_op( $spec->{-where} );
  }
  else {
    $spec->{-where} = sub { 1 };
  }

  if ( exists $spec->{-order} ) {
    my $sort_fcn = sub { 0 };
    my @order = @{$spec->{-order}};
    while ( @order ) {
      my ($dir, $field) = splice( @order, 0, 2);
      my $old_fcn = $sort_fcn;
      my $new_fcn = ($dir eq '-asc')
        ? sub { my ($i, $j) = @_; return $i->{$field} cmp $j->{$field} }
        : sub { my ($i, $j) = @_; return $j->{$field} cmp $i->{$field} }
        ;
      $sort_fcn = sub {
        my ($i, $j) = @_;
        return $old_fcn->($i, $j) || $new_fcn->($i, $j);
      }
    }
    $spec->{-order} = $sort_fcn;
  }

  return $spec;
}

sub op_eq {
  my ($self, $field, $val) = @_;
  return sub {
    my $data = shift->{$field} || '';
    return $data eq $val
  };
}

sub op_ne {
  my ($self, $field, $val) = @_;
  return sub {
    my $data = shift->{$field} || '';
    return $data ne $val
  };
}

sub op_gt {
  my ($self, $field, $val) = @_;
  return sub {
    my $data = shift->{$field} || '';
    return $data gt $val
  };
}

sub op_lt {
  my ($self, $field, $val) = @_;
  return sub {
    my $data = shift->{$field} || '';
    return $data lt $val
  };
}

sub op_ge {
  my ($self, $field, $val) = @_;
  return sub {
    my $data = shift->{$field} || '';
    return $data ge $val
  };
}

sub op_le {
  my ($self, $field, $val) = @_;
  return sub {
    my $data = shift->{$field} || '';
    return $data le $val
  };
}

sub op_between {
  my ($self, $field, $low, $high) = @_;
  return sub {
    my $data = shift->{$field};
    return $data ge $low && $data le $high;
  };
}

sub op_like {
  my ($self, $field, $val) = @_;
  my ($re) = to_regexp($val);
  return sub {
    my $data = shift->{$field};
    return $data =~ $re;
  }
}

sub op_not {
  my ($self, $pred) = @_;
  my $clause = $self->dispatch_query_op($pred);
  return sub {
    return ! $clause->(shift)
  }
}

sub op_or {
  my ($self, @args) = @_;
  my @predicates = map { $self->dispatch_query_op($_) } @args;
  return sub {
    my $data = shift;
    return any { $_->($data) } @predicates;
  }
}

sub op_and {
  my ($self, @args) = @_;
  my @predicates = map { $self->dispatch_query_op($_) } @args;
  return sub {
    my $data = shift;
    return all { $_->($data) } @predicates;
  }
}

1;



=pod

=head1 NAME

Metabase::Index::FlatFile - Metabase flat-file index

=head1 VERSION

version 1.001

=head1 SYNOPSIS

    require Metabase::Index::FlatFile;

    my $index = Metabase::Index::FlatFile->new(
      index_file => "$temp_dir/store/metabase.index",
    );

=head1 DESCRIPTION

Flat-file Metabase index.

=for Pod::Coverage::TrustPod add search delete count LOCK_EX LOCK_SH
initialize query translate_query op_eq op_ne op_gt op_lt op_ge op_le
op_between op_like op_not op_or op_and

=head1 USAGE

See L<Metabase::Index>, L<Metabase::Query> and L<Metabase::Librarian>.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Leon Brocard <acme@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2012 by David Golden.

This is free software, licensed under:

  The Apache License, Version 2.0, January 2004

=cut


__END__