/[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 135 by dpavlin, Tue May 9 12:42:39 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            );
25    
26            # create document
27            my $doc = new Search::Estraier::Document;
28    
29            # add attributes
30            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
31            $doc->add_attr('@title', "Over the Rainbow");
32    
33            # add body text to document
34            $doc->add_text("Somewhere over the rainbow.  Way up high.");
35            $doc->add_text("There's a land that I heard of once in a lullaby.");
36    
37            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
38    
39    =head2 Simple searcher
40    
41            use Search::Estraier;
42    
43            # create and configure node
44            my $node = new Search::Estraier::Node(
45                    url => 'http://localhost:1978/node/test',
46                    user => 'admin',
47                    passwd => 'admin',
48                    croak_on_error => 1,
49            );
50    
51            # create condition
52            my $cond = new Search::Estraier::Condition;
53    
54            # set search phrase
55            $cond->set_phrase("rainbow AND lullaby");
56    
57            my $nres = $node->search($cond, 0);
58    
59            if (defined($nres)) {
60                    print "Got ", $nres->hits, " results\n";
61    
62                    # for each document in results
63                    for my $i ( 0 ... $nres->doc_num - 1 ) {
64                            # get result document
65                            my $rdoc = $nres->get_doc($i);
66                            # display attribte
67                            print "URI: ", $rdoc->attr('@uri'),"\n";
68                            print "Title: ", $rdoc->attr('@title'),"\n";
69                            print $rdoc->snippet,"\n";
70                    }
71            } else {
72                    die "error: ", $node->status,"\n";
73            }
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 25  or Hyper Estraier development files on t Line 82  or Hyper Estraier development files on t
82  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
83  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
84    
85    There are few examples in C<scripts> directory of this distribution.
86    
87  =cut  =cut
88    
89  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 100  Remove multiple whitespaces from string,
100  =cut  =cut
101    
102  sub _s {  sub _s {
103          my $text = $_[1] || return;          my $text = $_[1];
104            return unless defined($text);
105          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
106          $text =~ s/^\s+//;          $text =~ s/^\s+//;
107          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 166  sub new {
166                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
167                                  $in_text = 1;                                  $in_text = 1;
168                                  next;                                  next;
169                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
170                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
171                                  next;                                  next;
172                          }                          }
173    
174                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
175                  }                  }
176          }          }
177    
# Line 205  Returns array with attribute names from Line 265  Returns array with attribute names from
265    
266  sub attr_names {  sub attr_names {
267          my $self = shift;          my $self = shift;
268          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
269            #croak "attr_names return array, not scalar" if (! wantarray);
270          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
271  }  }
272    
# Line 221  Returns value of an attribute. Line 282  Returns value of an attribute.
282  sub attr {  sub attr {
283          my $self = shift;          my $self = shift;
284          my $name = shift;          my $name = shift;
285            return unless (defined($name) && $self->{attrs});
286          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
287  }  }
288    
289    
# Line 236  Returns array with text sentences. Line 297  Returns array with text sentences.
297    
298  sub texts {  sub texts {
299          my $self = shift;          my $self = shift;
300          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
301          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
302  }  }
303    
304    
# Line 251  Return whole text as single scalar. Line 312  Return whole text as single scalar.
312    
313  sub cat_texts {  sub cat_texts {
314          my $self = shift;          my $self = shift;
315          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
316  }  }
317    
318    
# Line 268  sub dump_draft { Line 329  sub dump_draft {
329          my $draft;          my $draft;
330    
331          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
332                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
333                    $draft .= $attr_name . '=' . $v . "\n";
334          }          }
335    
336          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 378  sub delete {
378    
379  package Search::Estraier::Condition;  package Search::Estraier::Condition;
380    
381  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
382    
383  use Search::Estraier;  use Search::Estraier;
384  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 456  sub set_max {
456    
457  =head2 set_options  =head2 set_options
458    
459    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
460    
461      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
462    
463    Possible options are:
464    
465    =over 8
466    
467    =item SURE
468    
469    check every N-gram
470    
471    =item USUAL
472    
473    check every second N-gram
474    
475    =item FAST
476    
477    check every third N-gram
478    
479    =item AGITO
480    
481    check every fourth N-gram
482    
483    =item NOIDF
484    
485    don't perform TF-IDF tuning
486    
487    =item SIMPLE
488    
489    use simplified query phrase
490    
491    =back
492    
493    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
494    options;
495    
496    This option changed in version C<0.04> of this module. It's backwards compatibile.
497    
498  =cut  =cut
499    
500  my $options = {  my $options = {
         # check N-gram keys skipping by three  
501          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
502          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
503          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
504          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
505          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
506          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
507  };  };
508    
509  sub set_options {  sub set_options {
510          my $self = shift;          my $self = shift;
511          my $option = shift;          my $opt = 0;
512          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
513          $self->{options} ||= $options->{$option};                  my $mask;
514                    unless ($mask = $options->{$option}) {
515                            if ($option eq '1') {
516                                    next;
517                            } else {
518                                    croak "unknown option $option";
519                            }
520                    }
521                    $opt += $mask;
522            }
523            $self->{options} = $opt;
524  }  }
525    
526    
# Line 460  Return search result attrs. Line 563  Return search result attrs.
563  sub attrs {  sub attrs {
564          my $self = shift;          my $self = shift;
565          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
566          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
567  }  }
568    
569    
# Line 496  sub options { Line 599  sub options {
599  }  }
600    
601    
602    =head2 set_skip
603    
604    Set number of skipped documents from beginning of results
605    
606      $cond->set_skip(42);
607    
608    Similar to C<offset> in RDBMS.
609    
610    =cut
611    
612    sub set_skip {
613            my $self = shift;
614            $self->{skip} = shift;
615    }
616    
617    =head2 skip
618    
619    Return skip for this condition.
620    
621      print $cond->skip;
622    
623    =cut
624    
625    sub skip {
626            my $self = shift;
627            return $self->{skip};
628    }
629    
630    
631  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
632    
633  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 656  sub new {
656          my $self = {@_};          my $self = {@_};
657          bless($self, $class);          bless($self, $class);
658    
659          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});  
         }  
660    
661          $self ? return $self : return undef;          $self ? return $self : return undef;
662  }  }
# Line 641  Return number of documents Line 771  Return number of documents
771    
772    print $res->doc_num;    print $res->doc_num;
773    
774    This will return real number of documents (limited by C<max>).
775    If you want to get total number of hits, see C<hits>.
776    
777  =cut  =cut
778    
779  sub doc_num {  sub doc_num {
780          my $self = shift;          my $self = shift;
781          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
782  }  }
783    
784    
# Line 672  sub get_doc { Line 805  sub get_doc {
805    
806  Return specific hint from results.  Return specific hint from results.
807    
808    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
809    
810  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>,
811  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 818  sub hint {
818          return $self->{hints}->{$key};          return $self->{hints}->{$key};
819  }  }
820    
821    =head2 hints
822    
823    More perlish version of C<hint>. This one returns hash.
824    
825      my %hints = $res->hints;
826    
827    =cut
828    
829    sub hints {
830            my $self = shift;
831            return $self->{hints};
832    }
833    
834    =head2 hits
835    
836    Syntaxtic sugar for total number of hits for this query
837    
838      print $res->hits;
839    
840    It's same as
841    
842      print $res->hint('HIT');
843    
844    but shorter.
845    
846    =cut
847    
848    sub hits {
849            my $self = shift;
850            return $self->{hints}->{'HIT'} || 0;
851    }
852    
853  package Search::Estraier::Node;  package Search::Estraier::Node;
854    
# Line 692  use Carp qw/carp croak confess/; Line 856  use Carp qw/carp croak confess/;
856  use URI;  use URI;
857  use MIME::Base64;  use MIME::Base64;
858  use IO::Socket::INET;  use IO::Socket::INET;
859    use URI::Escape qw/uri_escape/;
860    
861  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
862    
# Line 699  use IO::Socket::INET; Line 864  use IO::Socket::INET;
864    
865    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
866    
867    or optionally with C<url> as parametar
868    
869      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
870    
871    or in more verbose form
872    
873      my $node = new Search::HyperEstraier::Node(
874            url => 'http://localhost:1978/node/test',
875            user => 'admin',
876            passwd => 'admin'
877            debug => 1,
878            croak_on_error => 1
879      );
880    
881    with following arguments:
882    
883    =over 4
884    
885    =item url
886    
887    URL to node
888    
889    =item user
890    
891    specify username for node server authentication
892    
893    =item passwd
894    
895    password for authentication
896    
897    =item debug
898    
899    dumps a B<lot> of debugging output
900    
901    =item croak_on_error
902    
903    very helpful during development. It will croak on all errors instead of
904    silently returning C<-1> (which is convention of Hyper Estraier API in other
905    languages).
906    
907    =back
908    
909  =cut  =cut
910    
911  sub new {  sub new {
# Line 706  sub new { Line 913  sub new {
913          my $self = {          my $self = {
914                  pxport => -1,                  pxport => -1,
915                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
916                  wwidth => 480,                  wwidth => 480,
917                  hwidth => 96,                  hwidth => 96,
918                  awidth => 96,                  awidth => 96,
919                  status => -1,                  status => -1,
920          };          };
921    
922          bless($self, $class);          bless($self, $class);
923    
924          if (@_) {          if ($#_ == 0) {
925                  $self->{debug} = shift;                  $self->{url} = shift;
926                  warn "## Node debug on\n";          } else {
927                    %$self = ( %$self, @_ );
928    
929                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
930    
931                    warn "## Node debug on\n" if ($self->{debug});
932          }          }
933    
934            $self->{inform} = {
935                    dnum => -1,
936                    wnum => -1,
937                    size => -1.0,
938            };
939    
940          $self ? return $self : return undef;          $self ? return $self : return undef;
941  }  }
942    
# Line 866  sub out_doc_by_uri { Line 1082  sub out_doc_by_uri {
1082          return unless ($self->{url});          return unless ($self->{url});
1083          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1084                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1085                  "uri=$uri",                  "uri=" . uri_escape($uri),
1086                  undef                  undef
1087          ) == 200;          ) == 200;
1088  }  }
# Line 928  sub get_doc_by_uri { Line 1144  sub get_doc_by_uri {
1144  }  }
1145    
1146    
1147    =head2 get_doc_attr
1148    
1149    Retrieve the value of an atribute from object
1150    
1151      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1152            die "can't get document attribute";
1153    
1154    =cut
1155    
1156    sub get_doc_attr {
1157            my $self = shift;
1158            my ($id,$name) = @_;
1159            return unless ($id && $name);
1160            return $self->_fetch_doc( id => $id, attr => $name );
1161    }
1162    
1163    
1164    =head2 get_doc_attr_by_uri
1165    
1166    Retrieve the value of an atribute from object
1167    
1168      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1169            die "can't get document attribute";
1170    
1171    =cut
1172    
1173    sub get_doc_attr_by_uri {
1174            my $self = shift;
1175            my ($uri,$name) = @_;
1176            return unless ($uri && $name);
1177            return $self->_fetch_doc( uri => $uri, attr => $name );
1178    }
1179    
1180    
1181  =head2 etch_doc  =head2 etch_doc
1182    
1183  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1186  Exctract document keywords
1186    
1187  =cut  =cut
1188    
1189  sub erch_doc {  sub etch_doc {
1190          my $self = shift;          my $self = shift;
1191          my $id = shift || return;          my $id = shift || return;
1192          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 1215  Get ID of document specified by URI
1215    
1216    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1217    
1218    This method won't croak, even if using C<croak_on_error>.
1219    
1220  =cut  =cut
1221    
1222  sub uri_to_id {  sub uri_to_id {
1223          my $self = shift;          my $self = shift;
1224          my $uri = shift || return;          my $uri = shift || return;
1225          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 );
1226  }  }
1227    
1228    
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1239  C<etch_doc>, C<etch_doc_by_uri>.
1239   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1240   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1241    
1242     # to get document attrubute add attr
1243     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1244     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1245    
1246   # more general form which allows implementation of   # more general form which allows implementation of
1247   # uri_to_id   # uri_to_id
1248   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1267  sub _fetch_doc {
1267                  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+$/);
1268                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1269          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1270                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1271          } else {          } else {
1272                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1273          }          }
1274    
1275            if ($a->{attr}) {
1276                    $path = '/get_doc_attr';
1277                    $arg .= '&attr=' . uri_escape($a->{attr});
1278                    $a->{chomp_resbody} = 1;
1279            }
1280    
1281          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1282                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1283                  $arg,                  $arg,
1284                  \$resbody,                  \$resbody,
1285                    $a->{croak_on_error},
1286          );          );
1287    
1288          return if ($rv != 200);          return if ($rv != 200);
# Line 1042  sub _fetch_doc { Line 1305  sub _fetch_doc {
1305  }  }
1306    
1307    
1308    =head2 name
1309    
1310      my $node_name = $node->name;
1311    
1312    =cut
1313    
1314    sub name {
1315            my $self = shift;
1316            $self->_set_info unless ($self->{inform}->{name});
1317            return $self->{inform}->{name};
1318    }
1319    
1320    
1321    =head2 label
1322    
1323      my $node_label = $node->label;
1324    
1325    =cut
1326    
1327    sub label {
1328            my $self = shift;
1329            $self->_set_info unless ($self->{inform}->{label});
1330            return $self->{inform}->{label};
1331    }
1332    
1333    
1334    =head2 doc_num
1335    
1336      my $documents_in_node = $node->doc_num;
1337    
1338    =cut
1339    
1340    sub doc_num {
1341            my $self = shift;
1342            $self->_set_info if ($self->{inform}->{dnum} < 0);
1343            return $self->{inform}->{dnum};
1344    }
1345    
1346    
1347    =head2 word_num
1348    
1349      my $words_in_node = $node->word_num;
1350    
1351    =cut
1352    
1353    sub word_num {
1354            my $self = shift;
1355            $self->_set_info if ($self->{inform}->{wnum} < 0);
1356            return $self->{inform}->{wnum};
1357    }
1358    
1359    
1360    =head2 size
1361    
1362      my $node_size = $node->size;
1363    
1364    =cut
1365    
1366    sub size {
1367            my $self = shift;
1368            $self->_set_info if ($self->{inform}->{size} < 0);
1369            return $self->{inform}->{size};
1370    }
1371    
1372    
1373    =head2 search
1374    
1375    Search documents which match condition
1376    
1377      my $nres = $node->search( $cond, $depth );
1378    
1379    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1380    depth for meta search.
1381    
1382    Function results C<Search::Estraier::NodeResult> object.
1383    
1384    =cut
1385    
1386    sub search {
1387            my $self = shift;
1388            my ($cond, $depth) = @_;
1389            return unless ($cond && defined($depth) && $self->{url});
1390            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1391            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1392    
1393            my $resbody;
1394    
1395            my $rv = $self->shuttle_url( $self->{url} . '/search',
1396                    'application/x-www-form-urlencoded',
1397                    $self->cond_to_query( $cond, $depth ),
1398                    \$resbody,
1399            );
1400            return if ($rv != 200);
1401    
1402            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1403            my $hintsText   = splice @records, 0, 2; # starts with empty record
1404            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1405    
1406            # process records
1407            my $docs = [];
1408            foreach my $record (@records)
1409            {
1410                    # split into keys and snippets
1411                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1412    
1413                    # create document hash
1414                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1415                    $doc->{'@keywords'}     = $doc->{keywords};
1416                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1417                    $doc->{snippet}         = $snippet;
1418    
1419                    push @$docs, new Search::Estraier::ResultDocument(
1420                            attrs           => $doc,
1421                            uri             => $doc->{'@uri'},
1422                            snippet         => $snippet,
1423                            keywords        => $doc->{'keywords'},
1424                    );
1425            }
1426    
1427            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1428    }
1429    
1430    
1431    =head2 cond_to_query
1432    
1433    Return URI encoded string generated from Search::Estraier::Condition
1434    
1435      my $args = $node->cond_to_query( $cond, $depth );
1436    
1437    =cut
1438    
1439    sub cond_to_query {
1440            my $self = shift;
1441    
1442            my $cond = shift || return;
1443            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1444            my $depth = shift;
1445    
1446            my @args;
1447    
1448            if (my $phrase = $cond->phrase) {
1449                    push @args, 'phrase=' . uri_escape($phrase);
1450            }
1451    
1452            if (my @attrs = $cond->attrs) {
1453                    for my $i ( 0 .. $#attrs ) {
1454                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1455                    }
1456            }
1457    
1458            if (my $order = $cond->order) {
1459                    push @args, 'order=' . uri_escape($order);
1460            }
1461                    
1462            if (my $max = $cond->max) {
1463                    push @args, 'max=' . $max;
1464            } else {
1465                    push @args, 'max=' . (1 << 30);
1466            }
1467    
1468            if (my $options = $cond->options) {
1469                    push @args, 'options=' . $options;
1470            }
1471    
1472            push @args, 'depth=' . $depth if ($depth);
1473            push @args, 'wwidth=' . $self->{wwidth};
1474            push @args, 'hwidth=' . $self->{hwidth};
1475            push @args, 'awidth=' . $self->{awidth};
1476            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1477    
1478            return join('&', @args);
1479    }
1480    
1481    
1482  =head2 shuttle_url  =head2 shuttle_url
1483    
1484  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
1485  master.  master.
1486    
1487    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1488    
1489  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
1490  body will be saved within object.  body will be saved within object.
1491    
1492  =cut  =cut
1493    
1494    use LWP::UserAgent;
1495    
1496  sub shuttle_url {  sub shuttle_url {
1497          my $self = shift;          my $self = shift;
1498    
1499          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1500    
1501            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1502    
1503          $self->{status} = -1;          $self->{status} = -1;
1504    
# Line 1074  sub shuttle_url { Line 1513  sub shuttle_url {
1513                  return -1;                  return -1;
1514          }          }
1515    
1516          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1517            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1518    
1519          if ($self->{pxhost}) {          my $req;
1520                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1521                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1522            } else {
1523                    $req = HTTP::Request->new(GET => $url);
1524          }          }
1525    
1526          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1527            $req->headers->header( 'Connection', 'close' );
1528            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1529            $req->content_type( $content_type );
1530    
1531          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1532    
1533          if ($reqbody) {          if ($reqbody) {
1534                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1535          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1536          }          }
1537    
1538          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1539          $headers .= "Connection: close\r\n";  
1540          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1541          $headers .= "Content-Type: $content_type\r\n";  
1542          $headers .= "Authorization: Basic $self->{auth}\r\n";          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1543          my $len = 0;  
1544          {          if (! $res->is_success) {
1545                  use bytes;                  if ($croak_on_error) {
1546                  $len = length($reqbody) if ($reqbody);                          croak("can't get $url: ",$res->status_line);
1547                    } else {
1548                            return -1;
1549                    }
1550          }          }
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
1551    
1552          my $sock = IO::Socket::INET->new(          $$resbody .= $res->content;
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1553    
1554          if (! $sock) {          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1555                  carp "can't open socket to $host:$port";  
1556                  return -1;          return $self->{status};
1557    }
1558    
1559    
1560    =head2 set_snippet_width
1561    
1562    Set width of snippets in results
1563    
1564      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1565    
1566    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1567    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1568    
1569    C<$hwidth> specified width of strings from beginning of string. Default
1570    value is C<96>. Negative or zero value keep previous value.
1571    
1572    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1573    If negative of zero value is provided previous value is kept unchanged.
1574    
1575    =cut
1576    
1577    sub set_snippet_width {
1578            my $self = shift;
1579    
1580            my ($wwidth, $hwidth, $awidth) = @_;
1581            $self->{wwidth} = $wwidth;
1582            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1583            $self->{awidth} = $awidth if ($awidth >= 0);
1584    }
1585    
1586    
1587    =head2 set_user
1588    
1589    Manage users of node
1590    
1591      $node->set_user( 'name', $mode );
1592    
1593    C<$mode> can be one of:
1594    
1595    =over 4
1596    
1597    =item 0
1598    
1599    delete account
1600    
1601    =item 1
1602    
1603    set administrative right for user
1604    
1605    =item 2
1606    
1607    set user account as guest
1608    
1609    =back
1610    
1611    Return true on success, otherwise false.
1612    
1613    =cut
1614    
1615    sub set_user {
1616            my $self = shift;
1617            my ($name, $mode) = @_;
1618    
1619            return unless ($self->{url});
1620            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1621    
1622            $self->shuttle_url( $self->{url} . '/_set_user',
1623                    'text/plain',
1624                    'name=' . uri_escape($name) . '&mode=' . $mode,
1625                    undef
1626            ) == 200;
1627    }
1628    
1629    
1630    =head2 set_link
1631    
1632    Manage node links
1633    
1634      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1635    
1636    If C<$credit> is negative, link is removed.
1637    
1638    =cut
1639    
1640    sub set_link {
1641            my $self = shift;
1642            my ($url, $label, $credit) = @_;
1643    
1644            return unless ($self->{url});
1645            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1646    
1647            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1648            $reqbody .= '&credit=' . $credit if ($credit > 0);
1649    
1650            if ($self->shuttle_url( $self->{url} . '/_set_link',
1651                    'application/x-www-form-urlencoded',
1652                    $reqbody,
1653                    undef
1654            ) == 200) {
1655                    # refresh node info after adding link
1656                    $self->_set_info;
1657                    return 1;
1658          }          }
1659    }
1660    
1661          warn $headers if ($self->{debug});  =head2 admins
1662    
1663          print $sock $headers or   my @admins = @{ $node->admins };
1664                  carp "can't send headers to network:\n$headers\n" and return -1;  
1665    Return array of users with admin rights on node
1666    
1667    =cut
1668    
1669    sub admins {
1670            my $self = shift;
1671            $self->_set_info unless ($self->{inform}->{name});
1672            return $self->{inform}->{admins};
1673    }
1674    
1675    =head2 guests
1676    
1677     my @guests = @{ $node->guests };
1678    
1679    Return array of users with guest rights on node
1680    
1681    =cut
1682    
1683    sub guests {
1684            my $self = shift;
1685            $self->_set_info unless ($self->{inform}->{name});
1686            return $self->{inform}->{guests};
1687    }
1688    
1689    =head2 links
1690    
1691     my $links = @{ $node->links };
1692    
1693    Return array of links for this node
1694    
1695    =cut
1696    
1697    sub links {
1698            my $self = shift;
1699            $self->_set_info unless ($self->{inform}->{name});
1700            return $self->{inform}->{links};
1701    }
1702    
1703    =head2 master
1704    
1705    Set actions on Hyper Estraier node master (C<estmaster> process)
1706    
1707      $node->master(
1708            action => 'sync'
1709      );
1710    
1711    All available actions are documented in
1712    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1713    
1714    =cut
1715    
1716    my $estmaster_rest = {
1717            shutdown => {
1718                    status => 202,
1719            },
1720            sync => {
1721                    status => 202,
1722            },
1723            backup => {
1724                    status => 202,
1725            },
1726            userlist => {
1727                    status => 200,
1728                    returns => [ qw/name passwd flags fname misc/ ],
1729            },
1730            useradd => {
1731                    required => [ qw/name passwd flags/ ],
1732                    optional => [ qw/fname misc/ ],
1733                    status => 200,
1734            },
1735            userdel => {
1736                    required => [ qw/name/ ],
1737                    status => 200,
1738            },
1739            nodelist => {
1740                    status => 200,
1741                    returns => [ qw/name label doc_num word_num size/ ],
1742            },
1743            nodeadd => {
1744                    required => [ qw/name/ ],
1745                    optional => [ qw/label/ ],
1746                    status => 200,
1747            },
1748            nodedel => {
1749                    required => [ qw/name/ ],
1750                    status => 200,
1751            },
1752            nodeclr => {
1753                    required => [ qw/name/ ],
1754                    status => 200,
1755            },
1756            nodertt => {
1757                    status => 200,  
1758            },
1759    };
1760    
1761    sub master {
1762            my $self = shift;
1763    
1764            my $args = {@_};
1765    
1766            # have action?
1767            my $action = $args->{action} || croak "need action, available: ",
1768                    join(", ",keys %{ $estmaster_rest });
1769    
1770            # check if action is valid
1771            my $rest = $estmaster_rest->{$action};
1772            croak "action '$action' is not supported, available actions: ",
1773                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1774    
1775            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1776    
1777            my @args;
1778    
1779            if ($rest->{required} || $rest->{optional}) {
1780    
1781                    map {
1782                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1783                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1784                    } ( keys %{ $rest->{required} } );
1785    
1786                    map {
1787                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1788                    } ( keys %{ $rest->{optional} } );
1789    
         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;  
1790          }          }
1791    
1792          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});  
         };  
1793    
1794          # read body          my $resbody;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1795    
1796          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          my $status = $self->shuttle_url(
1797                    'http://' . $uri->host_port . '/master?action=' . $action ,
1798                    'application/x-www-form-urlencoded',
1799                    join('&', @args),
1800                    \$resbody,
1801                    1,
1802            ) or confess "shuttle_url failed";
1803    
1804            if ($status == $rest->{status}) {
1805                    if ($rest->{returns} && wantarray) {
1806    
1807                            my @results;
1808                            my $fields = $#{$rest->{returns}};
1809    
1810                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1811                                    my @e = split(/\t/, $line, $fields + 1);
1812                                    my $row;
1813                                    foreach my $i ( 0 .. $fields) {
1814                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1815                                    }
1816                                    push @results, $row;
1817                            }
1818    
1819                            return @results;
1820    
1821                    } elsif ($resbody) {
1822                            return $resbody;
1823                    } else {
1824                            return 0E0;
1825                    }
1826            }
1827    
1828            carp "expected status $rest->{status}, but got $status";
1829            return undef;
1830    }
1831    
1832    =head1 PRIVATE METHODS
1833    
1834    You could call those directly, but you don't have to. I hope.
1835    
1836    =head2 _set_info
1837    
1838    Set information for node
1839    
1840      $node->_set_info;
1841    
1842    =cut
1843    
1844    sub _set_info {
1845            my $self = shift;
1846    
1847            $self->{status} = -1;
1848            return unless ($self->{url});
1849    
1850            my $resbody;
1851            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1852                    'text/plain',
1853                    undef,
1854                    \$resbody,
1855            );
1856    
1857            return if ($rv != 200 || !$resbody);
1858    
1859            my @lines = split(/[\r\n]/,$resbody);
1860    
1861            $self->{inform} = {};
1862    
1863            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1864                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1865    
1866            return $resbody unless (@lines);
1867    
1868            shift @lines;
1869    
1870            while(my $admin = shift @lines) {
1871                    push @{$self->{inform}->{admins}}, $admin;
1872            }
1873    
1874            while(my $guest = shift @lines) {
1875                    push @{$self->{inform}->{guests}}, $guest;
1876            }
1877    
1878            while(my $link = shift @lines) {
1879                    push @{$self->{inform}->{links}}, $link;
1880            }
1881    
1882            return $resbody;
1883    
         return $self->{status};  
1884  }  }
1885    
1886  ###  ###
# Line 1171  Hyper Estraier Ruby interface on which t Line 1899  Hyper Estraier Ruby interface on which t
1899    
1900  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1901    
1902    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1903    
1904  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1905    
Legend:
Removed from v.47  
changed lines
  Added in v.135
  ViewVC Help
Powered by ViewVC 1.1.26