/[Search-Estraier]/trunk/lib/Search/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/lib/Search/Estraier.pm

Parent Directory | Revision Log | View Patch Patch

-revision 47 by dpavlin,
Fri Jan  6 01:51:28 2006 UTC
+revision 166 by dpavlin,
Sun Aug  6 12:48:02 2006 UTC
 Line 4 
 use 5.008;
  use strict;
  use warnings;
- our $VERSION = '0.00';
+ our $VERSION = '0.07_3';
  =head1 NAME
 Line 12 
 Search::Estraier - pure perl module to u
  =head1 SYNOPSIS
-   use Search::Estraier;
+ =head2 Simple indexer
-   my $est = new Search::Estraier();
+         use Search::Estraier;
+         # create and configure node
+         my $node = new Search::Estraier::Node(
+                 url => 'http://localhost:1978/node/test',
+                 user => 'admin',
+                 passwd => 'admin',
+                 create => 1,
+                 label => 'Label for node',
+                 croak_on_error => 1,
+         );
+         # create document
+         my $doc = new Search::Estraier::Document;
+         # add attributes
+         $doc->add_attr('@uri', "http://estraier.gov/example.txt");
+         $doc->add_attr('@title', "Over the Rainbow");
+         # add body text to document
+         $doc->add_text("Somewhere over the rainbow.  Way up high.");
+         $doc->add_text("There's a land that I heard of once in a lullaby.");
+         die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
+ =head2 Simple searcher
+         use Search::Estraier;
+         # create and configure node
+         my $node = new Search::Estraier::Node(
+                 url => 'http://localhost:1978/node/test',
+                 user => 'admin',
+                 passwd => 'admin',
+                 croak_on_error => 1,
+         );
+         # create condition
+         my $cond = new Search::Estraier::Condition;
+         # set search phrase
+         $cond->set_phrase("rainbow AND lullaby");
+         my $nres = $node->search($cond, 0);
+         if (defined($nres)) {
+                 print "Got ", $nres->hits, " results\n";
+                 # for each document in results
+                 for my $i ( 0 ... $nres->doc_num - 1 ) {
+                         # get result document
+                         my $rdoc = $nres->get_doc($i);
+                         # display attribte
+                         print "URI: ", $rdoc->attr('@uri'),"\n";
+                         print "Title: ", $rdoc->attr('@title'),"\n";
+                         print $rdoc->snippet,"\n";
+                 }
+         } else {
+                 die "error: ", $node->status,"\n";
+         }
  =head1 DESCRIPTION
-Line 25 
 or Hyper Estraier development files on t
+Line 85 
 or Hyper Estraier development files on t
  It is implemented as multiple packages which closly resamble Ruby
  implementation. It also includes methods to manage nodes.
+ There are few examples in C<scripts> directory of this distribution.
  =cut
  =head1 Inheritable common methods
-Line 41 
 Remove multiple whitespaces from string,
+Line 103 
 Remove multiple whitespaces from string,
  =cut
  sub _s {
-         my $text = $_[1] || return;
+         my $text = $_[1];
+         return unless defined($text);
          $text =~ s/\s\s+/ /gs;
          $text =~ s/^\s+//;
          $text =~ s/\s+$//;
-Line 57 
 our @ISA = qw/Search::Estraier/;
+Line 120 
 our @ISA = qw/Search::Estraier/;
  =head1 Search::Estraier::Document
- This class implements Document which is collection of attributes
+ This class implements Document which is single item in Hyper Estraier.
- (key=value), vectors (also key value) display text and hidden text.
+ It's is collection of:
+ =over 4
+ =item attributes
+ C<< 'key' => 'value' >> pairs which can later be used for filtering of results
+ You can add common filters to C<attrindex> in estmaster's C<_conf>
+ file for better performance. See C<attrindex> in
+ L<Hyper Estraier P2P Guide|http://hyperestraier.sourceforge.net/nguide-en.html>.
+ =item vectors
+ also C<< 'key' => 'value' >> pairs
+ =item display text
+ Text which will be used to create searchable corpus of your index and
+ included in snippet output.
+ =item hidden text
+ Text which will be searchable, but will not be included in snippet.
+ =back
  =head2 new
-Line 94 
 sub new {
+Line 182 
 sub new {
                          if ($line =~ m/^%VECTOR\t(.+)$/) {
                                  my @fields = split(/\t/, $1);
-                                 for my $i ( 0 .. ($#fields - 1) ) {
+                                 if ($#fields % 2 == 1) {
-                                         $self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];
+                                         $self->{kwords} = { @fields };
-                                         $i++;
+                                 } else {
+                                         warn "can't decode $line\n";
                                  }
                                  next;
                          } elsif ($line =~ m/^%/) {
-Line 106 
 sub new {
+Line 195 
 sub new {
                          } elsif ($line =~ m/^$/) {
                                  $in_text = 1;
                                  next;
-                         } elsif ($line =~ m/^(.+)=(.+)$/) {
+                         } elsif ($line =~ m/^(.+)=(.*)$/) {
                                  $self->{attrs}->{ $1 } = $2;
                                  next;
                          }
-                         warn "draft ignored: $line\n";
+                         warn "draft ignored: '$line'\n";
                  }
          }
-Line 180 
 sub add_hidden_text {
+Line 269 
 sub add_hidden_text {
          push @{ $self->{htexts} }, $self->_s($text);
  }
+ =head2 add_vectors
+ Add a vectors
+   $doc->add_vector(
+         'vector_name' => 42,
+         'another' => 12345,
+   );
+ =cut
+ sub add_vectors {
+         my $self = shift;
+         return unless (@_);
+         # this is ugly, but works
+         die "add_vector needs HASH as argument" unless ($#_ % 2 == 1);
+         $self->{kwords} = {@_};
+ }
  =head2 id
-Line 205 
 Returns array with attribute names from
+Line 315 
 Returns array with attribute names from
  sub attr_names {
          my $self = shift;
-         croak "attr_names return array, not scalar" if (! wantarray);
+         return unless ($self->{attrs});
+         #croak "attr_names return array, not scalar" if (! wantarray);
          return sort keys %{ $self->{attrs} };
  }
-Line 221 
 Returns value of an attribute.
+Line 332 
 Returns value of an attribute.
  sub attr {
          my $self = shift;
          my $name = shift;
+         return unless (defined($name) && $self->{attrs});
-         return $self->{'attrs'}->{ $name };
+         return $self->{attrs}->{ $name };
  }
-Line 236 
 Returns array with text sentences.
+Line 347 
 Returns array with text sentences.
  sub texts {
          my $self = shift;
-         confess "texts return array, not scalar" if (! wantarray);
+         #confess "texts return array, not scalar" if (! wantarray);
-         return @{ $self->{dtexts} };
+         return @{ $self->{dtexts} } if ($self->{dtexts});
  }
-Line 251 
 Return whole text as single scalar.
+Line 362 
 Return whole text as single scalar.
  sub cat_texts {
          my $self = shift;
-         return join(' ',@{ $self->{dtexts} });
+         return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
  }
-Line 268 
 sub dump_draft {
+Line 379 
 sub dump_draft {
          my $draft;
          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
-                 $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";
+                 next unless defined(my $v = $self->{attrs}->{$attr_name});
+                 $draft .= $attr_name . '=' . $v . "\n";
          }
          if ($self->{kwords}) {
-                 $draft .= '%%VECTOR';
+                 $draft .= '%VECTOR';
                  while (my ($key, $value) = each %{ $self->{kwords} }) {
                          $draft .= "\t$key\t$value";
                  }
-Line 316 
 sub delete {
+Line 428 
 sub delete {
  package Search::Estraier::Condition;
- use Carp qw/confess croak/;
+ use Carp qw/carp confess croak/;
  use Search::Estraier;
  our @ISA = qw/Search::Estraier/;
-Line 394 
 sub set_max {
+Line 506 
 sub set_max {
  =head2 set_options
-   $cond->set_options( SURE => 1 );
+   $cond->set_options( 'SURE' );
+   $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
+ Possible options are:
+ =over 8
+ =item SURE
+ check every N-gram
+ =item USUAL
+ check every second N-gram
+ =item FAST
+ check every third N-gram
+ =item AGITO
+ check every fourth N-gram
+ =item NOIDF
+ don't perform TF-IDF tuning
+ =item SIMPLE
+ use simplified query phrase
+ =back
+ Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
+ options;
+ This option changed in version C<0.04> of this module. It's backwards compatibile.
  =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;
+         my $opt = 0;
-         confess "unknown option" unless ($options->{$option});
+         foreach my $option (@_) {
-         $self->{options} ||= $options->{$option};
+                 my $mask;
+                 unless ($mask = $options->{$option}) {
+                         if ($option eq '1') {
+                                 next;
+                         } else {
+                                 croak "unknown option $option";
+                         }
+                 }
+                 $opt += $mask;
+         }
+         $self->{options} = $opt;
  }
-Line 460 
 Return search result attrs.
+Line 613 
 Return search result attrs.
  sub attrs {
          my $self = shift;
          #croak "attrs return array, not scalar" if (! wantarray);
-         return @{ $self->{attrs} };
+         return @{ $self->{attrs} } if ($self->{attrs});
  }
-Line 496 
 sub options {
+Line 649 
 sub options {
  }
+ =head2 set_skip
+ Set number of skipped documents from beginning of results
+   $cond->set_skip(42);
+ Similar to C<offset> in RDBMS.
+ =cut
+ sub set_skip {
+         my $self = shift;
+         $self->{skip} = shift;
+ }
+ =head2 skip
+ Return skip for this condition.
+   print $cond->skip;
+ =cut
+ sub skip {
+         my $self = shift;
+         return $self->{skip};
+ }
  package Search::Estraier::ResultDocument;
  use Carp qw/croak/;
-Line 524 
 sub new {
+Line 706 
 sub new {
          my $self = {@_};
          bless($self, $class);
-         foreach my $f (qw/uri attrs snippet keywords/) {
+         croak "missing uri for ResultDocument" unless defined($self->{uri});
-                 croak "missing $f for ResultDocument" unless defined($self->{$f});
-         }
          $self ? return $self : return undef;
  }
-Line 641 
 Return number of documents
+Line 821 
 Return number of documents
    print $res->doc_num;
+ This will return real number of documents (limited by C<max>).
+ If you want to get total number of hits, see C<hits>.
  =cut
  sub doc_num {
          my $self = shift;
-         return $#{$self->{docs}};
+         return $#{$self->{docs}} + 1;
  }
-Line 672 
 sub get_doc {
+Line 855 
 sub get_doc {
  Return specific hint from results.
-   print $rec->hint( 'VERSION' );
+   print $res->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>.
-Line 685 
 sub hint {
+Line 868 
 sub hint {
          return $self->{hints}->{$key};
  }
+ =head2 hints
+ More perlish version of C<hint>. This one returns hash.
+   my %hints = $res->hints;
+ =cut
+ sub hints {
+         my $self = shift;
+         return $self->{hints};
+ }
+ =head2 hits
+ Syntaxtic sugar for total number of hits for this query
+   print $res->hits;
+ It's same as
+   print $res->hint('HIT');
+ but shorter.
+ =cut
+ sub hits {
+         my $self = shift;
+         return $self->{hints}->{'HIT'} || 0;
+ }
  package Search::Estraier::Node;
-Line 692 
 use Carp qw/carp croak confess/;
+Line 906 
 use Carp qw/carp croak confess/;
  use URI;
  use MIME::Base64;
  use IO::Socket::INET;
+ use URI::Escape qw/uri_escape/;
  =head1 Search::Estraier::Node
-Line 699 
 use IO::Socket::INET;
+Line 914 
 use IO::Socket::INET;
    my $node = new Search::HyperEstraier::Node;
+ or optionally with C<url> as parametar
+   my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
+ or in more verbose form
+   my $node = new Search::HyperEstraier::Node(
+         url => 'http://localhost:1978/node/test',
+         user => 'admin',
+         passwd => 'admin'
+         create => 1,
+         label => 'optional node label',
+         debug => 1,
+         croak_on_error => 1
+   );
+ with following arguments:
+ =over 4
+ =item url
+ URL to node
+ =item user
+ specify username for node server authentication
+ =item passwd
+ password for authentication
+ =item create
+ create node if it doesn't exists
+ =item label
+ optional label for new node if C<create> is used
+ =item debug
+ dumps a B<lot> of debugging output
+ =item croak_on_error
+ very helpful during development. It will croak on all errors instead of
+ silently returning C<-1> (which is convention of Hyper Estraier API in other
+ languages).
+ =back
  =cut
  sub new {
-Line 706 
 sub new {
+Line 973 
 sub new {
          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 (@_) {
+         if ($#_ == 0) {
-                 $self->{debug} = shift;
+                 $self->{url} = shift;
-                 warn "## Node debug on\n";
+         } else {
+                 %$self = ( %$self, @_ );
+                 $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
+                 warn "## Node debug on\n" if ($self->{debug});
+         }
+         $self->{inform} = {
+                 dnum => -1,
+                 wnum => -1,
+                 size => -1.0,
+         };
+         if ($self->{create}) {
+                 if (! eval { $self->name } || $@) {
+                         my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
+                         croak "can't find node name in '$self->{url}'" unless ($name);
+                         my $label = $self->{label} || $name;
+                         $self->master(
+                                 action => 'nodeadd',
+                                 name => $name,
+                                 label => $label,
+                         ) || croak "can't create node $name ($label)";
+                 }
          }
          $self ? return $self : return undef;
-Line 811 
 Add a document
+Line 1100 
 Add a document
    $node->put_doc( $document_draft ) or die "can't add document";
- Return true on success or false on failture.
+ Return true on success or false on failure.
  =cut
-Line 819 
 sub put_doc {
+Line 1108 
 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',
+         if ($self->shuttle_url( $self->{url} . '/put_doc',
                  'text/x-estraier-draft',
                  $doc->dump_draft,
                  undef
-         ) == 200;
+         ) == 200) {
+                 $self->_clear_info;
+                 return 1;
+         }
+         return undef;
  }
-Line 842 
 sub out_doc {
+Line 1135 
 sub out_doc {
          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',
+         if ($self->shuttle_url( $self->{url} . '/out_doc',
                  'application/x-www-form-urlencoded',
                  "id=$id",
                  undef
-         ) == 200;
+         ) == 200) {
+                 $self->_clear_info;
+                 return 1;
+         }
+         return undef;
  }
-Line 864 
 sub out_doc_by_uri {
+Line 1161 
 sub out_doc_by_uri {
          my $self = shift;
          my $uri = shift || return;
          return unless ($self->{url});
-         $self->shuttle_url( $self->{url} . '/out_doc',
+         if ($self->shuttle_url( $self->{url} . '/out_doc',
                  'application/x-www-form-urlencoded',
-                 "uri=$uri",
+                 "uri=" . uri_escape($uri),
                  undef
-         ) == 200;
+         ) == 200) {
+                 $self->_clear_info;
+                 return 1;
+         }
+         return undef;
  }
-Line 886 
 sub edit_doc {
+Line 1187 
 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',
+         if ($self->shuttle_url( $self->{url} . '/edit_doc',
                  'text/x-estraier-draft',
                  $doc->dump_draft,
                  undef
-         ) == 200;
+         ) == 200) {
+                 $self->_clear_info;
+                 return 1;
+         }
+         return undef;
  }
-Line 928 
 sub get_doc_by_uri {
+Line 1233 
 sub get_doc_by_uri {
  }
+ =head2 get_doc_attr
+ Retrieve the value of an atribute from object
+   my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
+         die "can't get document attribute";
+ =cut
+ sub get_doc_attr {
+         my $self = shift;
+         my ($id,$name) = @_;
+         return unless ($id && $name);
+         return $self->_fetch_doc( id => $id, attr => $name );
+ }
+ =head2 get_doc_attr_by_uri
+ Retrieve the value of an atribute from object
+   my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
+         die "can't get document attribute";
+ =cut
+ sub get_doc_attr_by_uri {
+         my $self = shift;
+         my ($uri,$name) = @_;
+         return unless ($uri && $name);
+         return $self->_fetch_doc( uri => $uri, attr => $name );
+ }
  =head2 etch_doc
  Exctract document keywords
-Line 936 
 Exctract document keywords
+Line 1275 
 Exctract document keywords
  =cut
- sub erch_doc {
+ sub etch_doc {
          my $self = shift;
          my $id = shift || return;
          return $self->_fetch_doc( id => $id, etch => 1 );
-Line 965 
 Get ID of document specified by URI
+Line 1304 
 Get ID of document specified by URI
    my $id = $node->uri_to_id( 'file:///document/uri/42' );
+ This method won't croak, even if using C<croak_on_error>.
  =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 );
+         return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1, croak_on_error => 0 );
  }
-Line 987 
 C<etch_doc>, C<etch_doc_by_uri>.
+Line 1328 
 C<etch_doc>, C<etch_doc_by_uri>.
   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
+  # to get document attrubute add attr
+  my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
+  my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
   # more general form which allows implementation of
   # uri_to_id
   my $id = $node->_fetch_doc(
-Line 1011 
 sub _fetch_doc {
+Line 1356 
 sub _fetch_doc {
                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
                  $arg = 'id=' . $a->{id};
          } elsif ($a->{uri}) {
-                 $arg = 'uri=' . $a->{uri};
+                 $arg = 'uri=' . uri_escape($a->{uri});
          } else {
                  confess "unhandled argument. Need id or uri.";
          }
+         if ($a->{attr}) {
+                 $path = '/get_doc_attr';
+                 $arg .= '&attr=' . uri_escape($a->{attr});
+                 $a->{chomp_resbody} = 1;
+         }
          my $rv = $self->shuttle_url( $self->{url} . $path,
                  'application/x-www-form-urlencoded',
                  $arg,
                  \$resbody,
+                 $a->{croak_on_error},
          );
          return if ($rv != 200);
-Line 1042 
 sub _fetch_doc {
+Line 1394 
 sub _fetch_doc {
  }
+ =head2 name
+   my $node_name = $node->name;
+ =cut
+ sub name {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{name};
+ }
+ =head2 label
+   my $node_label = $node->label;
+ =cut
+ sub label {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{label});
+         return $self->{inform}->{label};
+ }
+ =head2 doc_num
+   my $documents_in_node = $node->doc_num;
+ =cut
+ sub doc_num {
+         my $self = shift;
+         $self->_set_info if ($self->{inform}->{dnum} < 0);
+         return $self->{inform}->{dnum};
+ }
+ =head2 word_num
+   my $words_in_node = $node->word_num;
+ =cut
+ sub word_num {
+         my $self = shift;
+         $self->_set_info if ($self->{inform}->{wnum} < 0);
+         return $self->{inform}->{wnum};
+ }
+ =head2 size
+   my $node_size = $node->size;
+ =cut
+ sub size {
+         my $self = shift;
+         $self->_set_info if ($self->{inform}->{size} < 0);
+         return $self->{inform}->{size};
+ }
+ =head2 search
+ Search documents which match condition
+   my $nres = $node->search( $cond, $depth );
+ C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
+ depth for meta search.
+ Function results C<Search::Estraier::NodeResult> object.
+ =cut
+ sub search {
+         my $self = shift;
+         my ($cond, $depth) = @_;
+         return unless ($cond && defined($depth) && $self->{url});
+         croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
+         croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
+         my $resbody;
+         my $rv = $self->shuttle_url( $self->{url} . '/search',
+                 'application/x-www-form-urlencoded',
+                 $self->cond_to_query( $cond, $depth ),
+                 \$resbody,
+         );
+         return if ($rv != 200);
+         my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
+         my $hintsText   = splice @records, 0, 2; # starts with empty record
+         my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
+         # process records
+         my $docs = [];
+         foreach my $record (@records)
+         {
+                 # split into keys and snippets
+                 my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
+                 # create document hash
+                 my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
+                 $doc->{'@keywords'}     = $doc->{keywords};
+                 ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
+                 $doc->{snippet}         = $snippet;
+                 push @$docs, new Search::Estraier::ResultDocument(
+                         attrs           => $doc,
+                         uri             => $doc->{'@uri'},
+                         snippet         => $snippet,
+                         keywords        => $doc->{'keywords'},
+                 );
+         }
+         return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
+ }
+ =head2 cond_to_query
+ Return URI encoded string generated from Search::Estraier::Condition
+   my $args = $node->cond_to_query( $cond, $depth );
+ =cut
+ sub cond_to_query {
+         my $self = shift;
+         my $cond = shift || return;
+         croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
+         my $depth = shift;
+         my @args;
+         if (my $phrase = $cond->phrase) {
+                 push @args, 'phrase=' . uri_escape($phrase);
+         }
+         if (my @attrs = $cond->attrs) {
+                 for my $i ( 0 .. $#attrs ) {
+                         push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
+                 }
+         }
+         if (my $order = $cond->order) {
+                 push @args, 'order=' . uri_escape($order);
+         }
+         if (my $max = $cond->max) {
+                 push @args, 'max=' . $max;
+         } else {
+                 push @args, 'max=' . (1 << 30);
+         }
+         if (my $options = $cond->options) {
+                 push @args, 'options=' . $options;
+         }
+         push @args, 'depth=' . $depth if ($depth);
+         push @args, 'wwidth=' . $self->{wwidth};
+         push @args, 'hwidth=' . $self->{hwidth};
+         push @args, 'awidth=' . $self->{awidth};
+         push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
+         return join('&', @args);
+ }
  =head2 shuttle_url
- This is method which uses C<IO::Socket::INET> to communicate with Hyper Estraier node
+ This is method which uses C<LWP::UserAgent> to communicate with Hyper Estraier node
  master.
-   my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );
+   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
+ use LWP::UserAgent;
  sub shuttle_url {
          my $self = shift;
-         my ($url, $content_type, $reqbody, $resbody) = @_;
+         my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
+         $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
          $self->{status} = -1;
-Line 1074 
 sub shuttle_url {
+Line 1602 
 sub shuttle_url {
                  return -1;
          }
-         my ($host,$port,$query) = ($url->host, $url->port, $url->path);
+         my $ua = LWP::UserAgent->new;
+         $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
-         if ($self->{pxhost}) {
+         my $req;
-                 ($host,$port) = ($self->{pxhost}, $self->{pxport});
+         if ($reqbody) {
-                 $query = "http://$host:$port/$query";
+                 $req = HTTP::Request->new(POST => $url);
+         } else {
+                 $req = HTTP::Request->new(GET => $url);
          }
-         $query .= '?' . $url->query if ($url->query && ! $reqbody);
+         $req->headers->header( 'Host' => $url->host . ":" . $url->port );
+         $req->headers->header( 'Connection', 'close' );
+         $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
+         $req->content_type( $content_type );
-         my $headers;
+         warn $req->headers->as_string,"\n" if ($self->{debug});
          if ($reqbody) {
-                 $headers .= "POST $query HTTP/1.0\r\n";
+                 warn "$reqbody\n" if ($self->{debug});
-         } else {
+                 $req->content( $reqbody );
-                 $headers .= "GET $query HTTP/1.0\r\n";
          }
-         $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";
+         my $res = $ua->request($req) || croak "can't make request to $url: $!";
-         $headers .= "Connection: close\r\n";
-         $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";
+         warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
-         $headers .= "Content-Type: $content_type\r\n";
-         $headers .= "Authorization: Basic $self->{auth}\r\n";
+         ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
-         my $len = 0;
-         {
+         if (! $res->is_success) {
-                 use bytes;
+                 if ($croak_on_error) {
-                 $len = length($reqbody) if ($reqbody);
+                         croak("can't get $url: ",$res->status_line);
+                 } else {
+                         return -1;
+                 }
          }
-         $headers .= "Content-Length: $len\r\n";
-         $headers .= "\r\n";
-         my $sock = IO::Socket::INET->new(
+         $$resbody .= $res->content;
-                 PeerAddr        => $host,
-                 PeerPort        => $port,
+         warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
-                 Proto           => 'tcp',
-                 Timeout         => $self->{timeout} || 90,
+         return $self->{status};
+ }
+ =head2 set_snippet_width
+ Set width of snippets in results
+   $node->set_snippet_width( $wwidth, $hwidth, $awidth );
+ C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
+ is not sent with results. If it is negative, whole document text is sent instead of snippet.
+ C<$hwidth> specified width of strings from beginning of string. Default
+ value is C<96>. Negative or zero value keep previous value.
+ C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
+ If negative of zero value is provided previous value is kept unchanged.
+ =cut
+ sub set_snippet_width {
+         my $self = shift;
+         my ($wwidth, $hwidth, $awidth) = @_;
+         $self->{wwidth} = $wwidth;
+         $self->{hwidth} = $hwidth if ($hwidth >= 0);
+         $self->{awidth} = $awidth if ($awidth >= 0);
+ }
+ =head2 set_user
+ Manage users of node
+   $node->set_user( 'name', $mode );
+ C<$mode> can be one of:
+ =over 4
+ =item 0
+ delete account
+ =item 1
+ set administrative right for user
+ =item 2
+ set user account as guest
+ =back
+ Return true on success, otherwise false.
+ =cut
+ sub set_user {
+         my $self = shift;
+         my ($name, $mode) = @_;
+         return unless ($self->{url});
+         croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
+         $self->shuttle_url( $self->{url} . '/_set_user',
+                 'application/x-www-form-urlencoded',
+                 'name=' . uri_escape($name) . '&mode=' . $mode,
+                 undef
+         ) == 200;
+ }
+ =head2 set_link
+ Manage node links
+   $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
+ If C<$credit> is negative, link is removed.
+ =cut
+ sub set_link {
+         my $self = shift;
+         my ($url, $label, $credit) = @_;
+         return unless ($self->{url});
+         croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
+         my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
+         $reqbody .= '&credit=' . $credit if ($credit > 0);
+         if ($self->shuttle_url( $self->{url} . '/_set_link',
+                 'application/x-www-form-urlencoded',
+                 $reqbody,
+                 undef
+         ) == 200) {
+                 # refresh node info after adding link
+                 $self->_clear_info;
+                 return 1;
+         }
+         return undef;
+ }
+ =head2 admins
+  my @admins = @{ $node->admins };
+ Return array of users with admin rights on node
+ =cut
+ sub admins {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{admins};
+ }
+ =head2 guests
+  my @guests = @{ $node->guests };
+ Return array of users with guest rights on node
+ =cut
+ sub guests {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{guests};
+ }
+ =head2 links
+  my $links = @{ $node->links };
+ Return array of links for this node
+ =cut
+ sub links {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{links};
+ }
+ =head2 cacheusage
+ Return cache usage for a node
+   my $cache = $node->cacheusage;
+ =cut
+ sub cacheusage {
+         my $self = shift;
+         return unless ($self->{url});
+         my $resbody;
+         my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
+                 'text/plain',
+                 undef,
+                 \$resbody,
          );
-         if (! $sock) {
+         return if ($rv != 200 || !$resbody);
-                 carp "can't open socket to $host:$port";
-                 return -1;
+         return $resbody;
+ }
+ =head2 master
+ Set actions on Hyper Estraier node master (C<estmaster> process)
+   $node->master(
+         action => 'sync'
+   );
+ All available actions are documented in
+ L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
+ =cut
+ my $estmaster_rest = {
+         shutdown => {
+                 status => 202,
+         },
+         sync => {
+                 status => 202,
+         },
+         backup => {
+                 status => 202,
+         },
+         userlist => {
+                 status => 200,
+                 returns => [ qw/name passwd flags fname misc/ ],
+         },
+         useradd => {
+                 required => [ qw/name passwd flags/ ],
+                 optional => [ qw/fname misc/ ],
+                 status => 200,
+         },
+         userdel => {
+                 required => [ qw/name/ ],
+                 status => 200,
+         },
+         nodelist => {
+                 status => 200,
+                 returns => [ qw/name label doc_num word_num size/ ],
+         },
+         nodeadd => {
+                 required => [ qw/name/ ],
+                 optional => [ qw/label/ ],
+                 status => 200,
+         },
+         nodedel => {
+                 required => [ qw/name/ ],
+                 status => 200,
+         },
+         nodeclr => {
+                 required => [ qw/name/ ],
+                 status => 200,
+         },
+         nodertt => {
+                 status => 200,
+         },
+ };
+ sub master {
+         my $self = shift;
+         my $args = {@_};
+         # have action?
+         my $action = $args->{action} || croak "need action, available: ",
+                 join(", ",keys %{ $estmaster_rest });
+         # check if action is valid
+         my $rest = $estmaster_rest->{$action};
+         croak "action '$action' is not supported, available actions: ",
+                 join(", ",keys %{ $estmaster_rest }) unless ($rest);
+         croak "BUG: action '$action' needs return status" unless ($rest->{status});
+         my @args;
+         if ($rest->{required} || $rest->{optional}) {
+                 map {
+                         croak "need parametar '$_' for action '$action'" unless ($args->{$_});
+                         push @args, $_ . '=' . uri_escape( $args->{$_} );
+                 } ( @{ $rest->{required} } );
+                 map {
+                         push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
+                 } ( @{ $rest->{optional} } );
          }
-         warn $headers if ($self->{debug});
+         my $uri = new URI( $self->{url} );
-         print $sock $headers or
+         my $resbody;
-                 carp "can't send headers to network:\n$headers\n" and return -1;
-         if ($reqbody) {
+         my $status = $self->shuttle_url(
-                 warn "$reqbody\n" if ($self->{debug});
+                 'http://' . $uri->host_port . '/master?action=' . $action ,
-                 print $sock $reqbody or
+                 'application/x-www-form-urlencoded',
-                         carp "can't send request body to network:\n$$reqbody\n" and return -1;
+                 join('&', @args),
+                 \$resbody,
+,
+         ) or confess "shuttle_url failed";
+         if ($status == $rest->{status}) {
+                 # refresh node info after sync
+                 $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
+                 if ($rest->{returns} && wantarray) {
+                         my @results;
+                         my $fields = $#{$rest->{returns}};
+                         foreach my $line ( split(/[\r\n]/,$resbody) ) {
+                                 my @e = split(/\t/, $line, $fields + 1);
+                                 my $row;
+                                 foreach my $i ( 0 .. $fields) {
+                                         $row->{ $rest->{returns}->[$i] } = $e[ $i ];
+                                 }
+                                 push @results, $row;
+                         }
+                         return @results;
+                 } elsif ($resbody) {
+                         chomp $resbody;
+                         return $resbody;
+                 } else {
+                         return 0E0;
+                 }
          }
-         my $line = <$sock>;
+         carp "expected status $rest->{status}, but got $status";
-         chomp($line);
+         return undef;
-         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
+ =head1 PRIVATE METHODS
-         $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});
+ You could call those directly, but you don't have to. I hope.
-         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);
+         my @lines = split(/[\r\n]/,$resbody);
+         $self->_clear_info;
+         ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
+                 $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
+         return $resbody unless (@lines);
+         shift @lines;
+         while(my $admin = shift @lines) {
+                 push @{$self->{inform}->{admins}}, $admin;
+         }
+         while(my $guest = shift @lines) {
+                 push @{$self->{inform}->{guests}}, $guest;
+         }
+         while(my $link = shift @lines) {
+                 push @{$self->{inform}->{links}}, $link;
+         }
+         return $resbody;
+ }
+ =head2 _clear_info
+ Clear information for node
+   $node->_clear_info;
+ On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
+ info will be fetch again from Hyper Estraier.
+ =cut
+ sub _clear_info {
+         my $self = shift;
+         $self->{inform} = {
+                 dnum => -1,
+                 wnum => -1,
+                 size => -1.0,
+         };
  }
  ###
-Line 1167 
 L<http://hyperestraier.sourceforge.net/>
+Line 2034 
 L<http://hyperestraier.sourceforge.net/>
  Hyper Estraier Ruby interface on which this module is based.
+ Hyper Estraier now also has pure-perl binding included in distribution. It's
+ a faster way to access databases directly if you are not running
+ C<estmaster> P2P server.
  =head1 AUTHOR
  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
+ Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
  =head1 COPYRIGHT AND LICENSE

 Legend:



Removed from v.47
 


changed lines


 
Added in v.166
 Legend:



Removed from v.47
 


changed lines


 
Added in v.166
-Removed from v.47
+Added in v.166

	ViewVC Help
Powered by ViewVC 1.1.26