/[Search-Estraier]/trunk/Estraier.pm

This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!

Diff of /trunk/Estraier.pm

Parent Directory | Revision Log | View Patch Patch

-revision 2 by dpavlin,
Wed Jan  4 13:11:43 2006 UTC
+revision 39 by dpavlin,
Thu Jan  5 22:36:10 2006 UTC
 Line 4 
 use 5.008;
  use strict;
  use warnings;
- require Exporter;
- our @ISA = qw(Exporter);
- our %EXPORT_TAGS = ( 'all' => [ qw(
- ) ] );
- our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
- our @EXPORT = qw(
- );
  our $VERSION = '0.00';
- use Carp;
  =head1 NAME
  Search::Estraier - pure perl module to use Hyper Estraier search engine
-Line 41 
 implementation. It also includes methods
+Line 27 
 implementation. It also includes methods
  =cut
+ =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
- Document for HyperEstraier
+ 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 = {@_};
+         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 {
-Line 72 
 sub add_attr {
+Line 131 
 sub add_attr {
          my $attrs = {@_};
          while (my ($name, $value) = each %{ $attrs }) {
-                 $name =~ s/\s\s+/ /gs;
+                 if (! defined($value)) {
-                 $value =~ s/\s\s+/ /gs;
+                         delete( $self->{attrs}->{ $self->_s($name) } );
-                 push @{$self->{$name}}, $value;
+                 } 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
- package Search::Estraier::Master;
+ sub cat_texts {
+         my $self = shift;
+         return join(' ',@{ $self->{dtexts} });
+ }
- use Carp;
+ =head2 dump_draft
- =head1 Search::Estraier::Master
+ Dump draft data from document object.
- Controll node master. This requires user with administration priviledges.
+   print $doc->dump_draft;
  =cut
- {
+ sub dump_draft {
-         package RequestAgent;
+         my $self = shift;
-         @ISA = qw(LWP::UserAgent);
+         my $draft;
-         sub new {
+         foreach my $attr_name (sort keys %{ $self->{attrs} }) {
-                 my $self = LWP::UserAgent::new(@_);
+                 $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";
-                 $self->agent("Search-Estraier/$Search::Estraer::VERSION");
-                 $self;
          }
-         sub get_basic_credentials {
+         if ($self->{kwords}) {
-                 my($self, $realm, $uri) = @_;
+                 $draft .= '%%VECTOR';
- #               return ($user, $password);
+                 while (my ($key, $value) = each %{ $self->{kwords} }) {
+                         $draft .= "\t$key\t$value";
+                 }
+                 $draft .= "\n";
          }
+         $draft .= "\n";
+         $draft .= join("\n", @{ $self->{dtexts} }) . "\n";
+         $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";
+         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" 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
- Create new connection to node master.
+   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' );
-   my $master = new Search::Estraier::Master(
+ =cut
-         url => 'http://localhost:1978',
-         user => 'admin',
+ sub attr {
-         passwd => 'admin',
+         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
-Line 125 
 sub new {
+Line 603 
 sub new {
          my $self = {@_};
          bless($self, $class);
-         foreach my $p (qw/url user passwd/) {
+         foreach my $f (qw/docs hints/) {
-                 croak "need $p" unless ($self->{$p});
+                 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" 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/;
+ 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} = 1;
+                 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" 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" 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) = @_;
+         $self->{auth} = encode_base64( "$login:$passwd" );
+ }
+ =head2 status
+ Return status code of last request.
+   print $res->status;
+ C<-1> means connection failure.
+ =cut
+ sub status {
+         my $self = shift;
+         return $self->{status};
+ }
+ =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) = @_;
+         my $status = -1;
+         warn "## $url\n";
+         $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:\n$headers\n" if ($self->{debug});
+         print $sock $headers or
+                 carp "can't send headers to network:\n$headers\n" and return -1;
+         if ($reqbody) {
+                 warn "## request body:\n$headers\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);
+         $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";
+         };
+         # read body
+         $len = 0;
+         do {
+                 $len = read($sock, my $buf, 8192);
+                 $$resbody .= $buf if ($resbody);
+         } while ($len);
+         warn "## response body:\n$$resbody\n" if ($self->{debug});
+         return $status;
+ }
  ###
-Line 153 
 Dobrica Pavlinusic, E<lt>dpavlin@rot13.o
+Line 901 
 Dobrica Pavlinusic, E<lt>dpavlin@rot13.o
  =head1 COPYRIGHT AND LICENSE
- Copyright (C) 2005 by Dobrica Pavlinusic
+ 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.

 Legend:



Removed from v.2
 


changed lines


 
Added in v.39
 Legend:



Removed from v.2
 


changed lines


 
Added in v.39
-Removed from v.2
+Added in v.39

	ViewVC Help
Powered by ViewVC 1.1.26