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