/[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 47 by dpavlin, Fri Jan 6 01:51:28 2006 UTC revision 142 by dpavlin, Wed May 10 14:57:50 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.06';
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 106  sub new { Line 169  sub new {
169                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
170                                  $in_text = 1;                                  $in_text = 1;
171                                  next;                                  next;
172                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
173                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
174                                  next;                                  next;
175                          }                          }
176    
177                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
178                  }                  }
179          }          }
180    
# Line 205  Returns array with attribute names from Line 268  Returns array with attribute names from
268    
269  sub attr_names {  sub attr_names {
270          my $self = shift;          my $self = shift;
271          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
272            #croak "attr_names return array, not scalar" if (! wantarray);
273          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
274  }  }
275    
# Line 221  Returns value of an attribute. Line 285  Returns value of an attribute.
285  sub attr {  sub attr {
286          my $self = shift;          my $self = shift;
287          my $name = shift;          my $name = shift;
288            return unless (defined($name) && $self->{attrs});
289          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
290  }  }
291    
292    
# Line 236  Returns array with text sentences. Line 300  Returns array with text sentences.
300    
301  sub texts {  sub texts {
302          my $self = shift;          my $self = shift;
303          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
304          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
305  }  }
306    
307    
# Line 251  Return whole text as single scalar. Line 315  Return whole text as single scalar.
315    
316  sub cat_texts {  sub cat_texts {
317          my $self = shift;          my $self = shift;
318          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
319  }  }
320    
321    
# Line 268  sub dump_draft { Line 332  sub dump_draft {
332          my $draft;          my $draft;
333    
334          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
335                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
336                    $draft .= $attr_name . '=' . $v . "\n";
337          }          }
338    
339          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 381  sub delete {
381    
382  package Search::Estraier::Condition;  package Search::Estraier::Condition;
383    
384  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
385    
386  use Search::Estraier;  use Search::Estraier;
387  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 459  sub set_max {
459    
460  =head2 set_options  =head2 set_options
461    
462    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
463    
464      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
465    
466    Possible options are:
467    
468    =over 8
469    
470    =item SURE
471    
472    check every N-gram
473    
474    =item USUAL
475    
476    check every second N-gram
477    
478    =item FAST
479    
480    check every third N-gram
481    
482    =item AGITO
483    
484    check every fourth N-gram
485    
486    =item NOIDF
487    
488    don't perform TF-IDF tuning
489    
490    =item SIMPLE
491    
492    use simplified query phrase
493    
494    =back
495    
496    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
497    options;
498    
499    This option changed in version C<0.04> of this module. It's backwards compatibile.
500    
501  =cut  =cut
502    
503  my $options = {  my $options = {
         # check N-gram keys skipping by three  
504          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
505          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
506          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
507          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
508          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
509          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
510  };  };
511    
512  sub set_options {  sub set_options {
513          my $self = shift;          my $self = shift;
514          my $option = shift;          my $opt = 0;
515          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
516          $self->{options} ||= $options->{$option};                  my $mask;
517                    unless ($mask = $options->{$option}) {
518                            if ($option eq '1') {
519                                    next;
520                            } else {
521                                    croak "unknown option $option";
522                            }
523                    }
524                    $opt += $mask;
525            }
526            $self->{options} = $opt;
527  }  }
528    
529    
# Line 460  Return search result attrs. Line 566  Return search result attrs.
566  sub attrs {  sub attrs {
567          my $self = shift;          my $self = shift;
568          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
569          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
570  }  }
571    
572    
# Line 496  sub options { Line 602  sub options {
602  }  }
603    
604    
605    =head2 set_skip
606    
607    Set number of skipped documents from beginning of results
608    
609      $cond->set_skip(42);
610    
611    Similar to C<offset> in RDBMS.
612    
613    =cut
614    
615    sub set_skip {
616            my $self = shift;
617            $self->{skip} = shift;
618    }
619    
620    =head2 skip
621    
622    Return skip for this condition.
623    
624      print $cond->skip;
625    
626    =cut
627    
628    sub skip {
629            my $self = shift;
630            return $self->{skip};
631    }
632    
633    
634  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
635    
636  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 659  sub new {
659          my $self = {@_};          my $self = {@_};
660          bless($self, $class);          bless($self, $class);
661    
662          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});  
         }  
663    
664          $self ? return $self : return undef;          $self ? return $self : return undef;
665  }  }
# Line 641  Return number of documents Line 774  Return number of documents
774    
775    print $res->doc_num;    print $res->doc_num;
776    
777    This will return real number of documents (limited by C<max>).
778    If you want to get total number of hits, see C<hits>.
779    
780  =cut  =cut
781    
782  sub doc_num {  sub doc_num {
783          my $self = shift;          my $self = shift;
784          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
785  }  }
786    
787    
# Line 672  sub get_doc { Line 808  sub get_doc {
808    
809  Return specific hint from results.  Return specific hint from results.
810    
811    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
812    
813  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>,
814  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 821  sub hint {
821          return $self->{hints}->{$key};          return $self->{hints}->{$key};
822  }  }
823    
824    =head2 hints
825    
826    More perlish version of C<hint>. This one returns hash.
827    
828      my %hints = $res->hints;
829    
830    =cut
831    
832    sub hints {
833            my $self = shift;
834            return $self->{hints};
835    }
836    
837    =head2 hits
838    
839    Syntaxtic sugar for total number of hits for this query
840    
841      print $res->hits;
842    
843    It's same as
844    
845      print $res->hint('HIT');
846    
847    but shorter.
848    
849    =cut
850    
851    sub hits {
852            my $self = shift;
853            return $self->{hints}->{'HIT'} || 0;
854    }
855    
856  package Search::Estraier::Node;  package Search::Estraier::Node;
857    
# Line 692  use Carp qw/carp croak confess/; Line 859  use Carp qw/carp croak confess/;
859  use URI;  use URI;
860  use MIME::Base64;  use MIME::Base64;
861  use IO::Socket::INET;  use IO::Socket::INET;
862    use URI::Escape qw/uri_escape/;
863    
864  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
865    
# Line 699  use IO::Socket::INET; Line 867  use IO::Socket::INET;
867    
868    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
869    
870    or optionally with C<url> as parametar
871    
872      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
873    
874    or in more verbose form
875    
876      my $node = new Search::HyperEstraier::Node(
877            url => 'http://localhost:1978/node/test',
878            user => 'admin',
879            passwd => 'admin'
880            create => 1,
881            label => 'optional node label',
882            debug => 1,
883            croak_on_error => 1
884      );
885    
886    with following arguments:
887    
888    =over 4
889    
890    =item url
891    
892    URL to node
893    
894    =item user
895    
896    specify username for node server authentication
897    
898    =item passwd
899    
900    password for authentication
901    
902    =item create
903    
904    create node if it doesn't exists
905    
906    =item label
907    
908    optional label for new node if C<create> is used
909    
910    =item debug
911    
912    dumps a B<lot> of debugging output
913    
914    =item croak_on_error
915    
916    very helpful during development. It will croak on all errors instead of
917    silently returning C<-1> (which is convention of Hyper Estraier API in other
918    languages).
919    
920    =back
921    
922  =cut  =cut
923    
924  sub new {  sub new {
# Line 706  sub new { Line 926  sub new {
926          my $self = {          my $self = {
927                  pxport => -1,                  pxport => -1,
928                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
929                  wwidth => 480,                  wwidth => 480,
930                  hwidth => 96,                  hwidth => 96,
931                  awidth => 96,                  awidth => 96,
932                  status => -1,                  status => -1,
933          };          };
934    
935          bless($self, $class);          bless($self, $class);
936    
937          if (@_) {          if ($#_ == 0) {
938                  $self->{debug} = shift;                  $self->{url} = shift;
939                  warn "## Node debug on\n";          } else {
940                    %$self = ( %$self, @_ );
941    
942                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
943    
944                    warn "## Node debug on\n" if ($self->{debug});
945            }
946    
947            $self->{inform} = {
948                    dnum => -1,
949                    wnum => -1,
950                    size => -1.0,
951            };
952    
953            if ($self->{create}) {
954                    if (! eval { $self->name } || $@) {
955                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
956                            croak "can't find node name in '$self->{url}'" unless ($name);
957                            my $label = $self->{label} || $name;
958                            $self->master(
959                                    action => 'nodeadd',
960                                    name => $name,
961                                    label => $label,
962                            ) || croak "can't create node $name ($label)";
963                    }
964          }          }
965    
966          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 1108  sub out_doc_by_uri {
1108          return unless ($self->{url});          return unless ($self->{url});
1109          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1110                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1111                  "uri=$uri",                  "uri=" . uri_escape($uri),
1112                  undef                  undef
1113          ) == 200;          ) == 200;
1114  }  }
# Line 928  sub get_doc_by_uri { Line 1170  sub get_doc_by_uri {
1170  }  }
1171    
1172    
1173    =head2 get_doc_attr
1174    
1175    Retrieve the value of an atribute from object
1176    
1177      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1178            die "can't get document attribute";
1179    
1180    =cut
1181    
1182    sub get_doc_attr {
1183            my $self = shift;
1184            my ($id,$name) = @_;
1185            return unless ($id && $name);
1186            return $self->_fetch_doc( id => $id, attr => $name );
1187    }
1188    
1189    
1190    =head2 get_doc_attr_by_uri
1191    
1192    Retrieve the value of an atribute from object
1193    
1194      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1195            die "can't get document attribute";
1196    
1197    =cut
1198    
1199    sub get_doc_attr_by_uri {
1200            my $self = shift;
1201            my ($uri,$name) = @_;
1202            return unless ($uri && $name);
1203            return $self->_fetch_doc( uri => $uri, attr => $name );
1204    }
1205    
1206    
1207  =head2 etch_doc  =head2 etch_doc
1208    
1209  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1212  Exctract document keywords
1212    
1213  =cut  =cut
1214    
1215  sub erch_doc {  sub etch_doc {
1216          my $self = shift;          my $self = shift;
1217          my $id = shift || return;          my $id = shift || return;
1218          return $self->_fetch_doc( id => $id, etch => 1 );          return $self->_fetch_doc( id => $id, etch => 1 );
# Line 965  Get ID of document specified by URI Line 1241  Get ID of document specified by URI
1241    
1242    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1243    
1244    This method won't croak, even if using C<croak_on_error>.
1245    
1246  =cut  =cut
1247    
1248  sub uri_to_id {  sub uri_to_id {
1249          my $self = shift;          my $self = shift;
1250          my $uri = shift || return;          my $uri = shift || return;
1251          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 );
1252  }  }
1253    
1254    
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1265  C<etch_doc>, C<etch_doc_by_uri>.
1265   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1266   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1267    
1268     # to get document attrubute add attr
1269     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1270     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1271    
1272   # more general form which allows implementation of   # more general form which allows implementation of
1273   # uri_to_id   # uri_to_id
1274   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1293  sub _fetch_doc {
1293                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
1294                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1295          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1296                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1297          } else {          } else {
1298                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1299          }          }
1300    
1301            if ($a->{attr}) {
1302                    $path = '/get_doc_attr';
1303                    $arg .= '&attr=' . uri_escape($a->{attr});
1304                    $a->{chomp_resbody} = 1;
1305            }
1306    
1307          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1308                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1309                  $arg,                  $arg,
1310                  \$resbody,                  \$resbody,
1311                    $a->{croak_on_error},
1312          );          );
1313    
1314          return if ($rv != 200);          return if ($rv != 200);
# Line 1042  sub _fetch_doc { Line 1331  sub _fetch_doc {
1331  }  }
1332    
1333    
1334    =head2 name
1335    
1336      my $node_name = $node->name;
1337    
1338    =cut
1339    
1340    sub name {
1341            my $self = shift;
1342            $self->_set_info unless ($self->{inform}->{name});
1343            return $self->{inform}->{name};
1344    }
1345    
1346    
1347    =head2 label
1348    
1349      my $node_label = $node->label;
1350    
1351    =cut
1352    
1353    sub label {
1354            my $self = shift;
1355            $self->_set_info unless ($self->{inform}->{label});
1356            return $self->{inform}->{label};
1357    }
1358    
1359    
1360    =head2 doc_num
1361    
1362      my $documents_in_node = $node->doc_num;
1363    
1364    =cut
1365    
1366    sub doc_num {
1367            my $self = shift;
1368            $self->_set_info if ($self->{inform}->{dnum} < 0);
1369            return $self->{inform}->{dnum};
1370    }
1371    
1372    
1373    =head2 word_num
1374    
1375      my $words_in_node = $node->word_num;
1376    
1377    =cut
1378    
1379    sub word_num {
1380            my $self = shift;
1381            $self->_set_info if ($self->{inform}->{wnum} < 0);
1382            return $self->{inform}->{wnum};
1383    }
1384    
1385    
1386    =head2 size
1387    
1388      my $node_size = $node->size;
1389    
1390    =cut
1391    
1392    sub size {
1393            my $self = shift;
1394            $self->_set_info if ($self->{inform}->{size} < 0);
1395            return $self->{inform}->{size};
1396    }
1397    
1398    
1399    =head2 search
1400    
1401    Search documents which match condition
1402    
1403      my $nres = $node->search( $cond, $depth );
1404    
1405    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1406    depth for meta search.
1407    
1408    Function results C<Search::Estraier::NodeResult> object.
1409    
1410    =cut
1411    
1412    sub search {
1413            my $self = shift;
1414            my ($cond, $depth) = @_;
1415            return unless ($cond && defined($depth) && $self->{url});
1416            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1417            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1418    
1419            my $resbody;
1420    
1421            my $rv = $self->shuttle_url( $self->{url} . '/search',
1422                    'application/x-www-form-urlencoded',
1423                    $self->cond_to_query( $cond, $depth ),
1424                    \$resbody,
1425            );
1426            return if ($rv != 200);
1427    
1428            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1429            my $hintsText   = splice @records, 0, 2; # starts with empty record
1430            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1431    
1432            # process records
1433            my $docs = [];
1434            foreach my $record (@records)
1435            {
1436                    # split into keys and snippets
1437                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1438    
1439                    # create document hash
1440                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1441                    $doc->{'@keywords'}     = $doc->{keywords};
1442                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1443                    $doc->{snippet}         = $snippet;
1444    
1445                    push @$docs, new Search::Estraier::ResultDocument(
1446                            attrs           => $doc,
1447                            uri             => $doc->{'@uri'},
1448                            snippet         => $snippet,
1449                            keywords        => $doc->{'keywords'},
1450                    );
1451            }
1452    
1453            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1454    }
1455    
1456    
1457    =head2 cond_to_query
1458    
1459    Return URI encoded string generated from Search::Estraier::Condition
1460    
1461      my $args = $node->cond_to_query( $cond, $depth );
1462    
1463    =cut
1464    
1465    sub cond_to_query {
1466            my $self = shift;
1467    
1468            my $cond = shift || return;
1469            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1470            my $depth = shift;
1471    
1472            my @args;
1473    
1474            if (my $phrase = $cond->phrase) {
1475                    push @args, 'phrase=' . uri_escape($phrase);
1476            }
1477    
1478            if (my @attrs = $cond->attrs) {
1479                    for my $i ( 0 .. $#attrs ) {
1480                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1481                    }
1482            }
1483    
1484            if (my $order = $cond->order) {
1485                    push @args, 'order=' . uri_escape($order);
1486            }
1487                    
1488            if (my $max = $cond->max) {
1489                    push @args, 'max=' . $max;
1490            } else {
1491                    push @args, 'max=' . (1 << 30);
1492            }
1493    
1494            if (my $options = $cond->options) {
1495                    push @args, 'options=' . $options;
1496            }
1497    
1498            push @args, 'depth=' . $depth if ($depth);
1499            push @args, 'wwidth=' . $self->{wwidth};
1500            push @args, 'hwidth=' . $self->{hwidth};
1501            push @args, 'awidth=' . $self->{awidth};
1502            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1503    
1504            return join('&', @args);
1505    }
1506    
1507    
1508  =head2 shuttle_url  =head2 shuttle_url
1509    
1510  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
1511  master.  master.
1512    
1513    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1514    
1515  C<$resheads> and C<$resbody> booleans controll if response headers and/or response  C<$resheads> and C<$resbody> booleans controll if response headers and/or response
1516  body will be saved within object.  body will be saved within object.
1517    
1518  =cut  =cut
1519    
1520    use LWP::UserAgent;
1521    
1522  sub shuttle_url {  sub shuttle_url {
1523          my $self = shift;          my $self = shift;
1524    
1525          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1526    
1527            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1528    
1529          $self->{status} = -1;          $self->{status} = -1;
1530    
# Line 1074  sub shuttle_url { Line 1539  sub shuttle_url {
1539                  return -1;                  return -1;
1540          }          }
1541    
1542          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1543            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1544    
1545          if ($self->{pxhost}) {          my $req;
1546                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1547                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1548            } else {
1549                    $req = HTTP::Request->new(GET => $url);
1550          }          }
1551    
1552          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1553            $req->headers->header( 'Connection', 'close' );
1554            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1555            $req->content_type( $content_type );
1556    
1557          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1558    
1559          if ($reqbody) {          if ($reqbody) {
1560                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1561          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1562          }          }
1563    
1564          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1565          $headers .= "Connection: close\r\n";  
1566          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1567          $headers .= "Content-Type: $content_type\r\n";  
1568          $headers .= "Authorization: Basic $self->{auth}\r\n";          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1569          my $len = 0;  
1570          {          if (! $res->is_success) {
1571                  use bytes;                  if ($croak_on_error) {
1572                  $len = length($reqbody) if ($reqbody);                          croak("can't get $url: ",$res->status_line);
1573                    } else {
1574                            return -1;
1575                    }
1576          }          }
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
1577    
1578          my $sock = IO::Socket::INET->new(          $$resbody .= $res->content;
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1579    
1580          if (! $sock) {          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1581                  carp "can't open socket to $host:$port";  
1582                  return -1;          return $self->{status};
1583    }
1584    
1585    
1586    =head2 set_snippet_width
1587    
1588    Set width of snippets in results
1589    
1590      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1591    
1592    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1593    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1594    
1595    C<$hwidth> specified width of strings from beginning of string. Default
1596    value is C<96>. Negative or zero value keep previous value.
1597    
1598    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1599    If negative of zero value is provided previous value is kept unchanged.
1600    
1601    =cut
1602    
1603    sub set_snippet_width {
1604            my $self = shift;
1605    
1606            my ($wwidth, $hwidth, $awidth) = @_;
1607            $self->{wwidth} = $wwidth;
1608            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1609            $self->{awidth} = $awidth if ($awidth >= 0);
1610    }
1611    
1612    
1613    =head2 set_user
1614    
1615    Manage users of node
1616    
1617      $node->set_user( 'name', $mode );
1618    
1619    C<$mode> can be one of:
1620    
1621    =over 4
1622    
1623    =item 0
1624    
1625    delete account
1626    
1627    =item 1
1628    
1629    set administrative right for user
1630    
1631    =item 2
1632    
1633    set user account as guest
1634    
1635    =back
1636    
1637    Return true on success, otherwise false.
1638    
1639    =cut
1640    
1641    sub set_user {
1642            my $self = shift;
1643            my ($name, $mode) = @_;
1644    
1645            return unless ($self->{url});
1646            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1647    
1648            $self->shuttle_url( $self->{url} . '/_set_user',
1649                    'text/plain',
1650                    'name=' . uri_escape($name) . '&mode=' . $mode,
1651                    undef
1652            ) == 200;
1653    }
1654    
1655    
1656    =head2 set_link
1657    
1658    Manage node links
1659    
1660      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1661    
1662    If C<$credit> is negative, link is removed.
1663    
1664    =cut
1665    
1666    sub set_link {
1667            my $self = shift;
1668            my ($url, $label, $credit) = @_;
1669    
1670            return unless ($self->{url});
1671            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1672    
1673            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1674            $reqbody .= '&credit=' . $credit if ($credit > 0);
1675    
1676            if ($self->shuttle_url( $self->{url} . '/_set_link',
1677                    'application/x-www-form-urlencoded',
1678                    $reqbody,
1679                    undef
1680            ) == 200) {
1681                    # refresh node info after adding link
1682                    $self->_set_info;
1683                    return 1;
1684          }          }
1685    }
1686    
1687          warn $headers if ($self->{debug});  =head2 admins
1688    
1689          print $sock $headers or   my @admins = @{ $node->admins };
1690                  carp "can't send headers to network:\n$headers\n" and return -1;  
1691    Return array of users with admin rights on node
1692    
1693    =cut
1694    
1695    sub admins {
1696            my $self = shift;
1697            $self->_set_info unless ($self->{inform}->{name});
1698            return $self->{inform}->{admins};
1699    }
1700    
1701    =head2 guests
1702    
1703     my @guests = @{ $node->guests };
1704    
1705    Return array of users with guest rights on node
1706    
1707    =cut
1708    
1709    sub guests {
1710            my $self = shift;
1711            $self->_set_info unless ($self->{inform}->{name});
1712            return $self->{inform}->{guests};
1713    }
1714    
1715    =head2 links
1716    
1717     my $links = @{ $node->links };
1718    
1719    Return array of links for this node
1720    
1721    =cut
1722    
1723    sub links {
1724            my $self = shift;
1725            $self->_set_info unless ($self->{inform}->{name});
1726            return $self->{inform}->{links};
1727    }
1728    
1729    =head2 master
1730    
1731    Set actions on Hyper Estraier node master (C<estmaster> process)
1732    
1733      $node->master(
1734            action => 'sync'
1735      );
1736    
1737    All available actions are documented in
1738    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1739    
1740    =cut
1741    
1742    my $estmaster_rest = {
1743            shutdown => {
1744                    status => 202,
1745            },
1746            sync => {
1747                    status => 202,
1748            },
1749            backup => {
1750                    status => 202,
1751            },
1752            userlist => {
1753                    status => 200,
1754                    returns => [ qw/name passwd flags fname misc/ ],
1755            },
1756            useradd => {
1757                    required => [ qw/name passwd flags/ ],
1758                    optional => [ qw/fname misc/ ],
1759                    status => 200,
1760            },
1761            userdel => {
1762                    required => [ qw/name/ ],
1763                    status => 200,
1764            },
1765            nodelist => {
1766                    status => 200,
1767                    returns => [ qw/name label doc_num word_num size/ ],
1768            },
1769            nodeadd => {
1770                    required => [ qw/name/ ],
1771                    optional => [ qw/label/ ],
1772                    status => 200,
1773            },
1774            nodedel => {
1775                    required => [ qw/name/ ],
1776                    status => 200,
1777            },
1778            nodeclr => {
1779                    required => [ qw/name/ ],
1780                    status => 200,
1781            },
1782            nodertt => {
1783                    status => 200,  
1784            },
1785    };
1786    
1787    sub master {
1788            my $self = shift;
1789    
1790            my $args = {@_};
1791    
1792            # have action?
1793            my $action = $args->{action} || croak "need action, available: ",
1794                    join(", ",keys %{ $estmaster_rest });
1795    
1796            # check if action is valid
1797            my $rest = $estmaster_rest->{$action};
1798            croak "action '$action' is not supported, available actions: ",
1799                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1800    
1801            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1802    
1803            my @args;
1804    
1805            if ($rest->{required} || $rest->{optional}) {
1806    
1807                    map {
1808                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1809                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1810                    } ( @{ $rest->{required} } );
1811    
1812                    map {
1813                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1814                    } ( @{ $rest->{optional} } );
1815    
         if ($reqbody) {  
                 warn "$reqbody\n" if ($self->{debug});  
                 print $sock $reqbody or  
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
1816          }          }
1817    
1818          my $line = <$sock>;          my $uri = new URI( $self->{url} );
         chomp($line);  
         my ($schema, $res_status, undef) = split(/  */, $line, 3);  
         return if ($schema !~ /^HTTP/ || ! $res_status);  
   
         $self->{status} = $res_status;  
         warn "## response status: $res_status\n" if ($self->{debug});  
   
         # skip rest of headers  
         $line = <$sock>;  
         while ($line) {  
                 $line = <$sock>;  
                 $line =~ s/[\r\n]+$//;  
                 warn "## ", $line || 'NULL', " ##\n" if ($self->{debug});  
         };  
1819    
1820          # read body          my $resbody;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1821    
1822          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          my $status = $self->shuttle_url(
1823                    'http://' . $uri->host_port . '/master?action=' . $action ,
1824                    'application/x-www-form-urlencoded',
1825                    join('&', @args),
1826                    \$resbody,
1827                    1,
1828            ) or confess "shuttle_url failed";
1829    
1830            if ($status == $rest->{status}) {
1831                    if ($rest->{returns} && wantarray) {
1832    
1833                            my @results;
1834                            my $fields = $#{$rest->{returns}};
1835    
1836                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1837                                    my @e = split(/\t/, $line, $fields + 1);
1838                                    my $row;
1839                                    foreach my $i ( 0 .. $fields) {
1840                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1841                                    }
1842                                    push @results, $row;
1843                            }
1844    
1845                            return @results;
1846    
1847                    } elsif ($resbody) {
1848                            chomp $resbody;
1849                            return $resbody;
1850                    } else {
1851                            return 0E0;
1852                    }
1853            }
1854    
1855            carp "expected status $rest->{status}, but got $status";
1856            return undef;
1857    }
1858    
1859    =head1 PRIVATE METHODS
1860    
1861    You could call those directly, but you don't have to. I hope.
1862    
1863    =head2 _set_info
1864    
1865    Set information for node
1866    
1867      $node->_set_info;
1868    
1869    =cut
1870    
1871    sub _set_info {
1872            my $self = shift;
1873    
1874            $self->{status} = -1;
1875            return unless ($self->{url});
1876    
1877            my $resbody;
1878            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1879                    'text/plain',
1880                    undef,
1881                    \$resbody,
1882            );
1883    
1884            return if ($rv != 200 || !$resbody);
1885    
1886            my @lines = split(/[\r\n]/,$resbody);
1887    
1888            $self->{inform} = {};
1889    
1890            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1891                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1892    
1893            return $resbody unless (@lines);
1894    
1895            shift @lines;
1896    
1897            while(my $admin = shift @lines) {
1898                    push @{$self->{inform}->{admins}}, $admin;
1899            }
1900    
1901            while(my $guest = shift @lines) {
1902                    push @{$self->{inform}->{guests}}, $guest;
1903            }
1904    
1905            while(my $link = shift @lines) {
1906                    push @{$self->{inform}->{links}}, $link;
1907            }
1908    
1909            return $resbody;
1910    
         return $self->{status};  
1911  }  }
1912    
1913  ###  ###
# Line 1171  Hyper Estraier Ruby interface on which t Line 1926  Hyper Estraier Ruby interface on which t
1926    
1927  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1928    
1929    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1930    
1931  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1932    
Legend:
Removed from v.47  
changed lines
  Added in v.142
  ViewVC Help
Powered by ViewVC 1.1.26