/[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!
ViewVC logotype

Diff of /trunk/lib/Search/Estraier.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 58 by dpavlin, Fri Jan 6 21:05:05 2006 UTC revision 166 by dpavlin, Sun Aug 6 12:48:02 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.07_3';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node(
21                    url => 'http://localhost:1978/node/test',
22                    user => 'admin',
23                    passwd => 'admin',
24                    create => 1,
25                    label => 'Label for node',
26                    croak_on_error => 1,
27            );
28    
29            # create document
30            my $doc = new Search::Estraier::Document;
31    
32            # add attributes
33            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
34            $doc->add_attr('@title', "Over the Rainbow");
35    
36            # add body text to document
37            $doc->add_text("Somewhere over the rainbow.  Way up high.");
38            $doc->add_text("There's a land that I heard of once in a lullaby.");
39    
40            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
41    
42    =head2 Simple searcher
43    
44            use Search::Estraier;
45    
46            # create and configure node
47            my $node = new Search::Estraier::Node(
48                    url => 'http://localhost:1978/node/test',
49                    user => 'admin',
50                    passwd => 'admin',
51                    croak_on_error => 1,
52            );
53    
54            # create condition
55            my $cond = new Search::Estraier::Condition;
56    
57            # set search phrase
58            $cond->set_phrase("rainbow AND lullaby");
59    
60            my $nres = $node->search($cond, 0);
61    
62            if (defined($nres)) {
63                    print "Got ", $nres->hits, " results\n";
64    
65                    # for each document in results
66                    for my $i ( 0 ... $nres->doc_num - 1 ) {
67                            # get result document
68                            my $rdoc = $nres->get_doc($i);
69                            # display attribte
70                            print "URI: ", $rdoc->attr('@uri'),"\n";
71                            print "Title: ", $rdoc->attr('@title'),"\n";
72                            print $rdoc->snippet,"\n";
73                    }
74            } else {
75                    die "error: ", $node->status,"\n";
76            }
77    
78  =head1 DESCRIPTION  =head1 DESCRIPTION
79    
# Line 25  or Hyper Estraier development files on t Line 85  or Hyper Estraier development files on t
85  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
86  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
87    
88    There are few examples in C<scripts> directory of this distribution.
89    
90  =cut  =cut
91    
92  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 103  Remove multiple whitespaces from string,
103  =cut  =cut
104    
105  sub _s {  sub _s {
106          my $text = $_[1] || return;          my $text = $_[1];
107            return unless defined($text);
108          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
109          $text =~ s/^\s+//;          $text =~ s/^\s+//;
110          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 57  our @ISA = qw/Search::Estraier/; Line 120  our @ISA = qw/Search::Estraier/;
120    
121  =head1 Search::Estraier::Document  =head1 Search::Estraier::Document
122    
123  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.  
124    
125    It's is collection of:
126    
127    =over 4
128    
129    =item attributes
130    
131    C<< 'key' => 'value' >> pairs which can later be used for filtering of results
132    
133    You can add common filters to C<attrindex> in estmaster's C<_conf>
134    file for better performance. See C<attrindex> in
135    L<Hyper Estraier P2P Guide|http://hyperestraier.sourceforge.net/nguide-en.html>.
136    
137    =item vectors
138    
139    also C<< 'key' => 'value' >> pairs
140    
141    =item display text
142    
143    Text which will be used to create searchable corpus of your index and
144    included in snippet output.
145    
146    =item hidden text
147    
148    Text which will be searchable, but will not be included in snippet.
149    
150    =back
151    
152  =head2 new  =head2 new
153    
# Line 94  sub new { Line 182  sub new {
182    
183                          if ($line =~ m/^%VECTOR\t(.+)$/) {                          if ($line =~ m/^%VECTOR\t(.+)$/) {
184                                  my @fields = split(/\t/, $1);                                  my @fields = split(/\t/, $1);
185                                  for my $i ( 0 .. ($#fields - 1) ) {                                  if ($#fields % 2 == 1) {
186                                          $self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];                                          $self->{kwords} = { @fields };
187                                          $i++;                                  } else {
188                                            warn "can't decode $line\n";
189                                  }                                  }
190                                  next;                                  next;
191                          } elsif ($line =~ m/^%/) {                          } elsif ($line =~ m/^%/) {
# Line 106  sub new { Line 195  sub new {
195                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
196                                  $in_text = 1;                                  $in_text = 1;
197                                  next;                                  next;
198                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
199                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
200                                  next;                                  next;
201                          }                          }
202    
203                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
204                  }                  }
205          }          }
206    
# Line 180  sub add_hidden_text { Line 269  sub add_hidden_text {
269          push @{ $self->{htexts} }, $self->_s($text);          push @{ $self->{htexts} }, $self->_s($text);
270  }  }
271    
272    =head2 add_vectors
273    
274    Add a vectors
275    
276      $doc->add_vector(
277            'vector_name' => 42,
278            'another' => 12345,
279      );
280    
281    =cut
282    
283    sub add_vectors {
284            my $self = shift;
285            return unless (@_);
286    
287            # this is ugly, but works
288            die "add_vector needs HASH as argument" unless ($#_ % 2 == 1);
289    
290            $self->{kwords} = {@_};
291    }
292    
293    
294  =head2 id  =head2 id
295    
# Line 205  Returns array with attribute names from Line 315  Returns array with attribute names from
315    
316  sub attr_names {  sub attr_names {
317          my $self = shift;          my $self = shift;
318          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
319            #croak "attr_names return array, not scalar" if (! wantarray);
320          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
321  }  }
322    
# Line 221  Returns value of an attribute. Line 332  Returns value of an attribute.
332  sub attr {  sub attr {
333          my $self = shift;          my $self = shift;
334          my $name = shift;          my $name = shift;
335            return unless (defined($name) && $self->{attrs});
336          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
337  }  }
338    
339    
# Line 236  Returns array with text sentences. Line 347  Returns array with text sentences.
347    
348  sub texts {  sub texts {
349          my $self = shift;          my $self = shift;
350          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
351          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
352  }  }
353    
354    
# Line 251  Return whole text as single scalar. Line 362  Return whole text as single scalar.
362    
363  sub cat_texts {  sub cat_texts {
364          my $self = shift;          my $self = shift;
365          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
366  }  }
367    
368    
# Line 268  sub dump_draft { Line 379  sub dump_draft {
379          my $draft;          my $draft;
380    
381          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
382                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
383                    $draft .= $attr_name . '=' . $v . "\n";
384          }          }
385    
386          if ($self->{kwords}) {          if ($self->{kwords}) {
387                  $draft .= '%%VECTOR';                  $draft .= '%VECTOR';
388                  while (my ($key, $value) = each %{ $self->{kwords} }) {                  while (my ($key, $value) = each %{ $self->{kwords} }) {
389                          $draft .= "\t$key\t$value";                          $draft .= "\t$key\t$value";
390                  }                  }
# Line 316  sub delete { Line 428  sub delete {
428    
429  package Search::Estraier::Condition;  package Search::Estraier::Condition;
430    
431  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
432    
433  use Search::Estraier;  use Search::Estraier;
434  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 506  sub set_max {
506    
507  =head2 set_options  =head2 set_options
508    
509    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
510    
511      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
512    
513    Possible options are:
514    
515    =over 8
516    
517    =item SURE
518    
519    check every N-gram
520    
521    =item USUAL
522    
523    check every second N-gram
524    
525    =item FAST
526    
527    check every third N-gram
528    
529    =item AGITO
530    
531    check every fourth N-gram
532    
533    =item NOIDF
534    
535    don't perform TF-IDF tuning
536    
537    =item SIMPLE
538    
539    use simplified query phrase
540    
541    =back
542    
543    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
544    options;
545    
546    This option changed in version C<0.04> of this module. It's backwards compatibile.
547    
548  =cut  =cut
549    
550  my $options = {  my $options = {
         # check N-gram keys skipping by three  
551          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
552          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
553          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
554          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
555          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
556          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
557  };  };
558    
559  sub set_options {  sub set_options {
560          my $self = shift;          my $self = shift;
561          my $option = shift;          my $opt = 0;
562          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
563          $self->{options} ||= $options->{$option};                  my $mask;
564                    unless ($mask = $options->{$option}) {
565                            if ($option eq '1') {
566                                    next;
567                            } else {
568                                    croak "unknown option $option";
569                            }
570                    }
571                    $opt += $mask;
572            }
573            $self->{options} = $opt;
574  }  }
575    
576    
# Line 460  Return search result attrs. Line 613  Return search result attrs.
613  sub attrs {  sub attrs {
614          my $self = shift;          my $self = shift;
615          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
616          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
617  }  }
618    
619    
# Line 496  sub options { Line 649  sub options {
649  }  }
650    
651    
652    =head2 set_skip
653    
654    Set number of skipped documents from beginning of results
655    
656      $cond->set_skip(42);
657    
658    Similar to C<offset> in RDBMS.
659    
660    =cut
661    
662    sub set_skip {
663            my $self = shift;
664            $self->{skip} = shift;
665    }
666    
667    =head2 skip
668    
669    Return skip for this condition.
670    
671      print $cond->skip;
672    
673    =cut
674    
675    sub skip {
676            my $self = shift;
677            return $self->{skip};
678    }
679    
680    
681  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
682    
683  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 706  sub new {
706          my $self = {@_};          my $self = {@_};
707          bless($self, $class);          bless($self, $class);
708    
709          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});  
         }  
710    
711          $self ? return $self : return undef;          $self ? return $self : return undef;
712  }  }
# Line 641  Return number of documents Line 821  Return number of documents
821    
822    print $res->doc_num;    print $res->doc_num;
823    
824    This will return real number of documents (limited by C<max>).
825    If you want to get total number of hits, see C<hits>.
826    
827  =cut  =cut
828    
829  sub doc_num {  sub doc_num {
# Line 672  sub get_doc { Line 855  sub get_doc {
855    
856  Return specific hint from results.  Return specific hint from results.
857    
858    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
859    
860  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
861  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 868  sub hint {
868          return $self->{hints}->{$key};          return $self->{hints}->{$key};
869  }  }
870    
871    =head2 hints
872    
873    More perlish version of C<hint>. This one returns hash.
874    
875      my %hints = $res->hints;
876    
877    =cut
878    
879    sub hints {
880            my $self = shift;
881            return $self->{hints};
882    }
883    
884    =head2 hits
885    
886    Syntaxtic sugar for total number of hits for this query
887    
888      print $res->hits;
889    
890    It's same as
891    
892      print $res->hint('HIT');
893    
894    but shorter.
895    
896    =cut
897    
898    sub hits {
899            my $self = shift;
900            return $self->{hints}->{'HIT'} || 0;
901    }
902    
903  package Search::Estraier::Node;  package Search::Estraier::Node;
904    
# Line 700  use URI::Escape qw/uri_escape/; Line 914  use URI::Escape qw/uri_escape/;
914    
915    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
916    
917    or optionally with C<url> as parametar
918    
919      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
920    
921    or in more verbose form
922    
923      my $node = new Search::HyperEstraier::Node(
924            url => 'http://localhost:1978/node/test',
925            user => 'admin',
926            passwd => 'admin'
927            create => 1,
928            label => 'optional node label',
929            debug => 1,
930            croak_on_error => 1
931      );
932    
933    with following arguments:
934    
935    =over 4
936    
937    =item url
938    
939    URL to node
940    
941    =item user
942    
943    specify username for node server authentication
944    
945    =item passwd
946    
947    password for authentication
948    
949    =item create
950    
951    create node if it doesn't exists
952    
953    =item label
954    
955    optional label for new node if C<create> is used
956    
957    =item debug
958    
959    dumps a B<lot> of debugging output
960    
961    =item croak_on_error
962    
963    very helpful during development. It will croak on all errors instead of
964    silently returning C<-1> (which is convention of Hyper Estraier API in other
965    languages).
966    
967    =back
968    
969  =cut  =cut
970    
971  sub new {  sub new {
# Line 707  sub new { Line 973  sub new {
973          my $self = {          my $self = {
974                  pxport => -1,                  pxport => -1,
975                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
976                  wwidth => 480,                  wwidth => 480,
977                  hwidth => 96,                  hwidth => 96,
978                  awidth => 96,                  awidth => 96,
979                  status => -1,                  status => -1,
980          };          };
981    
982          bless($self, $class);          bless($self, $class);
983    
984          my $args = {@_};          if ($#_ == 0) {
985                    $self->{url} = shift;
986            } else {
987                    %$self = ( %$self, @_ );
988    
989          $self->{debug} = $args->{debug};                  $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
990          warn "## Node debug on\n" if ($self->{debug});  
991                    warn "## Node debug on\n" if ($self->{debug});
992            }
993    
994            $self->{inform} = {
995                    dnum => -1,
996                    wnum => -1,
997                    size => -1.0,
998            };
999    
1000            if ($self->{create}) {
1001                    if (! eval { $self->name } || $@) {
1002                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
1003                            croak "can't find node name in '$self->{url}'" unless ($name);
1004                            my $label = $self->{label} || $name;
1005                            $self->master(
1006                                    action => 'nodeadd',
1007                                    name => $name,
1008                                    label => $label,
1009                            ) || croak "can't create node $name ($label)";
1010                    }
1011            }
1012    
1013          $self ? return $self : return undef;          $self ? return $self : return undef;
1014  }  }
# Line 812  Add a document Line 1100  Add a document
1100    
1101    $node->put_doc( $document_draft ) or die "can't add document";    $node->put_doc( $document_draft ) or die "can't add document";
1102    
1103  Return true on success or false on failture.  Return true on success or false on failure.
1104    
1105  =cut  =cut
1106    
# Line 820  sub put_doc { Line 1108  sub put_doc {
1108          my $self = shift;          my $self = shift;
1109          my $doc = shift || return;          my $doc = shift || return;
1110          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1111          $self->shuttle_url( $self->{url} . '/put_doc',          if ($self->shuttle_url( $self->{url} . '/put_doc',
1112                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1113                  $doc->dump_draft,                  $doc->dump_draft,
1114                  undef                  undef
1115          ) == 200;          ) == 200) {
1116                    $self->_clear_info;
1117                    return 1;
1118            }
1119            return undef;
1120  }  }
1121    
1122    
# Line 843  sub out_doc { Line 1135  sub out_doc {
1135          my $id = shift || return;          my $id = shift || return;
1136          return unless ($self->{url});          return unless ($self->{url});
1137          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1138          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1139                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1140                  "id=$id",                  "id=$id",
1141                  undef                  undef
1142          ) == 200;          ) == 200) {
1143                    $self->_clear_info;
1144                    return 1;
1145            }
1146            return undef;
1147  }  }
1148    
1149    
# Line 865  sub out_doc_by_uri { Line 1161  sub out_doc_by_uri {
1161          my $self = shift;          my $self = shift;
1162          my $uri = shift || return;          my $uri = shift || return;
1163          return unless ($self->{url});          return unless ($self->{url});
1164          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1165                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1166                  "uri=" . uri_escape($uri),                  "uri=" . uri_escape($uri),
1167                  undef                  undef
1168          ) == 200;          ) == 200) {
1169                    $self->_clear_info;
1170                    return 1;
1171            }
1172            return undef;
1173  }  }
1174    
1175    
# Line 887  sub edit_doc { Line 1187  sub edit_doc {
1187          my $self = shift;          my $self = shift;
1188          my $doc = shift || return;          my $doc = shift || return;
1189          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1190          $self->shuttle_url( $self->{url} . '/edit_doc',          if ($self->shuttle_url( $self->{url} . '/edit_doc',
1191                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1192                  $doc->dump_draft,                  $doc->dump_draft,
1193                  undef                  undef
1194          ) == 200;          ) == 200) {
1195                    $self->_clear_info;
1196                    return 1;
1197            }
1198            return undef;
1199  }  }
1200    
1201    
# Line 1000  Get ID of document specified by URI Line 1304  Get ID of document specified by URI
1304    
1305    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1306    
1307    This method won't croak, even if using C<croak_on_error>.
1308    
1309  =cut  =cut
1310    
1311  sub uri_to_id {  sub uri_to_id {
1312          my $self = shift;          my $self = shift;
1313          my $uri = shift || return;          my $uri = shift || return;
1314          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 );
1315  }  }
1316    
1317    
# Line 1065  sub _fetch_doc { Line 1371  sub _fetch_doc {
1371                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1372                  $arg,                  $arg,
1373                  \$resbody,                  \$resbody,
1374                    $a->{croak_on_error},
1375          );          );
1376    
1377          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1402  sub _fetch_doc {
1402    
1403  sub name {  sub name {
1404          my $self = shift;          my $self = shift;
1405          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1406          return $self->{name};          return $self->{inform}->{name};
1407  }  }
1408    
1409    
# Line 1108  sub name { Line 1415  sub name {
1415    
1416  sub label {  sub label {
1417          my $self = shift;          my $self = shift;
1418          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1419          return $self->{label};          return $self->{inform}->{label};
1420  }  }
1421    
1422    
# Line 1121  sub label { Line 1428  sub label {
1428    
1429  sub doc_num {  sub doc_num {
1430          my $self = shift;          my $self = shift;
1431          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1432          return $self->{dnum};          return $self->{inform}->{dnum};
1433  }  }
1434    
1435    
# Line 1134  sub doc_num { Line 1441  sub doc_num {
1441    
1442  sub word_num {  sub word_num {
1443          my $self = shift;          my $self = shift;
1444          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1445          return $self->{wnum};          return $self->{inform}->{wnum};
1446  }  }
1447    
1448    
# Line 1147  sub word_num { Line 1454  sub word_num {
1454    
1455  sub size {  sub size {
1456          my $self = shift;          my $self = shift;
1457          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1458          return $self->{size};          return $self->{inform}->{size};
1459  }  }
1460    
1461    
# Line 1176  sub search { Line 1483  sub search {
1483    
1484          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1485                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1486                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1487                  \$resbody,                  \$resbody,
1488          );          );
1489          return if ($rv != 200);          return if ($rv != 200);
1490    
1491          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1492            my $hintsText   = splice @records, 0, 2; # starts with empty record
1493          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1494          return unless (@lines);  
1495            # process records
1496          my $border = $lines[0];          my $docs = [];
1497          my $isend = 0;          foreach my $record (@records)
1498          my $lnum = 1;          {
1499                    # split into keys and snippets
1500          while ( $lnum <= $#lines ) {                  my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
                 my $line = $lines[$lnum];  
                 $lnum++;  
   
                 #warn "## $line\n";  
                 if ($line && $line =~ m/^\Q$border\E(:END)*$/) {  
                         $isend = $1;  
                         last;  
                 }  
   
                 if ($line =~ /\t/) {  
                         my ($k,$v) = split(/\t/, $line, 2);  
                         $hints->{$k} = $v;  
                 }  
         }  
   
         my $snum = $lnum;  
   
         while( ! $isend && $lnum <= $#lines ) {  
                 my $line = $lines[$lnum];  
                 #warn "# $lnum: $line\n";  
                 $lnum++;  
   
                 if ($line && $line =~ m/^\Q$border\E/) {  
                         if ($lnum > $snum) {  
                                 my $rdattrs;  
                                 my $rdvector;  
                                 my $rdsnippet;  
                                   
                                 my $rlnum = $snum;  
                                 while ($rlnum < $lnum - 1 ) {  
                                         #my $rdline = $self->_s($lines[$rlnum]);  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         last unless ($rdline);  
                                         if ($rdline =~ /^%/) {  
                                                 $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);  
                                         } elsif($rdline =~ /=/) {  
                                                 $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);  
                                         } else {  
                                                 confess "invalid format of response";  
                                         }  
                                 }  
                                 while($rlnum < $lnum - 1) {  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         $rdsnippet .= "$rdline\n";  
                                 }  
                                 #warn Dumper($rdvector, $rdattrs, $rdsnippet);  
                                 if (my $rduri = $rdattrs->{'@uri'}) {  
                                         push @docs, new Search::Estraier::ResultDocument(  
                                                 uri => $rduri,  
                                                 attrs => $rdattrs,  
                                                 snippet => $rdsnippet,  
                                                 keywords => $rdvector,  
                                         );  
                                 }  
                         }  
                         $snum = $lnum;  
                         #warn "### $line\n";  
                         $isend = 1 if ($line =~ /:END$/);  
                 }  
   
         }  
1501    
1502          if (! $isend) {                  # create document hash
1503                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1504                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1505                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1506                    $doc->{snippet}         = $snippet;
1507    
1508                    push @$docs, new Search::Estraier::ResultDocument(
1509                            attrs           => $doc,
1510                            uri             => $doc->{'@uri'},
1511                            snippet         => $snippet,
1512                            keywords        => $doc->{'keywords'},
1513                    );
1514          }          }
1515    
1516          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1517  }  }
1518    
1519    
# Line 1270  sub search { Line 1521  sub search {
1521    
1522  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1523    
1524    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1525    
1526  =cut  =cut
1527    
# Line 1279  sub cond_to_query { Line 1530  sub cond_to_query {
1530    
1531          my $cond = shift || return;          my $cond = shift || return;
1532          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1533            my $depth = shift;
1534    
1535          my @args;          my @args;
1536    
# Line 1288  sub cond_to_query { Line 1540  sub cond_to_query {
1540    
1541          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1542                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1543                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1544                  }                  }
1545          }          }
1546    
# Line 1306  sub cond_to_query { Line 1558  sub cond_to_query {
1558                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1559          }          }
1560    
1561          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1562          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1563          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1564          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1565            push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
1566    
1567          return join('&', @args);          return join('&', @args);
1568  }  }
# Line 1317  sub cond_to_query { Line 1570  sub cond_to_query {
1570    
1571  =head2 shuttle_url  =head2 shuttle_url
1572    
1573  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
1574  master.  master.
1575    
1576    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
# Line 1327  body will be saved within object. Line 1580  body will be saved within object.
1580    
1581  =cut  =cut
1582    
1583    use LWP::UserAgent;
1584    
1585  sub shuttle_url {  sub shuttle_url {
1586          my $self = shift;          my $self = shift;
1587    
1588          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1589    
1590            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1591    
1592          $self->{status} = -1;          $self->{status} = -1;
1593    
# Line 1345  sub shuttle_url { Line 1602  sub shuttle_url {
1602                  return -1;                  return -1;
1603          }          }
1604    
1605          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1606            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
         if ($self->{pxhost}) {  
                 ($host,$port) = ($self->{pxhost}, $self->{pxport});  
                 $query = "http://$host:$port/$query";  
         }  
   
         $query .= '?' . $url->query if ($url->query && ! $reqbody);  
   
         my $headers;  
1607    
1608            my $req;
1609          if ($reqbody) {          if ($reqbody) {
1610                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1611          } else {          } else {
1612                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1613          }          }
1614    
1615          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1616          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1617          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1618          $headers .= "Content-Type: $content_type\r\n";          $req->content_type( $content_type );
         $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";  
1619    
1620          my $sock = IO::Socket::INET->new(          warn $req->headers->as_string,"\n" if ($self->{debug});
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1621    
1622          if (! $sock) {          if ($reqbody) {
1623                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1624                  return -1;                  $req->content( $reqbody );
1625          }          }
1626    
1627          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1628    
1629          print $sock $headers or          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1630    
1631          if ($reqbody) {          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
                 warn "$reqbody\n" if ($self->{debug});  
                 print $sock $reqbody or  
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
         }  
1632    
1633          my $line = <$sock>;          if (! $res->is_success) {
1634          chomp($line);                  if ($croak_on_error) {
1635          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1636          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1637                            return -1;
1638          $self->{status} = $res_status;                  }
1639          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});  
         };  
1640    
1641          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1642    
1643          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1644    
# Line 1490  sub set_user { Line 1709  sub set_user {
1709          croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);          croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1710    
1711          $self->shuttle_url( $self->{url} . '/_set_user',          $self->shuttle_url( $self->{url} . '/_set_user',
1712                  'text/plain',                  'application/x-www-form-urlencoded',
1713                  'name=' . uri_escape($name) . '&mode=' . $mode,                  'name=' . uri_escape($name) . '&mode=' . $mode,
1714                  undef                  undef
1715          ) == 200;          ) == 200;
# Line 1517  sub set_link { Line 1736  sub set_link {
1736          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1737          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1738    
1739          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1740                  'text/plain',                  'application/x-www-form-urlencoded',
1741                  $reqbody,                  $reqbody,
1742                  undef                  undef
1743          ) == 200;          ) == 200) {
1744                    # refresh node info after adding link
1745                    $self->_clear_info;
1746                    return 1;
1747            }
1748            return undef;
1749    }
1750    
1751    =head2 admins
1752    
1753     my @admins = @{ $node->admins };
1754    
1755    Return array of users with admin rights on node
1756    
1757    =cut
1758    
1759    sub admins {
1760            my $self = shift;
1761            $self->_set_info unless ($self->{inform}->{name});
1762            return $self->{inform}->{admins};
1763    }
1764    
1765    =head2 guests
1766    
1767     my @guests = @{ $node->guests };
1768    
1769    Return array of users with guest rights on node
1770    
1771    =cut
1772    
1773    sub guests {
1774            my $self = shift;
1775            $self->_set_info unless ($self->{inform}->{name});
1776            return $self->{inform}->{guests};
1777    }
1778    
1779    =head2 links
1780    
1781     my $links = @{ $node->links };
1782    
1783    Return array of links for this node
1784    
1785    =cut
1786    
1787    sub links {
1788            my $self = shift;
1789            $self->_set_info unless ($self->{inform}->{name});
1790            return $self->{inform}->{links};
1791    }
1792    
1793    =head2 cacheusage
1794    
1795    Return cache usage for a node
1796    
1797      my $cache = $node->cacheusage;
1798    
1799    =cut
1800    
1801    sub cacheusage {
1802            my $self = shift;
1803    
1804            return unless ($self->{url});
1805    
1806            my $resbody;
1807            my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
1808                    'text/plain',
1809                    undef,
1810                    \$resbody,
1811            );
1812    
1813            return if ($rv != 200 || !$resbody);
1814    
1815            return $resbody;
1816  }  }
1817    
1818    =head2 master
1819    
1820    Set actions on Hyper Estraier node master (C<estmaster> process)
1821    
1822      $node->master(
1823            action => 'sync'
1824      );
1825    
1826    All available actions are documented in
1827    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1828    
1829    =cut
1830    
1831    my $estmaster_rest = {
1832            shutdown => {
1833                    status => 202,
1834            },
1835            sync => {
1836                    status => 202,
1837            },
1838            backup => {
1839                    status => 202,
1840            },
1841            userlist => {
1842                    status => 200,
1843                    returns => [ qw/name passwd flags fname misc/ ],
1844            },
1845            useradd => {
1846                    required => [ qw/name passwd flags/ ],
1847                    optional => [ qw/fname misc/ ],
1848                    status => 200,
1849            },
1850            userdel => {
1851                    required => [ qw/name/ ],
1852                    status => 200,
1853            },
1854            nodelist => {
1855                    status => 200,
1856                    returns => [ qw/name label doc_num word_num size/ ],
1857            },
1858            nodeadd => {
1859                    required => [ qw/name/ ],
1860                    optional => [ qw/label/ ],
1861                    status => 200,
1862            },
1863            nodedel => {
1864                    required => [ qw/name/ ],
1865                    status => 200,
1866            },
1867            nodeclr => {
1868                    required => [ qw/name/ ],
1869                    status => 200,
1870            },
1871            nodertt => {
1872                    status => 200,  
1873            },
1874    };
1875    
1876    sub master {
1877            my $self = shift;
1878    
1879            my $args = {@_};
1880    
1881            # have action?
1882            my $action = $args->{action} || croak "need action, available: ",
1883                    join(", ",keys %{ $estmaster_rest });
1884    
1885            # check if action is valid
1886            my $rest = $estmaster_rest->{$action};
1887            croak "action '$action' is not supported, available actions: ",
1888                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1889    
1890            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1891    
1892            my @args;
1893    
1894            if ($rest->{required} || $rest->{optional}) {
1895    
1896                    map {
1897                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1898                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1899                    } ( @{ $rest->{required} } );
1900    
1901                    map {
1902                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1903                    } ( @{ $rest->{optional} } );
1904    
1905            }
1906    
1907            my $uri = new URI( $self->{url} );
1908    
1909            my $resbody;
1910    
1911            my $status = $self->shuttle_url(
1912                    'http://' . $uri->host_port . '/master?action=' . $action ,
1913                    'application/x-www-form-urlencoded',
1914                    join('&', @args),
1915                    \$resbody,
1916                    1,
1917            ) or confess "shuttle_url failed";
1918    
1919            if ($status == $rest->{status}) {
1920    
1921                    # refresh node info after sync
1922                    $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
1923    
1924                    if ($rest->{returns} && wantarray) {
1925    
1926                            my @results;
1927                            my $fields = $#{$rest->{returns}};
1928    
1929                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1930                                    my @e = split(/\t/, $line, $fields + 1);
1931                                    my $row;
1932                                    foreach my $i ( 0 .. $fields) {
1933                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1934                                    }
1935                                    push @results, $row;
1936                            }
1937    
1938                            return @results;
1939    
1940                    } elsif ($resbody) {
1941                            chomp $resbody;
1942                            return $resbody;
1943                    } else {
1944                            return 0E0;
1945                    }
1946            }
1947    
1948            carp "expected status $rest->{status}, but got $status";
1949            return undef;
1950    }
1951    
1952  =head1 PRIVATE METHODS  =head1 PRIVATE METHODS
1953    
# Line 1552  sub _set_info { Line 1976  sub _set_info {
1976    
1977          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1978    
1979          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1980          $resbody =~ s/[\r\n]+$//;  
1981            $self->_clear_info;
1982    
1983            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1984                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1985    
1986            return $resbody unless (@lines);
1987    
1988          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          shift @lines;
                 split(/\t/, $resbody, 5);  
1989    
1990            while(my $admin = shift @lines) {
1991                    push @{$self->{inform}->{admins}}, $admin;
1992            }
1993    
1994            while(my $guest = shift @lines) {
1995                    push @{$self->{inform}->{guests}}, $guest;
1996            }
1997    
1998            while(my $link = shift @lines) {
1999                    push @{$self->{inform}->{links}}, $link;
2000            }
2001    
2002            return $resbody;
2003    
2004    }
2005    
2006    =head2 _clear_info
2007    
2008    Clear information for node
2009    
2010      $node->_clear_info;
2011    
2012    On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
2013    info will be fetch again from Hyper Estraier.
2014    
2015    =cut
2016    sub _clear_info {
2017            my $self = shift;
2018            $self->{inform} = {
2019                    dnum => -1,
2020                    wnum => -1,
2021                    size => -1.0,
2022            };
2023  }  }
2024    
2025  ###  ###
# Line 1572  L<http://hyperestraier.sourceforge.net/> Line 2034  L<http://hyperestraier.sourceforge.net/>
2034    
2035  Hyper Estraier Ruby interface on which this module is based.  Hyper Estraier Ruby interface on which this module is based.
2036    
2037    Hyper Estraier now also has pure-perl binding included in distribution. It's
2038    a faster way to access databases directly if you are not running
2039    C<estmaster> P2P server.
2040    
2041  =head1 AUTHOR  =head1 AUTHOR
2042    
2043  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
2044    
2045    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
2046    
2047  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
2048    
Legend:
Removed from v.58  
changed lines
  Added in v.166
  ViewVC Help
Powered by ViewVC 1.1.26