/[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 139 by dpavlin, Wed May 10 13:45:08 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_1';
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                    eval {
955                            $self->name;
956                    };
957                    if ($@) {
958                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
959                            croak "can't find node name in '$self->{url}'" unless ($name);
960                            my $label = $self->{label} || $name;
961                            $self->master(
962                                    action => 'nodeadd',
963                                    name => $name,
964                                    label => $label,
965                            ) || croak "can't create node $name ($label)";
966                    }
967          }          }
968    
969          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 1111  sub out_doc_by_uri {
1111          return unless ($self->{url});          return unless ($self->{url});
1112          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1113                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1114                  "uri=$uri",                  "uri=" . uri_escape($uri),
1115                  undef                  undef
1116          ) == 200;          ) == 200;
1117  }  }
# Line 928  sub get_doc_by_uri { Line 1173  sub get_doc_by_uri {
1173  }  }
1174    
1175    
1176    =head2 get_doc_attr
1177    
1178    Retrieve the value of an atribute from object
1179    
1180      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1181            die "can't get document attribute";
1182    
1183    =cut
1184    
1185    sub get_doc_attr {
1186            my $self = shift;
1187            my ($id,$name) = @_;
1188            return unless ($id && $name);
1189            return $self->_fetch_doc( id => $id, attr => $name );
1190    }
1191    
1192    
1193    =head2 get_doc_attr_by_uri
1194    
1195    Retrieve the value of an atribute from object
1196    
1197      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1198            die "can't get document attribute";
1199    
1200    =cut
1201    
1202    sub get_doc_attr_by_uri {
1203            my $self = shift;
1204            my ($uri,$name) = @_;
1205            return unless ($uri && $name);
1206            return $self->_fetch_doc( uri => $uri, attr => $name );
1207    }
1208    
1209    
1210  =head2 etch_doc  =head2 etch_doc
1211    
1212  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1215  Exctract document keywords
1215    
1216  =cut  =cut
1217    
1218  sub erch_doc {  sub etch_doc {
1219          my $self = shift;          my $self = shift;
1220          my $id = shift || return;          my $id = shift || return;
1221          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 1244  Get ID of document specified by URI
1244    
1245    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1246    
1247    This method won't croak, even if using C<croak_on_error>.
1248    
1249  =cut  =cut
1250    
1251  sub uri_to_id {  sub uri_to_id {
1252          my $self = shift;          my $self = shift;
1253          my $uri = shift || return;          my $uri = shift || return;
1254          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 );
1255  }  }
1256    
1257    
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1268  C<etch_doc>, C<etch_doc_by_uri>.
1268   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1269   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1270    
1271     # to get document attrubute add attr
1272     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1273     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1274    
1275   # more general form which allows implementation of   # more general form which allows implementation of
1276   # uri_to_id   # uri_to_id
1277   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1296  sub _fetch_doc {
1296                  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+$/);
1297                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1298          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1299                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1300          } else {          } else {
1301                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1302          }          }
1303    
1304            if ($a->{attr}) {
1305                    $path = '/get_doc_attr';
1306                    $arg .= '&attr=' . uri_escape($a->{attr});
1307                    $a->{chomp_resbody} = 1;
1308            }
1309    
1310          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1311                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1312                  $arg,                  $arg,
1313                  \$resbody,                  \$resbody,
1314                    $a->{croak_on_error},
1315          );          );
1316    
1317          return if ($rv != 200);          return if ($rv != 200);
# Line 1042  sub _fetch_doc { Line 1334  sub _fetch_doc {
1334  }  }
1335    
1336    
1337    =head2 name
1338    
1339      my $node_name = $node->name;
1340    
1341    =cut
1342    
1343    sub name {
1344            my $self = shift;
1345            $self->_set_info unless ($self->{inform}->{name});
1346            return $self->{inform}->{name};
1347    }
1348    
1349    
1350    =head2 label
1351    
1352      my $node_label = $node->label;
1353    
1354    =cut
1355    
1356    sub label {
1357            my $self = shift;
1358            $self->_set_info unless ($self->{inform}->{label});
1359            return $self->{inform}->{label};
1360    }
1361    
1362    
1363    =head2 doc_num
1364    
1365      my $documents_in_node = $node->doc_num;
1366    
1367    =cut
1368    
1369    sub doc_num {
1370            my $self = shift;
1371            $self->_set_info if ($self->{inform}->{dnum} < 0);
1372            return $self->{inform}->{dnum};
1373    }
1374    
1375    
1376    =head2 word_num
1377    
1378      my $words_in_node = $node->word_num;
1379    
1380    =cut
1381    
1382    sub word_num {
1383            my $self = shift;
1384            $self->_set_info if ($self->{inform}->{wnum} < 0);
1385            return $self->{inform}->{wnum};
1386    }
1387    
1388    
1389    =head2 size
1390    
1391      my $node_size = $node->size;
1392    
1393    =cut
1394    
1395    sub size {
1396            my $self = shift;
1397            $self->_set_info if ($self->{inform}->{size} < 0);
1398            return $self->{inform}->{size};
1399    }
1400    
1401    
1402    =head2 search
1403    
1404    Search documents which match condition
1405    
1406      my $nres = $node->search( $cond, $depth );
1407    
1408    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1409    depth for meta search.
1410    
1411    Function results C<Search::Estraier::NodeResult> object.
1412    
1413    =cut
1414    
1415    sub search {
1416            my $self = shift;
1417            my ($cond, $depth) = @_;
1418            return unless ($cond && defined($depth) && $self->{url});
1419            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1420            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1421    
1422            my $resbody;
1423    
1424            my $rv = $self->shuttle_url( $self->{url} . '/search',
1425                    'application/x-www-form-urlencoded',
1426                    $self->cond_to_query( $cond, $depth ),
1427                    \$resbody,
1428            );
1429            return if ($rv != 200);
1430    
1431            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1432            my $hintsText   = splice @records, 0, 2; # starts with empty record
1433            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1434    
1435            # process records
1436            my $docs = [];
1437            foreach my $record (@records)
1438            {
1439                    # split into keys and snippets
1440                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1441    
1442                    # create document hash
1443                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1444                    $doc->{'@keywords'}     = $doc->{keywords};
1445                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1446                    $doc->{snippet}         = $snippet;
1447    
1448                    push @$docs, new Search::Estraier::ResultDocument(
1449                            attrs           => $doc,
1450                            uri             => $doc->{'@uri'},
1451                            snippet         => $snippet,
1452                            keywords        => $doc->{'keywords'},
1453                    );
1454            }
1455    
1456            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1457    }
1458    
1459    
1460    =head2 cond_to_query
1461    
1462    Return URI encoded string generated from Search::Estraier::Condition
1463    
1464      my $args = $node->cond_to_query( $cond, $depth );
1465    
1466    =cut
1467    
1468    sub cond_to_query {
1469            my $self = shift;
1470    
1471            my $cond = shift || return;
1472            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1473            my $depth = shift;
1474    
1475            my @args;
1476    
1477            if (my $phrase = $cond->phrase) {
1478                    push @args, 'phrase=' . uri_escape($phrase);
1479            }
1480    
1481            if (my @attrs = $cond->attrs) {
1482                    for my $i ( 0 .. $#attrs ) {
1483                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1484                    }
1485            }
1486    
1487            if (my $order = $cond->order) {
1488                    push @args, 'order=' . uri_escape($order);
1489            }
1490                    
1491            if (my $max = $cond->max) {
1492                    push @args, 'max=' . $max;
1493            } else {
1494                    push @args, 'max=' . (1 << 30);
1495            }
1496    
1497            if (my $options = $cond->options) {
1498                    push @args, 'options=' . $options;
1499            }
1500    
1501            push @args, 'depth=' . $depth if ($depth);
1502            push @args, 'wwidth=' . $self->{wwidth};
1503            push @args, 'hwidth=' . $self->{hwidth};
1504            push @args, 'awidth=' . $self->{awidth};
1505            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1506    
1507            return join('&', @args);
1508    }
1509    
1510    
1511  =head2 shuttle_url  =head2 shuttle_url
1512    
1513  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
1514  master.  master.
1515    
1516    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1517    
1518  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
1519  body will be saved within object.  body will be saved within object.
1520    
1521  =cut  =cut
1522    
1523    use LWP::UserAgent;
1524    
1525  sub shuttle_url {  sub shuttle_url {
1526          my $self = shift;          my $self = shift;
1527    
1528          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1529    
1530            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1531    
1532          $self->{status} = -1;          $self->{status} = -1;
1533    
# Line 1074  sub shuttle_url { Line 1542  sub shuttle_url {
1542                  return -1;                  return -1;
1543          }          }
1544    
1545          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1546            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1547    
1548          if ($self->{pxhost}) {          my $req;
1549                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1550                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1551            } else {
1552                    $req = HTTP::Request->new(GET => $url);
1553          }          }
1554    
1555          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1556            $req->headers->header( 'Connection', 'close' );
1557            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1558            $req->content_type( $content_type );
1559    
1560          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1561    
1562          if ($reqbody) {          if ($reqbody) {
1563                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1564          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1565          }          }
1566    
1567          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1568          $headers .= "Connection: close\r\n";  
1569          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1570          $headers .= "Content-Type: $content_type\r\n";  
1571          $headers .= "Authorization: Basic $self->{auth}\r\n";          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1572          my $len = 0;  
1573          {          if (! $res->is_success) {
1574                  use bytes;                  if ($croak_on_error) {
1575                  $len = length($reqbody) if ($reqbody);                          croak("can't get $url: ",$res->status_line);
1576                    } else {
1577                            return -1;
1578                    }
1579          }          }
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
1580    
1581          my $sock = IO::Socket::INET->new(          $$resbody .= $res->content;
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1582    
1583          if (! $sock) {          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1584                  carp "can't open socket to $host:$port";  
1585                  return -1;          return $self->{status};
1586    }
1587    
1588    
1589    =head2 set_snippet_width
1590    
1591    Set width of snippets in results
1592    
1593      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1594    
1595    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1596    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1597    
1598    C<$hwidth> specified width of strings from beginning of string. Default
1599    value is C<96>. Negative or zero value keep previous value.
1600    
1601    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1602    If negative of zero value is provided previous value is kept unchanged.
1603    
1604    =cut
1605    
1606    sub set_snippet_width {
1607            my $self = shift;
1608    
1609            my ($wwidth, $hwidth, $awidth) = @_;
1610            $self->{wwidth} = $wwidth;
1611            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1612            $self->{awidth} = $awidth if ($awidth >= 0);
1613    }
1614    
1615    
1616    =head2 set_user
1617    
1618    Manage users of node
1619    
1620      $node->set_user( 'name', $mode );
1621    
1622    C<$mode> can be one of:
1623    
1624    =over 4
1625    
1626    =item 0
1627    
1628    delete account
1629    
1630    =item 1
1631    
1632    set administrative right for user
1633    
1634    =item 2
1635    
1636    set user account as guest
1637    
1638    =back
1639    
1640    Return true on success, otherwise false.
1641    
1642    =cut
1643    
1644    sub set_user {
1645            my $self = shift;
1646            my ($name, $mode) = @_;
1647    
1648            return unless ($self->{url});
1649            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1650    
1651            $self->shuttle_url( $self->{url} . '/_set_user',
1652                    'text/plain',
1653                    'name=' . uri_escape($name) . '&mode=' . $mode,
1654                    undef
1655            ) == 200;
1656    }
1657    
1658    
1659    =head2 set_link
1660    
1661    Manage node links
1662    
1663      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1664    
1665    If C<$credit> is negative, link is removed.
1666    
1667    =cut
1668    
1669    sub set_link {
1670            my $self = shift;
1671            my ($url, $label, $credit) = @_;
1672    
1673            return unless ($self->{url});
1674            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1675    
1676            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1677            $reqbody .= '&credit=' . $credit if ($credit > 0);
1678    
1679            if ($self->shuttle_url( $self->{url} . '/_set_link',
1680                    'application/x-www-form-urlencoded',
1681                    $reqbody,
1682                    undef
1683            ) == 200) {
1684                    # refresh node info after adding link
1685                    $self->_set_info;
1686                    return 1;
1687          }          }
1688    }
1689    
1690          warn $headers if ($self->{debug});  =head2 admins
1691    
1692          print $sock $headers or   my @admins = @{ $node->admins };
1693                  carp "can't send headers to network:\n$headers\n" and return -1;  
1694    Return array of users with admin rights on node
1695    
1696    =cut
1697    
1698    sub admins {
1699            my $self = shift;
1700            $self->_set_info unless ($self->{inform}->{name});
1701            return $self->{inform}->{admins};
1702    }
1703    
1704    =head2 guests
1705    
1706     my @guests = @{ $node->guests };
1707    
1708    Return array of users with guest rights on node
1709    
1710    =cut
1711    
1712    sub guests {
1713            my $self = shift;
1714            $self->_set_info unless ($self->{inform}->{name});
1715            return $self->{inform}->{guests};
1716    }
1717    
1718    =head2 links
1719    
1720     my $links = @{ $node->links };
1721    
1722    Return array of links for this node
1723    
1724    =cut
1725    
1726    sub links {
1727            my $self = shift;
1728            $self->_set_info unless ($self->{inform}->{name});
1729            return $self->{inform}->{links};
1730    }
1731    
1732    =head2 master
1733    
1734    Set actions on Hyper Estraier node master (C<estmaster> process)
1735    
1736      $node->master(
1737            action => 'sync'
1738      );
1739    
1740    All available actions are documented in
1741    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1742    
1743    =cut
1744    
1745    my $estmaster_rest = {
1746            shutdown => {
1747                    status => 202,
1748            },
1749            sync => {
1750                    status => 202,
1751            },
1752            backup => {
1753                    status => 202,
1754            },
1755            userlist => {
1756                    status => 200,
1757                    returns => [ qw/name passwd flags fname misc/ ],
1758            },
1759            useradd => {
1760                    required => [ qw/name passwd flags/ ],
1761                    optional => [ qw/fname misc/ ],
1762                    status => 200,
1763            },
1764            userdel => {
1765                    required => [ qw/name/ ],
1766                    status => 200,
1767            },
1768            nodelist => {
1769                    status => 200,
1770                    returns => [ qw/name label doc_num word_num size/ ],
1771            },
1772            nodeadd => {
1773                    required => [ qw/name/ ],
1774                    optional => [ qw/label/ ],
1775                    status => 200,
1776            },
1777            nodedel => {
1778                    required => [ qw/name/ ],
1779                    status => 200,
1780            },
1781            nodeclr => {
1782                    required => [ qw/name/ ],
1783                    status => 200,
1784            },
1785            nodertt => {
1786                    status => 200,  
1787            },
1788    };
1789    
1790    sub master {
1791            my $self = shift;
1792    
1793            my $args = {@_};
1794    
1795            # have action?
1796            my $action = $args->{action} || croak "need action, available: ",
1797                    join(", ",keys %{ $estmaster_rest });
1798    
1799            # check if action is valid
1800            my $rest = $estmaster_rest->{$action};
1801            croak "action '$action' is not supported, available actions: ",
1802                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1803    
1804            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1805    
1806            my @args;
1807    
1808            if ($rest->{required} || $rest->{optional}) {
1809    
1810                    map {
1811                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1812                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1813                    } ( @{ $rest->{required} } );
1814    
1815                    map {
1816                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1817                    } ( @{ $rest->{optional} } );
1818    
         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;  
1819          }          }
1820    
1821          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});  
         };  
1822    
1823          # read body          my $resbody;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1824    
1825          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          my $status = $self->shuttle_url(
1826                    'http://' . $uri->host_port . '/master?action=' . $action ,
1827                    'application/x-www-form-urlencoded',
1828                    join('&', @args),
1829                    \$resbody,
1830                    1,
1831            ) or confess "shuttle_url failed";
1832    
1833            if ($status == $rest->{status}) {
1834                    if ($rest->{returns} && wantarray) {
1835    
1836                            my @results;
1837                            my $fields = $#{$rest->{returns}};
1838    
1839                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1840                                    my @e = split(/\t/, $line, $fields + 1);
1841                                    my $row;
1842                                    foreach my $i ( 0 .. $fields) {
1843                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1844                                    }
1845                                    push @results, $row;
1846                            }
1847    
1848                            return @results;
1849    
1850                    } elsif ($resbody) {
1851                            chomp $resbody;
1852                            return $resbody;
1853                    } else {
1854                            return 0E0;
1855                    }
1856            }
1857    
1858            carp "expected status $rest->{status}, but got $status";
1859            return undef;
1860    }
1861    
1862    =head1 PRIVATE METHODS
1863    
1864    You could call those directly, but you don't have to. I hope.
1865    
1866    =head2 _set_info
1867    
1868    Set information for node
1869    
1870      $node->_set_info;
1871    
1872    =cut
1873    
1874    sub _set_info {
1875            my $self = shift;
1876    
1877            $self->{status} = -1;
1878            return unless ($self->{url});
1879    
1880            my $resbody;
1881            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1882                    'text/plain',
1883                    undef,
1884                    \$resbody,
1885            );
1886    
1887            return if ($rv != 200 || !$resbody);
1888    
1889            my @lines = split(/[\r\n]/,$resbody);
1890    
1891            $self->{inform} = {};
1892    
1893            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1894                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1895    
1896            return $resbody unless (@lines);
1897    
1898            shift @lines;
1899    
1900            while(my $admin = shift @lines) {
1901                    push @{$self->{inform}->{admins}}, $admin;
1902            }
1903    
1904            while(my $guest = shift @lines) {
1905                    push @{$self->{inform}->{guests}}, $guest;
1906            }
1907    
1908            while(my $link = shift @lines) {
1909                    push @{$self->{inform}->{links}}, $link;
1910            }
1911    
1912            return $resbody;
1913    
         return $self->{status};  
1914  }  }
1915    
1916  ###  ###
# Line 1171  Hyper Estraier Ruby interface on which t Line 1929  Hyper Estraier Ruby interface on which t
1929    
1930  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1931    
1932    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1933    
1934  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1935    
Legend:
Removed from v.47  
changed lines
  Added in v.139
  ViewVC Help
Powered by ViewVC 1.1.26