/[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 164 by dpavlin, Sun Aug 6 12:19:19 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_2';
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 106  sub new { Line 194  sub new {
194                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
195                                  $in_text = 1;                                  $in_text = 1;
196                                  next;                                  next;
197                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
198                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
199                                  next;                                  next;
200                          }                          }
201    
202                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
203                  }                  }
204          }          }
205    
# Line 205  Returns array with attribute names from Line 293  Returns array with attribute names from
293    
294  sub attr_names {  sub attr_names {
295          my $self = shift;          my $self = shift;
296          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
297            #croak "attr_names return array, not scalar" if (! wantarray);
298          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
299  }  }
300    
# Line 221  Returns value of an attribute. Line 310  Returns value of an attribute.
310  sub attr {  sub attr {
311          my $self = shift;          my $self = shift;
312          my $name = shift;          my $name = shift;
313            return unless (defined($name) && $self->{attrs});
314          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
315  }  }
316    
317    
# Line 236  Returns array with text sentences. Line 325  Returns array with text sentences.
325    
326  sub texts {  sub texts {
327          my $self = shift;          my $self = shift;
328          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
329          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
330  }  }
331    
332    
# Line 251  Return whole text as single scalar. Line 340  Return whole text as single scalar.
340    
341  sub cat_texts {  sub cat_texts {
342          my $self = shift;          my $self = shift;
343          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
344  }  }
345    
346    
# Line 268  sub dump_draft { Line 357  sub dump_draft {
357          my $draft;          my $draft;
358    
359          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
360                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
361                    $draft .= $attr_name . '=' . $v . "\n";
362          }          }
363    
364          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 406  sub delete {
406    
407  package Search::Estraier::Condition;  package Search::Estraier::Condition;
408    
409  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
410    
411  use Search::Estraier;  use Search::Estraier;
412  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 484  sub set_max {
484    
485  =head2 set_options  =head2 set_options
486    
487    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
488    
489      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
490    
491    Possible options are:
492    
493    =over 8
494    
495    =item SURE
496    
497    check every N-gram
498    
499    =item USUAL
500    
501    check every second N-gram
502    
503    =item FAST
504    
505    check every third N-gram
506    
507    =item AGITO
508    
509    check every fourth N-gram
510    
511    =item NOIDF
512    
513    don't perform TF-IDF tuning
514    
515    =item SIMPLE
516    
517    use simplified query phrase
518    
519    =back
520    
521    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
522    options;
523    
524    This option changed in version C<0.04> of this module. It's backwards compatibile.
525    
526  =cut  =cut
527    
528  my $options = {  my $options = {
         # check N-gram keys skipping by three  
529          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
530          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
531          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
532          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
533          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
534          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
535  };  };
536    
537  sub set_options {  sub set_options {
538          my $self = shift;          my $self = shift;
539          my $option = shift;          my $opt = 0;
540          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
541          $self->{options} ||= $options->{$option};                  my $mask;
542                    unless ($mask = $options->{$option}) {
543                            if ($option eq '1') {
544                                    next;
545                            } else {
546                                    croak "unknown option $option";
547                            }
548                    }
549                    $opt += $mask;
550            }
551            $self->{options} = $opt;
552  }  }
553    
554    
# Line 460  Return search result attrs. Line 591  Return search result attrs.
591  sub attrs {  sub attrs {
592          my $self = shift;          my $self = shift;
593          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
594          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
595  }  }
596    
597    
# Line 496  sub options { Line 627  sub options {
627  }  }
628    
629    
630    =head2 set_skip
631    
632    Set number of skipped documents from beginning of results
633    
634      $cond->set_skip(42);
635    
636    Similar to C<offset> in RDBMS.
637    
638    =cut
639    
640    sub set_skip {
641            my $self = shift;
642            $self->{skip} = shift;
643    }
644    
645    =head2 skip
646    
647    Return skip for this condition.
648    
649      print $cond->skip;
650    
651    =cut
652    
653    sub skip {
654            my $self = shift;
655            return $self->{skip};
656    }
657    
658    
659  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
660    
661  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 684  sub new {
684          my $self = {@_};          my $self = {@_};
685          bless($self, $class);          bless($self, $class);
686    
687          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});  
         }  
688    
689          $self ? return $self : return undef;          $self ? return $self : return undef;
690  }  }
# Line 641  Return number of documents Line 799  Return number of documents
799    
800    print $res->doc_num;    print $res->doc_num;
801    
802    This will return real number of documents (limited by C<max>).
803    If you want to get total number of hits, see C<hits>.
804    
805  =cut  =cut
806    
807  sub doc_num {  sub doc_num {
# Line 672  sub get_doc { Line 833  sub get_doc {
833    
834  Return specific hint from results.  Return specific hint from results.
835    
836    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
837    
838  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>,
839  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 846  sub hint {
846          return $self->{hints}->{$key};          return $self->{hints}->{$key};
847  }  }
848    
849    =head2 hints
850    
851    More perlish version of C<hint>. This one returns hash.
852    
853      my %hints = $res->hints;
854    
855    =cut
856    
857    sub hints {
858            my $self = shift;
859            return $self->{hints};
860    }
861    
862    =head2 hits
863    
864    Syntaxtic sugar for total number of hits for this query
865    
866      print $res->hits;
867    
868    It's same as
869    
870      print $res->hint('HIT');
871    
872    but shorter.
873    
874    =cut
875    
876    sub hits {
877            my $self = shift;
878            return $self->{hints}->{'HIT'} || 0;
879    }
880    
881  package Search::Estraier::Node;  package Search::Estraier::Node;
882    
# Line 700  use URI::Escape qw/uri_escape/; Line 892  use URI::Escape qw/uri_escape/;
892    
893    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
894    
895    or optionally with C<url> as parametar
896    
897      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
898    
899    or in more verbose form
900    
901      my $node = new Search::HyperEstraier::Node(
902            url => 'http://localhost:1978/node/test',
903            user => 'admin',
904            passwd => 'admin'
905            create => 1,
906            label => 'optional node label',
907            debug => 1,
908            croak_on_error => 1
909      );
910    
911    with following arguments:
912    
913    =over 4
914    
915    =item url
916    
917    URL to node
918    
919    =item user
920    
921    specify username for node server authentication
922    
923    =item passwd
924    
925    password for authentication
926    
927    =item create
928    
929    create node if it doesn't exists
930    
931    =item label
932    
933    optional label for new node if C<create> is used
934    
935    =item debug
936    
937    dumps a B<lot> of debugging output
938    
939    =item croak_on_error
940    
941    very helpful during development. It will croak on all errors instead of
942    silently returning C<-1> (which is convention of Hyper Estraier API in other
943    languages).
944    
945    =back
946    
947  =cut  =cut
948    
949  sub new {  sub new {
# Line 707  sub new { Line 951  sub new {
951          my $self = {          my $self = {
952                  pxport => -1,                  pxport => -1,
953                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
954                  wwidth => 480,                  wwidth => 480,
955                  hwidth => 96,                  hwidth => 96,
956                  awidth => 96,                  awidth => 96,
957                  status => -1,                  status => -1,
958          };          };
959    
960          bless($self, $class);          bless($self, $class);
961    
962          my $args = {@_};          if ($#_ == 0) {
963                    $self->{url} = shift;
964            } else {
965                    %$self = ( %$self, @_ );
966    
967                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
968    
969                    warn "## Node debug on\n" if ($self->{debug});
970            }
971    
972            $self->{inform} = {
973                    dnum => -1,
974                    wnum => -1,
975                    size => -1.0,
976            };
977    
978          $self->{debug} = $args->{debug};          if ($self->{create}) {
979          warn "## Node debug on\n" if ($self->{debug});                  if (! eval { $self->name } || $@) {
980                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
981                            croak "can't find node name in '$self->{url}'" unless ($name);
982                            my $label = $self->{label} || $name;
983                            $self->master(
984                                    action => 'nodeadd',
985                                    name => $name,
986                                    label => $label,
987                            ) || croak "can't create node $name ($label)";
988                    }
989            }
990    
991          $self ? return $self : return undef;          $self ? return $self : return undef;
992  }  }
# Line 812  Add a document Line 1078  Add a document
1078    
1079    $node->put_doc( $document_draft ) or die "can't add document";    $node->put_doc( $document_draft ) or die "can't add document";
1080    
1081  Return true on success or false on failture.  Return true on success or false on failure.
1082    
1083  =cut  =cut
1084    
# Line 820  sub put_doc { Line 1086  sub put_doc {
1086          my $self = shift;          my $self = shift;
1087          my $doc = shift || return;          my $doc = shift || return;
1088          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1089          $self->shuttle_url( $self->{url} . '/put_doc',          if ($self->shuttle_url( $self->{url} . '/put_doc',
1090                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1091                  $doc->dump_draft,                  $doc->dump_draft,
1092                  undef                  undef
1093          ) == 200;          ) == 200) {
1094                    $self->_clear_info;
1095                    return 1;
1096            }
1097            return undef;
1098  }  }
1099    
1100    
# Line 843  sub out_doc { Line 1113  sub out_doc {
1113          my $id = shift || return;          my $id = shift || return;
1114          return unless ($self->{url});          return unless ($self->{url});
1115          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1116          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1117                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1118                  "id=$id",                  "id=$id",
1119                  undef                  undef
1120          ) == 200;          ) == 200) {
1121                    $self->_clear_info;
1122                    return 1;
1123            }
1124            return undef;
1125  }  }
1126    
1127    
# Line 865  sub out_doc_by_uri { Line 1139  sub out_doc_by_uri {
1139          my $self = shift;          my $self = shift;
1140          my $uri = shift || return;          my $uri = shift || return;
1141          return unless ($self->{url});          return unless ($self->{url});
1142          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1143                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1144                  "uri=" . uri_escape($uri),                  "uri=" . uri_escape($uri),
1145                  undef                  undef
1146          ) == 200;          ) == 200) {
1147                    $self->_clear_info;
1148                    return 1;
1149            }
1150            return undef;
1151  }  }
1152    
1153    
# Line 887  sub edit_doc { Line 1165  sub edit_doc {
1165          my $self = shift;          my $self = shift;
1166          my $doc = shift || return;          my $doc = shift || return;
1167          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1168          $self->shuttle_url( $self->{url} . '/edit_doc',          if ($self->shuttle_url( $self->{url} . '/edit_doc',
1169                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1170                  $doc->dump_draft,                  $doc->dump_draft,
1171                  undef                  undef
1172          ) == 200;          ) == 200) {
1173                    $self->_clear_info;
1174                    return 1;
1175            }
1176            return undef;
1177  }  }
1178    
1179    
# Line 1000  Get ID of document specified by URI Line 1282  Get ID of document specified by URI
1282    
1283    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1284    
1285    This method won't croak, even if using C<croak_on_error>.
1286    
1287  =cut  =cut
1288    
1289  sub uri_to_id {  sub uri_to_id {
1290          my $self = shift;          my $self = shift;
1291          my $uri = shift || return;          my $uri = shift || return;
1292          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 );
1293  }  }
1294    
1295    
# Line 1065  sub _fetch_doc { Line 1349  sub _fetch_doc {
1349                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1350                  $arg,                  $arg,
1351                  \$resbody,                  \$resbody,
1352                    $a->{croak_on_error},
1353          );          );
1354    
1355          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1380  sub _fetch_doc {
1380    
1381  sub name {  sub name {
1382          my $self = shift;          my $self = shift;
1383          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1384          return $self->{name};          return $self->{inform}->{name};
1385  }  }
1386    
1387    
# Line 1108  sub name { Line 1393  sub name {
1393    
1394  sub label {  sub label {
1395          my $self = shift;          my $self = shift;
1396          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1397          return $self->{label};          return $self->{inform}->{label};
1398  }  }
1399    
1400    
# Line 1121  sub label { Line 1406  sub label {
1406    
1407  sub doc_num {  sub doc_num {
1408          my $self = shift;          my $self = shift;
1409          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1410          return $self->{dnum};          return $self->{inform}->{dnum};
1411  }  }
1412    
1413    
# Line 1134  sub doc_num { Line 1419  sub doc_num {
1419    
1420  sub word_num {  sub word_num {
1421          my $self = shift;          my $self = shift;
1422          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1423          return $self->{wnum};          return $self->{inform}->{wnum};
1424  }  }
1425    
1426    
# Line 1147  sub word_num { Line 1432  sub word_num {
1432    
1433  sub size {  sub size {
1434          my $self = shift;          my $self = shift;
1435          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1436          return $self->{size};          return $self->{inform}->{size};
1437  }  }
1438    
1439    
# Line 1176  sub search { Line 1461  sub search {
1461    
1462          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1463                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1464                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1465                  \$resbody,                  \$resbody,
1466          );          );
1467          return if ($rv != 200);          return if ($rv != 200);
1468    
1469          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1470            my $hintsText   = splice @records, 0, 2; # starts with empty record
1471          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1472          return unless (@lines);  
1473            # process records
1474          my $border = $lines[0];          my $docs = [];
1475          my $isend = 0;          foreach my $record (@records)
1476          my $lnum = 1;          {
1477                    # split into keys and snippets
1478          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$/);  
                 }  
   
         }  
1479    
1480          if (! $isend) {                  # create document hash
1481                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1482                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1483                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1484                    $doc->{snippet}         = $snippet;
1485    
1486                    push @$docs, new Search::Estraier::ResultDocument(
1487                            attrs           => $doc,
1488                            uri             => $doc->{'@uri'},
1489                            snippet         => $snippet,
1490                            keywords        => $doc->{'keywords'},
1491                    );
1492          }          }
1493    
1494          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1495  }  }
1496    
1497    
# Line 1270  sub search { Line 1499  sub search {
1499    
1500  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1501    
1502    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1503    
1504  =cut  =cut
1505    
# Line 1279  sub cond_to_query { Line 1508  sub cond_to_query {
1508    
1509          my $cond = shift || return;          my $cond = shift || return;
1510          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'));
1511            my $depth = shift;
1512    
1513          my @args;          my @args;
1514    
# Line 1288  sub cond_to_query { Line 1518  sub cond_to_query {
1518    
1519          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1520                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1521                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1522                  }                  }
1523          }          }
1524    
# Line 1306  sub cond_to_query { Line 1536  sub cond_to_query {
1536                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1537          }          }
1538    
1539          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1540          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1541          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1542          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1543            push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
1544    
1545          return join('&', @args);          return join('&', @args);
1546  }  }
# Line 1317  sub cond_to_query { Line 1548  sub cond_to_query {
1548    
1549  =head2 shuttle_url  =head2 shuttle_url
1550    
1551  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
1552  master.  master.
1553    
1554    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 1558  body will be saved within object.
1558    
1559  =cut  =cut
1560    
1561    use LWP::UserAgent;
1562    
1563  sub shuttle_url {  sub shuttle_url {
1564          my $self = shift;          my $self = shift;
1565    
1566          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1567    
1568            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1569    
1570          $self->{status} = -1;          $self->{status} = -1;
1571    
# Line 1345  sub shuttle_url { Line 1580  sub shuttle_url {
1580                  return -1;                  return -1;
1581          }          }
1582    
1583          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1584            $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;  
1585    
1586            my $req;
1587          if ($reqbody) {          if ($reqbody) {
1588                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1589          } else {          } else {
1590                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1591          }          }
1592    
1593          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1594          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1595          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1596          $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";  
1597    
1598          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,  
         );  
1599    
1600          if (! $sock) {          if ($reqbody) {
1601                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1602                  return -1;                  $req->content( $reqbody );
1603          }          }
1604    
1605          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1606    
1607          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;  
1608    
1609          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;  
         }  
1610    
1611          my $line = <$sock>;          if (! $res->is_success) {
1612          chomp($line);                  if ($croak_on_error) {
1613          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1614          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1615                            return -1;
1616          $self->{status} = $res_status;                  }
1617          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});  
         };  
1618    
1619          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1620    
1621          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1622    
# Line 1490  sub set_user { Line 1687  sub set_user {
1687          croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);          croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1688    
1689          $self->shuttle_url( $self->{url} . '/_set_user',          $self->shuttle_url( $self->{url} . '/_set_user',
1690                  'text/plain',                  'application/x-www-form-urlencoded',
1691                  'name=' . uri_escape($name) . '&mode=' . $mode,                  'name=' . uri_escape($name) . '&mode=' . $mode,
1692                  undef                  undef
1693          ) == 200;          ) == 200;
# Line 1517  sub set_link { Line 1714  sub set_link {
1714          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1715          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1716    
1717          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1718                  'text/plain',                  'application/x-www-form-urlencoded',
1719                  $reqbody,                  $reqbody,
1720                  undef                  undef
1721          ) == 200;          ) == 200) {
1722                    # refresh node info after adding link
1723                    $self->_clear_info;
1724                    return 1;
1725            }
1726            return undef;
1727    }
1728    
1729    =head2 admins
1730    
1731     my @admins = @{ $node->admins };
1732    
1733    Return array of users with admin rights on node
1734    
1735    =cut
1736    
1737    sub admins {
1738            my $self = shift;
1739            $self->_set_info unless ($self->{inform}->{name});
1740            return $self->{inform}->{admins};
1741    }
1742    
1743    =head2 guests
1744    
1745     my @guests = @{ $node->guests };
1746    
1747    Return array of users with guest rights on node
1748    
1749    =cut
1750    
1751    sub guests {
1752            my $self = shift;
1753            $self->_set_info unless ($self->{inform}->{name});
1754            return $self->{inform}->{guests};
1755    }
1756    
1757    =head2 links
1758    
1759     my $links = @{ $node->links };
1760    
1761    Return array of links for this node
1762    
1763    =cut
1764    
1765    sub links {
1766            my $self = shift;
1767            $self->_set_info unless ($self->{inform}->{name});
1768            return $self->{inform}->{links};
1769    }
1770    
1771    =head2 cacheusage
1772    
1773    Return cache usage for a node
1774    
1775      my $cache = $node->cacheusage;
1776    
1777    =cut
1778    
1779    sub cacheusage {
1780            my $self = shift;
1781    
1782            return unless ($self->{url});
1783    
1784            my $resbody;
1785            my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
1786                    'text/plain',
1787                    undef,
1788                    \$resbody,
1789            );
1790    
1791            return if ($rv != 200 || !$resbody);
1792    
1793            return $resbody;
1794  }  }
1795    
1796    =head2 master
1797    
1798    Set actions on Hyper Estraier node master (C<estmaster> process)
1799    
1800      $node->master(
1801            action => 'sync'
1802      );
1803    
1804    All available actions are documented in
1805    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1806    
1807    =cut
1808    
1809    my $estmaster_rest = {
1810            shutdown => {
1811                    status => 202,
1812            },
1813            sync => {
1814                    status => 202,
1815            },
1816            backup => {
1817                    status => 202,
1818            },
1819            userlist => {
1820                    status => 200,
1821                    returns => [ qw/name passwd flags fname misc/ ],
1822            },
1823            useradd => {
1824                    required => [ qw/name passwd flags/ ],
1825                    optional => [ qw/fname misc/ ],
1826                    status => 200,
1827            },
1828            userdel => {
1829                    required => [ qw/name/ ],
1830                    status => 200,
1831            },
1832            nodelist => {
1833                    status => 200,
1834                    returns => [ qw/name label doc_num word_num size/ ],
1835            },
1836            nodeadd => {
1837                    required => [ qw/name/ ],
1838                    optional => [ qw/label/ ],
1839                    status => 200,
1840            },
1841            nodedel => {
1842                    required => [ qw/name/ ],
1843                    status => 200,
1844            },
1845            nodeclr => {
1846                    required => [ qw/name/ ],
1847                    status => 200,
1848            },
1849            nodertt => {
1850                    status => 200,  
1851            },
1852    };
1853    
1854    sub master {
1855            my $self = shift;
1856    
1857            my $args = {@_};
1858    
1859            # have action?
1860            my $action = $args->{action} || croak "need action, available: ",
1861                    join(", ",keys %{ $estmaster_rest });
1862    
1863            # check if action is valid
1864            my $rest = $estmaster_rest->{$action};
1865            croak "action '$action' is not supported, available actions: ",
1866                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1867    
1868            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1869    
1870            my @args;
1871    
1872            if ($rest->{required} || $rest->{optional}) {
1873    
1874                    map {
1875                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1876                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1877                    } ( @{ $rest->{required} } );
1878    
1879                    map {
1880                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1881                    } ( @{ $rest->{optional} } );
1882    
1883            }
1884    
1885            my $uri = new URI( $self->{url} );
1886    
1887            my $resbody;
1888    
1889            my $status = $self->shuttle_url(
1890                    'http://' . $uri->host_port . '/master?action=' . $action ,
1891                    'application/x-www-form-urlencoded',
1892                    join('&', @args),
1893                    \$resbody,
1894                    1,
1895            ) or confess "shuttle_url failed";
1896    
1897            if ($status == $rest->{status}) {
1898    
1899                    # refresh node info after sync
1900                    $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
1901    
1902                    if ($rest->{returns} && wantarray) {
1903    
1904                            my @results;
1905                            my $fields = $#{$rest->{returns}};
1906    
1907                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1908                                    my @e = split(/\t/, $line, $fields + 1);
1909                                    my $row;
1910                                    foreach my $i ( 0 .. $fields) {
1911                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1912                                    }
1913                                    push @results, $row;
1914                            }
1915    
1916                            return @results;
1917    
1918                    } elsif ($resbody) {
1919                            chomp $resbody;
1920                            return $resbody;
1921                    } else {
1922                            return 0E0;
1923                    }
1924            }
1925    
1926            carp "expected status $rest->{status}, but got $status";
1927            return undef;
1928    }
1929    
1930  =head1 PRIVATE METHODS  =head1 PRIVATE METHODS
1931    
# Line 1552  sub _set_info { Line 1954  sub _set_info {
1954    
1955          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1956    
1957          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1958          $resbody =~ s/[\r\n]+$//;  
1959            $self->_clear_info;
1960    
1961            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1962                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1963    
1964            return $resbody unless (@lines);
1965    
1966            shift @lines;
1967    
1968          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          while(my $admin = shift @lines) {
1969                  split(/\t/, $resbody, 5);                  push @{$self->{inform}->{admins}}, $admin;
1970            }
1971    
1972            while(my $guest = shift @lines) {
1973                    push @{$self->{inform}->{guests}}, $guest;
1974            }
1975    
1976            while(my $link = shift @lines) {
1977                    push @{$self->{inform}->{links}}, $link;
1978            }
1979    
1980            return $resbody;
1981    
1982  }  }
1983    
1984    =head2 _clear_info
1985    
1986    Clear information for node
1987    
1988      $node->_clear_info;
1989    
1990    On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
1991    info will be fetch again from Hyper Estraier.
1992    
1993    =cut
1994    sub _clear_info {
1995            my $self = shift;
1996            $self->{inform} = {
1997                    dnum => -1,
1998                    wnum => -1,
1999                    size => -1.0,
2000            };
2001    }
2002    
2003  ###  ###
2004    
2005  =head1 EXPORT  =head1 EXPORT
# Line 1572  L<http://hyperestraier.sourceforge.net/> Line 2012  L<http://hyperestraier.sourceforge.net/>
2012    
2013  Hyper Estraier Ruby interface on which this module is based.  Hyper Estraier Ruby interface on which this module is based.
2014    
2015    Hyper Estraier now also has pure-perl binding included in distribution. It's
2016    a faster way to access databases directly if you are not running
2017    C<estmaster> P2P server.
2018    
2019  =head1 AUTHOR  =head1 AUTHOR
2020    
2021  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
2022    
2023    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
2024    
2025  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
2026    
Legend:
Removed from v.58  
changed lines
  Added in v.164
  ViewVC Help
Powered by ViewVC 1.1.26