lib/Search/Estraier.pm

package Search::Estraier;

use 5.008;
use strict;
use warnings;

our $VERSION = '0.00';

=head1 NAME

Search::Estraier - pure perl module to use Hyper Estraier search engine

=head1 SYNOPSIS

  use Search::Estraier;
  my $est = new Search::Estraier();

=head1 DESCRIPTION

This module is implementation of node API of Hyper Estraier. Since it's
perl-only module with dependencies only on standard perl modules, it will
run on all platforms on which perl runs. It doesn't require compilation
or Hyper Estraier development files on target machine.

It is implemented as multiple packages which closly resamble Ruby
implementation. It also includes methods to manage nodes.

=cut

=head1 Inheritable common methods

This methods should really move somewhere else.

=head2 _s

Remove multiple whitespaces from string, as well as whitespaces at beginning or end

 my $text = $self->_s(" this  is a text  ");
 $text = 'this is a text';

=cut

sub _s {
        my $text = $_[1] || return;
        $text =~ s/\s\s+/ /gs;
        $text =~ s/^\s+//;
        $text =~ s/\s+$//;
        return $text;
}

package Search::Estraier::Document;

use Carp qw/croak confess/;

use Search::Estraier;
our @ISA = qw/Search::Estraier/;

=head1 Search::Estraier::Document

This class implements Document which is collection of attributes
(key=value), vectors (also key value) display text and hidden text.


=head2 new

Create new document, empty or from draft.

  my $doc = new Search::HyperEstraier::Document;
  my $doc2 = new Search::HyperEstraier::Document( $draft );

=cut

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

        $self->{id} = -1;

        my $draft = shift;

        if ($draft) {
                my $in_text = 0;
                foreach my $line (split(/\n/, $draft)) {

                        if ($in_text) {
                                if ($line =~ /^\t/) {
                                        push @{ $self->{htexts} }, substr($line, 1);
                                } else {
                                        push @{ $self->{dtexts} }, $line;
                                }
                                next;
                        }

                        if ($line =~ m/^%VECTOR\t(.+)$/) {
                                my @fields = split(/\t/, $1);
                                for my $i ( 0 .. ($#fields - 1) ) {
                                        $self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];
                                        $i++;
                                }
                                next;
                        } elsif ($line =~ m/^%/) {
                                # What is this? comment?
                                #warn "$line\n";
                                next;
                        } elsif ($line =~ m/^$/) {
                                $in_text = 1;
                                next;
                        } elsif ($line =~ m/^(.+)=(.+)$/) {
                                $self->{attrs}->{ $1 } = $2;
                                next;
                        }

                        warn "draft ignored: $line\n";
                }
        }

        $self ? return $self : return undef;
}


=head2 add_attr

Add an attribute.

  $doc->add_attr( name => 'value' );

Delete attribute using

  $doc->add_attr( name => undef );

=cut

sub add_attr {
        my $self = shift;
        my $attrs = {@_};

        while (my ($name, $value) = each %{ $attrs }) {
                if (! defined($value)) {
                        delete( $self->{attrs}->{ $self->_s($name) } );
                } else {
                        $self->{attrs}->{ $self->_s($name) } = $self->_s($value);
                }
        }

        return 1;
}


=head2 add_text

Add a sentence of text.

  $doc->add_text('this is example text to display');

=cut

sub add_text {
        my $self = shift;
        my $text = shift;
        return unless defined($text);

        push @{ $self->{dtexts} }, $self->_s($text);
}


=head2 add_hidden_text

Add a hidden sentence.

  $doc->add_hidden_text('this is example text just for search');

=cut

sub add_hidden_text {
        my $self = shift;
        my $text = shift;
        return unless defined($text);

        push @{ $self->{htexts} }, $self->_s($text);
}


=head2 id

Get the ID number of document. If the object has never been registred, C<-1> is returned.

  print $doc->id;

=cut

sub id {
        my $self = shift;
        return $self->{id};
}


=head2 attr_names

Returns array with attribute names from document object.

  my @attrs = $doc->attr_names;

=cut

sub attr_names {
        my $self = shift;
        croak "attr_names return array, not scalar" if (! wantarray);
        return sort keys %{ $self->{attrs} };
}


=head2 attr

Returns value of an attribute.

  my $value = $doc->attr( 'attribute' );

=cut

sub attr {
        my $self = shift;
        my $name = shift;

        return $self->{'attrs'}->{ $name };
}


=head2 texts

Returns array with text sentences.

  my @texts = $doc->texts;

=cut

sub texts {
        my $self = shift;
        confess "texts return array, not scalar" if (! wantarray);
        return @{ $self->{dtexts} };
}


=head2 cat_texts

Return whole text as single scalar.

 my $text = $doc->cat_texts;

=cut

sub cat_texts {
        my $self = shift;
        return join(' ',@{ $self->{dtexts} });
}


=head2 dump_draft

Dump draft data from document object.

  print $doc->dump_draft;

=cut

sub dump_draft {
        my $self = shift;
        my $draft;

        foreach my $attr_name (sort keys %{ $self->{attrs} }) {
                $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";
        }

        if ($self->{kwords}) {
                $draft .= '%%VECTOR';
                while (my ($key, $value) = each %{ $self->{kwords} }) {
                        $draft .= "\t$key\t$value";
                }
                $draft .= "\n";
        }

        $draft .= "\n";

        $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
        $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});

        return $draft;
}


=head2 delete

Empty document object

  $doc->delete;

This function is addition to original Ruby API, and since it was included in C wrappers it's here as a
convinience. Document objects which go out of scope will be destroyed
automatically.

=cut

sub delete {
        my $self = shift;

        foreach my $data (qw/attrs dtexts stexts kwords/) {
                delete($self->{$data});
        }

        $self->{id} = -1;

        return 1;
}


package Search::Estraier::Condition;

use Carp qw/confess croak/;

use Search::Estraier;
our @ISA = qw/Search::Estraier/;

=head1 Search::Estraier::Condition

=head2 new

  my $cond = new Search::HyperEstraier::Condition;

=cut

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

        $self->{max} = -1;
        $self->{options} = 0;

        $self ? return $self : return undef;
}


=head2 set_phrase

  $cond->set_phrase('search phrase');

=cut

sub set_phrase {
        my $self = shift;
        $self->{phrase} = $self->_s( shift );
}


=head2 add_attr

  $cond->add_attr('@URI STRINC /~dpavlin/');

=cut

sub add_attr {
        my $self = shift;
        my $attr = shift || return;
        push @{ $self->{attrs} }, $self->_s( $attr );
}


=head2 set_order

  $cond->set_order('@mdate NUMD');

=cut

sub set_order {
        my $self = shift;
        $self->{order} = shift;
}


=head2 set_max

  $cond->set_max(42);

=cut

sub set_max {
        my $self = shift;
        my $max = shift;
        croak "set_max needs number, not '$max'" unless ($max =~ m/^\d+$/);
        $self->{max} = $max;
}


=head2 set_options

  $cond->set_options( SURE => 1 );

=cut

my $options = {
        # check N-gram keys skipping by three
        SURE => 1 << 0,
        # check N-gram keys skipping by two
        USUAL => 1 << 1,
        # without TF-IDF tuning
        FAST => 1 << 2,
        # with the simplified phrase
        AGITO => 1 << 3,
        # check every N-gram key
        NOIDF => 1 << 4,
        # check N-gram keys skipping by one
        SIMPLE => 1 << 10,
};

sub set_options {
        my $self = shift;
        my $option = shift;
        confess "unknown option" unless ($options->{$option});
        $self->{options} ||= $options->{$option};
}


=head2 phrase

Return search phrase.

  print $cond->phrase;

=cut

sub phrase {
        my $self = shift;
        return $self->{phrase};
}


=head2 order

Return search result order.

  print $cond->order;

=cut

sub order {
        my $self = shift;
        return $self->{order};
}


=head2 attrs

Return search result attrs.

  my @cond_attrs = $cond->attrs;

=cut

sub attrs {
        my $self = shift;
        #croak "attrs return array, not scalar" if (! wantarray);
        return @{ $self->{attrs} };
}


=head2 max

Return maximum number of results.

  print $cond->max;

C<-1> is returned for unitialized value, C<0> is unlimited.

=cut

sub max {
        my $self = shift;
        return $self->{max};
}


=head2 options

Return options for this condition.

  print $cond->options;

Options are returned in numerical form.

=cut

sub options {
        my $self = shift;
        return $self->{options};
}


package Search::Estraier::ResultDocument;

use Carp qw/croak/;

#use Search::Estraier;
#our @ISA = qw/Search::Estraier/;

=head1 Search::Estraier::ResultDocument

=head2 new

  my $rdoc = new Search::HyperEstraier::ResultDocument(
        uri => 'http://localhost/document/uri/42',
        attrs => {
                foo => 1,
                bar => 2,
        },
        snippet => 'this is a text of snippet'
        keywords => 'this\tare\tkeywords'
  );

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        foreach my $f (qw/uri attrs snippet keywords/) {
                croak "missing $f for ResultDocument" unless defined($self->{$f});
        }

        $self ? return $self : return undef;
}


=head2 uri

Return URI of result document

  print $rdoc->uri;

=cut

sub uri {
        my $self = shift;
        return $self->{uri};
}


=head2 attr_names

Returns array with attribute names from result document object.

  my @attrs = $rdoc->attr_names;

=cut

sub attr_names {
        my $self = shift;
        croak "attr_names return array, not scalar" if (! wantarray);
        return sort keys %{ $self->{attrs} };
}


=head2 attr

Returns value of an attribute.

  my $value = $rdoc->attr( 'attribute' );

=cut

sub attr {
        my $self = shift;
        my $name = shift || return;
        return $self->{attrs}->{ $name };
}


=head2 snippet

Return snippet from result document

  print $rdoc->snippet;

=cut

sub snippet {
        my $self = shift;
        return $self->{snippet};
}


=head2 keywords

Return keywords from result document

  print $rdoc->keywords;

=cut

sub keywords {
        my $self = shift;
        return $self->{keywords};
}


package Search::Estraier::NodeResult;

use Carp qw/croak/;

#use Search::Estraier;
#our @ISA = qw/Search::Estraier/;

=head1 Search::Estraier::NodeResult

=head2 new

  my $res = new Search::HyperEstraier::NodeResult(
        docs => @array_of_rdocs,
        hits => %hash_with_hints,
  );

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        foreach my $f (qw/docs hints/) {
                croak "missing $f for ResultDocument" unless defined($self->{$f});
        }

        $self ? return $self : return undef;
}


=head2 doc_num

Return number of documents

  print $res->doc_num;

=cut

sub doc_num {
        my $self = shift;
        return $#{$self->{docs}};
}


=head2 get_doc

Return single document

  my $doc = $res->get_doc( 42 );

Returns undef if document doesn't exist.

=cut

sub get_doc {
        my $self = shift;
        my $num = shift;
        croak "expect number as argument, not '$num'" unless ($num =~ m/^\d+$/);
        return undef if ($num < 0 || $num > $self->{docs});
        return $self->{docs}->[$num];
}


=head2 hint

Return specific hint from results.

  print $rec->hint( 'VERSION' );

Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
C<TIME>, C<LINK#n>, C<VIEW>.

=cut

sub hint {
        my $self = shift;
        my $key = shift || return;
        return $self->{hints}->{$key};
}


package Search::Estraier::Node;

use Carp qw/carp croak confess/;
use URI;
use MIME::Base64;
use IO::Socket::INET;

=head1 Search::Estraier::Node

=head2 new

  my $node = new Search::HyperEstraier::Node;

=cut

sub new {
        my $class = shift;
        my $self = {
                pxport => -1,
                timeout => 0,   # this used to be -1
                dnum => -1,
                wnum => -1,
                size => -1.0,
                wwidth => 480,
                hwidth => 96,
                awidth => 96,
                status => -1,
        };
        bless($self, $class);

        if (@_) {
                $self->{debug} = shift;
                warn "## Node debug on\n";
        }

        $self ? return $self : return undef;
}


=head2 set_url

Specify URL to node server

  $node->set_url('http://localhost:1978');

=cut

sub set_url {
        my $self = shift;
        $self->{url} = shift;
}


=head2 set_proxy

Specify proxy server to connect to node server

  $node->set_proxy('proxy.example.com', 8080);

=cut

sub set_proxy {
        my $self = shift;
        my ($host,$port) = @_;
        croak "proxy port must be number, not '$port'" unless ($port =~ m/^\d+$/);
        $self->{pxhost} = $host;
        $self->{pxport} = $port;
}


=head2 set_timeout

Specify timeout of connection in seconds

  $node->set_timeout( 15 );

=cut

sub set_timeout {
        my $self = shift;
        my $sec = shift;
        croak "timeout must be number, not '$sec'" unless ($sec =~ m/^\d+$/);
        $self->{timeout} = $sec;
}


=head2 set_auth

Specify name and password for authentication to node server.

  $node->set_auth('clint','eastwood');

=cut

sub set_auth {
        my $self = shift;
        my ($login,$passwd) = @_;
        my $basic_auth = encode_base64( "$login:$passwd" );
        chomp($basic_auth);
        $self->{auth} = $basic_auth;
}


=head2 status

Return status code of last request.

  print $node->status;

C<-1> means connection failure.

=cut

sub status {
        my $self = shift;
        return $self->{status};
}


=head2 put_doc

Add a document

  $node->put_doc( $document_draft ) or die "can't add document";

Return true on success or false on failture.

=cut

sub put_doc {
        my $self = shift;
        my $doc = shift || return;
        return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
        $self->shuttle_url( $self->{url} . '/put_doc',
                'text/x-estraier-draft',
                $doc->dump_draft,
                undef
        ) == 200;
}


=head2 out_doc

Remove a document

  $node->out_doc( document_id ) or "can't remove document";

Return true on success or false on failture.

=cut

sub out_doc {
        my $self = shift;
        my $id = shift || return;
        return unless ($self->{url});
        croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
        $self->shuttle_url( $self->{url} . '/out_doc',
                'application/x-www-form-urlencoded',
                "id=$id",
                undef
        ) == 200;
}


=head2 out_doc_by_uri

Remove a registrated document using it's uri

  $node->out_doc_by_uri( 'file:///document/uri/42' ) or "can't remove document";

Return true on success or false on failture.

=cut

sub out_doc_by_uri {
        my $self = shift;
        my $uri = shift || return;
        return unless ($self->{url});
        $self->shuttle_url( $self->{url} . '/out_doc',
                'application/x-www-form-urlencoded',
                "uri=$uri",
                undef
        ) == 200;
}


=head2 edit_doc

Edit attributes of a document

  $node->edit_doc( $document_draft ) or die "can't edit document";

Return true on success or false on failture.

=cut

sub edit_doc {
        my $self = shift;
        my $doc = shift || return;
        return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
        $self->shuttle_url( $self->{url} . '/edit_doc',
                'text/x-estraier-draft',
                $doc->dump_draft,
                undef
        ) == 200;
}


=head2 get_doc

Retreive document

  my $doc = $node->get_doc( document_id ) or die "can't get document";

Return true on success or false on failture.

=cut

sub get_doc {
        my $self = shift;
        my $id = shift || return;
        return $self->_fetch_doc( id => $id );
}


=head2 get_doc_by_uri

Retreive document

  my $doc = $node->get_doc_by_uri( 'file:///document/uri/42' ) or die "can't get document";

Return true on success or false on failture.

=cut

sub get_doc_by_uri {
        my $self = shift;
        my $uri = shift || return;
        return $self->_fetch_doc( uri => $uri );
}


=head2 etch_doc

Exctract document keywords

  my $keywords = $node->etch_doc( document_id ) or die "can't etch document";

=cut

sub erch_doc {
        my $self = shift;
        my $id = shift || return;
        return $self->_fetch_doc( id => $id, etch => 1 );
}

=head2 etch_doc_by_uri

Retreive document

  my $keywords = $node->etch_doc_by_uri( 'file:///document/uri/42' ) or die "can't etch document";

Return true on success or false on failture.

=cut

sub etch_doc_by_uri {
        my $self = shift;
        my $uri = shift || return;
        return $self->_fetch_doc( uri => $uri, etch => 1 );
}


=head2 uri_to_id

Get ID of document specified by URI

  my $id = $node->uri_to_id( 'file:///document/uri/42' );

=cut

sub uri_to_id {
        my $self = shift;
        my $uri = shift || return;
        return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1 );
}


=head2 _fetch_doc

Private function used for implementing of C<get_doc>, C<get_doc_by_uri>,
C<etch_doc>, C<etch_doc_by_uri>.

 # this will decode received draft into Search::Estraier::Document object
 my $doc = $node->_fetch_doc( id => 42 );
 my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42' );

 # to extract keywords, add etch
 my $doc = $node->_fetch_doc( id => 42, etch => 1 );
 my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );

 # more general form which allows implementation of
 # uri_to_id
 my $id = $node->_fetch_doc(
        uri => 'file:///document/uri/42',
        path => '/uri_to_id',
        chomp_resbody => 1
 );

=cut

sub _fetch_doc {
        my $self = shift;
        my $a = {@_};
        return unless ( ($a->{id} || $a->{uri}) && $self->{url} );

        my ($arg, $resbody);

        my $path = $a->{path} || '/get_doc';
        $path = '/etch_doc' if ($a->{etch});

        if ($a->{id}) {
                croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
                $arg = 'id=' . $a->{id};
        } elsif ($a->{uri}) {
                $arg = 'uri=' . $a->{uri};
        } else {
                confess "unhandled argument. Need id or uri.";
        }

        my $rv = $self->shuttle_url( $self->{url} . $path,
                'application/x-www-form-urlencoded',
                $arg,
                \$resbody,
        );

        return if ($rv != 200);

        if ($a->{etch}) {
                $self->{kwords} = {};
                return +{} unless ($resbody);
                foreach my $l (split(/\n/, $resbody)) {
                        my ($k,$v) = split(/\t/, $l, 2);
                        $self->{kwords}->{$k} = $v if ($v);
                }
                return $self->{kwords};
        } elsif ($a->{chomp_resbody}) {
                return unless (defined($resbody));
                chomp($resbody);
                return $resbody;
        } else {
                return new Search::Estraier::Document($resbody);
        }
}


=head2 name

  my $node_name = $node->name;

=cut

sub name {
        my $self = shift;
        $self->set_info unless ($self->{name});
        return $self->{name};
}


=head2 label

  my $node_label = $node->label;

=cut

sub label {
        my $self = shift;
        $self->set_info unless ($self->{label});
        return $self->{label};
}


=head2 doc_num

  my $documents_in_node = $node->doc_num;

=cut

sub doc_num {
        my $self = shift;
        $self->set_info if ($self->{dnum} < 0);
        return $self->{dnum};
}


=head2 word_num

  my $words_in_node = $node->word_num;

=cut

sub word_num {
        my $self = shift;
        $self->set_info if ($self->{wnum} < 0);
        return $self->{wnum};
}


=head2 size

  my $node_size = $node->size;

=cut

sub size {
        my $self = shift;
        $self->set_info if ($self->{size} < 0);
        return $self->{size};
}


=head2 shuttle_url

This is method which uses C<IO::Socket::INET> to communicate with Hyper Estraier node
master.

  my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );

C<$resheads> and C<$resbody> booleans controll if response headers and/or response
body will be saved within object.

=cut

sub shuttle_url {
        my $self = shift;

        my ($url, $content_type, $reqbody, $resbody) = @_;

        $self->{status} = -1;

        warn "## $url\n" if ($self->{debug});

        $url = new URI($url);
        if (
                        !$url || !$url->scheme || !$url->scheme eq 'http' ||
                        !$url->host || !$url->port || $url->port < 1
                ) {
                carp "can't parse $url\n";
                return -1;
        }

        my ($host,$port,$query) = ($url->host, $url->port, $url->path);

        if ($self->{pxhost}) {
                ($host,$port) = ($self->{pxhost}, $self->{pxport});
                $query = "http://$host:$port/$query";
        }

        $query .= '?' . $url->query if ($url->query && ! $reqbody);

        my $headers;

        if ($reqbody) {
                $headers .= "POST $query HTTP/1.0\r\n";
        } else {
                $headers .= "GET $query HTTP/1.0\r\n";
        }

        $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";
        $headers .= "Connection: close\r\n";
        $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";
        $headers .= "Content-Type: $content_type\r\n";
        $headers .= "Authorization: Basic $self->{auth}\r\n";
        my $len = 0;
        {
                use bytes;
                $len = length($reqbody) if ($reqbody);
        }
        $headers .= "Content-Length: $len\r\n";
        $headers .= "\r\n";

        my $sock = IO::Socket::INET->new(
                PeerAddr        => $host,
                PeerPort        => $port,
                Proto           => 'tcp',
                Timeout         => $self->{timeout} || 90,
        );

        if (! $sock) {
                carp "can't open socket to $host:$port";
                return -1;
        }

        warn $headers if ($self->{debug});

        print $sock $headers or
                carp "can't send headers to network:\n$headers\n" and return -1;

        if ($reqbody) {
                warn "$reqbody\n" if ($self->{debug});
                print $sock $reqbody or
                        carp "can't send request body to network:\n$$reqbody\n" and return -1;
        }

        my $line = <$sock>;
        chomp($line);
        my ($schema, $res_status, undef) = split(/  */, $line, 3);
        return if ($schema !~ /^HTTP/ || ! $res_status);

        $self->{status} = $res_status;
        warn "## response status: $res_status\n" if ($self->{debug});

        # skip rest of headers
        $line = <$sock>;
        while ($line) {
                $line = <$sock>;
                $line =~ s/[\r\n]+$//;
                warn "## ", $line || 'NULL', " ##\n" if ($self->{debug});
        };

        # read body
        $len = 0;
        do {
                $len = read($sock, my $buf, 8192);
                $$resbody .= $buf if ($resbody);
        } while ($len);

        warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});

        return $self->{status};
}


=head2 set_info

Set information for node

  $node->set_info;

=cut

sub set_info {
        my $self = shift;

        $self->{status} = -1;
        return unless ($self->{url});

        my $resbody;
        my $rv = $self->shuttle_url( $self->{url} . '/inform',
                'text/plain',
                undef,
                \$resbody,
        );

        return if ($rv != 200 || !$resbody);

        chomp($resbody);

        ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
                split(/\t/, $resbody, 5);

}

###

=head1 EXPORT

Nothing.

=head1 SEE ALSO

L<http://hyperestraier.sourceforge.net/>

Hyper Estraier Ruby interface on which this module is based.

=head1 AUTHOR

Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005-2006 by Dobrica Pavlinusic

This library is free software; you can redistribute it and/or modify
it under the GPL v2 or later.

=cut

1;