/[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 126 by dpavlin, Sat May 6 21:38:14 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            debug => 1,
876            croak_on_error => 1
877      );
878    
879    with following arguments:
880    
881    =over 4
882    
883    =item url
884    
885    URL to node
886    
887    =item debug
888    
889    dumps a B<lot> of debugging output
890    
891    =item croak_on_error
892    
893    very helpful during development. It will croak on all errors instead of
894    silently returning C<-1> (which is convention of Hyper Estraier API in other
895    languages).
896    
897    =back
898    
899  =cut  =cut
900    
901  sub new {  sub new {
# Line 706  sub new { Line 903  sub new {
903          my $self = {          my $self = {
904                  pxport => -1,                  pxport => -1,
905                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
906                  wwidth => 480,                  wwidth => 480,
907                  hwidth => 96,                  hwidth => 96,
908                  awidth => 96,                  awidth => 96,
909                  status => -1,                  status => -1,
910          };          };
911    
912          bless($self, $class);          bless($self, $class);
913    
914          if (@_) {          if ($#_ == 0) {
915                  $self->{debug} = shift;                  $self->{url} = shift;
916                  warn "## Node debug on\n";          } else {
917                    my $args = {@_};
918    
919                    %$self = ( %$self, @_ );
920    
921                    warn "## Node debug on\n" if ($self->{debug});
922          }          }
923    
924            $self->{inform} = {
925                    dnum => -1,
926                    wnum => -1,
927                    size => -1.0,
928            };
929    
930          $self ? return $self : return undef;          $self ? return $self : return undef;
931  }  }
932    
# Line 866  sub out_doc_by_uri { Line 1072  sub out_doc_by_uri {
1072          return unless ($self->{url});          return unless ($self->{url});
1073          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1074                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1075                  "uri=$uri",                  "uri=" . uri_escape($uri),
1076                  undef                  undef
1077          ) == 200;          ) == 200;
1078  }  }
# Line 928  sub get_doc_by_uri { Line 1134  sub get_doc_by_uri {
1134  }  }
1135    
1136    
1137    =head2 get_doc_attr
1138    
1139    Retrieve the value of an atribute from object
1140    
1141      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1142            die "can't get document attribute";
1143    
1144    =cut
1145    
1146    sub get_doc_attr {
1147            my $self = shift;
1148            my ($id,$name) = @_;
1149            return unless ($id && $name);
1150            return $self->_fetch_doc( id => $id, attr => $name );
1151    }
1152    
1153    
1154    =head2 get_doc_attr_by_uri
1155    
1156    Retrieve the value of an atribute from object
1157    
1158      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1159            die "can't get document attribute";
1160    
1161    =cut
1162    
1163    sub get_doc_attr_by_uri {
1164            my $self = shift;
1165            my ($uri,$name) = @_;
1166            return unless ($uri && $name);
1167            return $self->_fetch_doc( uri => $uri, attr => $name );
1168    }
1169    
1170    
1171  =head2 etch_doc  =head2 etch_doc
1172    
1173  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1176  Exctract document keywords
1176    
1177  =cut  =cut
1178    
1179  sub erch_doc {  sub etch_doc {
1180          my $self = shift;          my $self = shift;
1181          my $id = shift || return;          my $id = shift || return;
1182          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 1205  Get ID of document specified by URI
1205    
1206    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1207    
1208    This method won't croak, even if using C<croak_on_error>.
1209    
1210  =cut  =cut
1211    
1212  sub uri_to_id {  sub uri_to_id {
1213          my $self = shift;          my $self = shift;
1214          my $uri = shift || return;          my $uri = shift || return;
1215          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 );
1216  }  }
1217    
1218    
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1229  C<etch_doc>, C<etch_doc_by_uri>.
1229   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1230   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1231    
1232     # to get document attrubute add attr
1233     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1234     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1235    
1236   # more general form which allows implementation of   # more general form which allows implementation of
1237   # uri_to_id   # uri_to_id
1238   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1257  sub _fetch_doc {
1257                  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+$/);
1258                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1259          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1260                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1261          } else {          } else {
1262                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1263          }          }
1264    
1265            if ($a->{attr}) {
1266                    $path = '/get_doc_attr';
1267                    $arg .= '&attr=' . uri_escape($a->{attr});
1268                    $a->{chomp_resbody} = 1;
1269            }
1270    
1271          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1272                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1273                  $arg,                  $arg,
1274                  \$resbody,                  \$resbody,
1275                    $a->{croak_on_error},
1276          );          );
1277    
1278          return if ($rv != 200);          return if ($rv != 200);
# Line 1042  sub _fetch_doc { Line 1295  sub _fetch_doc {
1295  }  }
1296    
1297    
1298    =head2 name
1299    
1300      my $node_name = $node->name;
1301    
1302    =cut
1303    
1304    sub name {
1305            my $self = shift;
1306            $self->_set_info unless ($self->{inform}->{name});
1307            return $self->{inform}->{name};
1308    }
1309    
1310    
1311    =head2 label
1312    
1313      my $node_label = $node->label;
1314    
1315    =cut
1316    
1317    sub label {
1318            my $self = shift;
1319            $self->_set_info unless ($self->{inform}->{label});
1320            return $self->{inform}->{label};
1321    }
1322    
1323    
1324    =head2 doc_num
1325    
1326      my $documents_in_node = $node->doc_num;
1327    
1328    =cut
1329    
1330    sub doc_num {
1331            my $self = shift;
1332            $self->_set_info if ($self->{inform}->{dnum} < 0);
1333            return $self->{inform}->{dnum};
1334    }
1335    
1336    
1337    =head2 word_num
1338    
1339      my $words_in_node = $node->word_num;
1340    
1341    =cut
1342    
1343    sub word_num {
1344            my $self = shift;
1345            $self->_set_info if ($self->{inform}->{wnum} < 0);
1346            return $self->{inform}->{wnum};
1347    }
1348    
1349    
1350    =head2 size
1351    
1352      my $node_size = $node->size;
1353    
1354    =cut
1355    
1356    sub size {
1357            my $self = shift;
1358            $self->_set_info if ($self->{inform}->{size} < 0);
1359            return $self->{inform}->{size};
1360    }
1361    
1362    
1363    =head2 search
1364    
1365    Search documents which match condition
1366    
1367      my $nres = $node->search( $cond, $depth );
1368    
1369    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1370    depth for meta search.
1371    
1372    Function results C<Search::Estraier::NodeResult> object.
1373    
1374    =cut
1375    
1376    sub search {
1377            my $self = shift;
1378            my ($cond, $depth) = @_;
1379            return unless ($cond && defined($depth) && $self->{url});
1380            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1381            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1382    
1383            my $resbody;
1384    
1385            my $rv = $self->shuttle_url( $self->{url} . '/search',
1386                    'application/x-www-form-urlencoded',
1387                    $self->cond_to_query( $cond, $depth ),
1388                    \$resbody,
1389            );
1390            return if ($rv != 200);
1391    
1392            my (@docs, $hints);
1393    
1394            my @lines = split(/\n/, $resbody);
1395            return unless (@lines);
1396    
1397            my $border = $lines[0];
1398            my $isend = 0;
1399            my $lnum = 1;
1400    
1401            while ( $lnum <= $#lines ) {
1402                    my $line = $lines[$lnum];
1403                    $lnum++;
1404    
1405                    #warn "## $line\n";
1406                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1407                            $isend = $1;
1408                            last;
1409                    }
1410    
1411                    if ($line =~ /\t/) {
1412                            my ($k,$v) = split(/\t/, $line, 2);
1413                            $hints->{$k} = $v;
1414                    }
1415            }
1416    
1417            my $snum = $lnum;
1418    
1419            while( ! $isend && $lnum <= $#lines ) {
1420                    my $line = $lines[$lnum];
1421                    #warn "# $lnum: $line\n";
1422                    $lnum++;
1423    
1424                    if ($line && $line =~ m/^\Q$border\E/) {
1425                            if ($lnum > $snum) {
1426                                    my $rdattrs;
1427                                    my $rdvector;
1428                                    my $rdsnippet;
1429                                    
1430                                    my $rlnum = $snum;
1431                                    while ($rlnum < $lnum - 1 ) {
1432                                            #my $rdline = $self->_s($lines[$rlnum]);
1433                                            my $rdline = $lines[$rlnum];
1434                                            $rlnum++;
1435                                            last unless ($rdline);
1436                                            if ($rdline =~ /^%/) {
1437                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1438                                            } elsif($rdline =~ /=/) {
1439                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1440                                            } else {
1441                                                    confess "invalid format of response";
1442                                            }
1443                                    }
1444                                    while($rlnum < $lnum - 1) {
1445                                            my $rdline = $lines[$rlnum];
1446                                            $rlnum++;
1447                                            $rdsnippet .= "$rdline\n";
1448                                    }
1449                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1450                                    if (my $rduri = $rdattrs->{'@uri'}) {
1451                                            push @docs, new Search::Estraier::ResultDocument(
1452                                                    uri => $rduri,
1453                                                    attrs => $rdattrs,
1454                                                    snippet => $rdsnippet,
1455                                                    keywords => $rdvector,
1456                                            );
1457                                    }
1458                            }
1459                            $snum = $lnum;
1460                            #warn "### $line\n";
1461                            $isend = 1 if ($line =~ /:END$/);
1462                    }
1463    
1464            }
1465    
1466            if (! $isend) {
1467                    warn "received result doesn't have :END\n$resbody";
1468                    return;
1469            }
1470    
1471            #warn Dumper(\@docs, $hints);
1472    
1473            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1474    }
1475    
1476    =head2 search_new
1477    
1478    Better implementation of search by Robert Klep <robert@klep.name>
1479    
1480    =cut
1481    
1482    sub search_new {
1483            my $self = shift;
1484            my ($cond, $depth) = @_;
1485            return unless ($cond && defined($depth) && $self->{url});
1486            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1487            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1488    
1489            my $resbody;
1490    
1491            my $rv = $self->shuttle_url( $self->{url} . '/search',
1492                    'application/x-www-form-urlencoded',
1493                    $self->cond_to_query( $cond, $depth ),
1494                    \$resbody,
1495            );
1496            return if ($rv != 200);
1497    
1498            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1499            my $hintsText   = splice @records, 0, 2; # starts with empty record
1500            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1501    
1502            # process records
1503            my $docs;
1504            foreach my $record (@records)
1505            {
1506                    # split into keys and snippets
1507                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1508    
1509                    # create document hash
1510                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1511                    $doc->{'@keywords'}     = $doc->{keywords};
1512                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1513                    $doc->{snippet}         = $snippet;
1514    
1515                    push @$docs, new Search::Estraier::ResultDocument(
1516                            attrs           => $doc,
1517                            uri             => $doc->{'@uri'},
1518                            snippet         => $snippet,
1519                            keywords        => $doc->{'keywords'},
1520                    );
1521            }
1522    
1523            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1524    }
1525    
1526    
1527    =head2 cond_to_query
1528    
1529    Return URI encoded string generated from Search::Estraier::Condition
1530    
1531      my $args = $node->cond_to_query( $cond, $depth );
1532    
1533    =cut
1534    
1535    sub cond_to_query {
1536            my $self = shift;
1537    
1538            my $cond = shift || return;
1539            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1540            my $depth = shift;
1541    
1542            my @args;
1543    
1544            if (my $phrase = $cond->phrase) {
1545                    push @args, 'phrase=' . uri_escape($phrase);
1546            }
1547    
1548            if (my @attrs = $cond->attrs) {
1549                    for my $i ( 0 .. $#attrs ) {
1550                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1551                    }
1552            }
1553    
1554            if (my $order = $cond->order) {
1555                    push @args, 'order=' . uri_escape($order);
1556            }
1557                    
1558            if (my $max = $cond->max) {
1559                    push @args, 'max=' . $max;
1560            } else {
1561                    push @args, 'max=' . (1 << 30);
1562            }
1563    
1564            if (my $options = $cond->options) {
1565                    push @args, 'options=' . $options;
1566            }
1567    
1568            push @args, 'depth=' . $depth if ($depth);
1569            push @args, 'wwidth=' . $self->{wwidth};
1570            push @args, 'hwidth=' . $self->{hwidth};
1571            push @args, 'awidth=' . $self->{awidth};
1572            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1573    
1574            return join('&', @args);
1575    }
1576    
1577    
1578  =head2 shuttle_url  =head2 shuttle_url
1579    
1580  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
1581  master.  master.
1582    
1583    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1584    
1585  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
1586  body will be saved within object.  body will be saved within object.
1587    
1588  =cut  =cut
1589    
1590    use LWP::UserAgent;
1591    
1592  sub shuttle_url {  sub shuttle_url {
1593          my $self = shift;          my $self = shift;
1594    
1595          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1596    
1597            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1598    
1599          $self->{status} = -1;          $self->{status} = -1;
1600    
# Line 1074  sub shuttle_url { Line 1609  sub shuttle_url {
1609                  return -1;                  return -1;
1610          }          }
1611    
1612          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1613            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1614    
1615          if ($self->{pxhost}) {          my $req;
1616                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1617                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1618            } else {
1619                    $req = HTTP::Request->new(GET => $url);
1620          }          }
1621    
1622          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1623            $req->headers->header( 'Connection', 'close' );
1624            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1625            $req->content_type( $content_type );
1626    
1627          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1628    
1629          if ($reqbody) {          if ($reqbody) {
1630                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1631          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1632          }          }
1633    
1634          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1635          $headers .= "Connection: close\r\n";  
1636          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1637          $headers .= "Content-Type: $content_type\r\n";  
1638          $headers .= "Authorization: Basic $self->{auth}\r\n";          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1639          my $len = 0;  
1640          {          if (! $res->is_success) {
1641                  use bytes;                  if ($croak_on_error) {
1642                  $len = length($reqbody) if ($reqbody);                          croak("can't get $url: ",$res->status_line);
1643                    } else {
1644                            return -1;
1645                    }
1646          }          }
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
1647    
1648          my $sock = IO::Socket::INET->new(          $$resbody .= $res->content;
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1649    
1650          if (! $sock) {          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1651                  carp "can't open socket to $host:$port";  
1652                  return -1;          return $self->{status};
1653    }
1654    
1655    
1656    =head2 set_snippet_width
1657    
1658    Set width of snippets in results
1659    
1660      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1661    
1662    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1663    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1664    
1665    C<$hwidth> specified width of strings from beginning of string. Default
1666    value is C<96>. Negative or zero value keep previous value.
1667    
1668    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1669    If negative of zero value is provided previous value is kept unchanged.
1670    
1671    =cut
1672    
1673    sub set_snippet_width {
1674            my $self = shift;
1675    
1676            my ($wwidth, $hwidth, $awidth) = @_;
1677            $self->{wwidth} = $wwidth;
1678            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1679            $self->{awidth} = $awidth if ($awidth >= 0);
1680    }
1681    
1682    
1683    =head2 set_user
1684    
1685    Manage users of node
1686    
1687      $node->set_user( 'name', $mode );
1688    
1689    C<$mode> can be one of:
1690    
1691    =over 4
1692    
1693    =item 0
1694    
1695    delete account
1696    
1697    =item 1
1698    
1699    set administrative right for user
1700    
1701    =item 2
1702    
1703    set user account as guest
1704    
1705    =back
1706    
1707    Return true on success, otherwise false.
1708    
1709    =cut
1710    
1711    sub set_user {
1712            my $self = shift;
1713            my ($name, $mode) = @_;
1714    
1715            return unless ($self->{url});
1716            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1717    
1718            $self->shuttle_url( $self->{url} . '/_set_user',
1719                    'text/plain',
1720                    'name=' . uri_escape($name) . '&mode=' . $mode,
1721                    undef
1722            ) == 200;
1723    }
1724    
1725    
1726    =head2 set_link
1727    
1728    Manage node links
1729    
1730      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1731    
1732    If C<$credit> is negative, link is removed.
1733    
1734    =cut
1735    
1736    sub set_link {
1737            my $self = shift;
1738            my ($url, $label, $credit) = @_;
1739    
1740            return unless ($self->{url});
1741            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1742    
1743            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1744            $reqbody .= '&credit=' . $credit if ($credit > 0);
1745    
1746            if ($self->shuttle_url( $self->{url} . '/_set_link',
1747                    'application/x-www-form-urlencoded',
1748                    $reqbody,
1749                    undef
1750            ) == 200) {
1751                    # refresh node info after adding link
1752                    $self->_set_info;
1753                    return 1;
1754          }          }
1755    }
1756    
1757          warn $headers if ($self->{debug});  =head2 admins
1758    
1759          print $sock $headers or   my @admins = @{ $node->admins };
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1760    
1761          if ($reqbody) {  Return array of users with admin rights on node
1762                  warn "$reqbody\n" if ($self->{debug});  
1763                  print $sock $reqbody or  =cut
1764                          carp "can't send request body to network:\n$$reqbody\n" and return -1;  
1765    sub admins {
1766            my $self = shift;
1767            $self->_set_info unless ($self->{inform}->{name});
1768            return $self->{inform}->{admins};
1769    }
1770    
1771    =head2 guests
1772    
1773     my @guests = @{ $node->guests };
1774    
1775    Return array of users with guest rights on node
1776    
1777    =cut
1778    
1779    sub guests {
1780            my $self = shift;
1781            $self->_set_info unless ($self->{inform}->{name});
1782            return $self->{inform}->{guests};
1783    }
1784    
1785    =head2 links
1786    
1787     my $links = @{ $node->links };
1788    
1789    Return array of links for this node
1790    
1791    =cut
1792    
1793    sub links {
1794            my $self = shift;
1795            $self->_set_info unless ($self->{inform}->{name});
1796            return $self->{inform}->{links};
1797    }
1798    
1799    
1800    =head1 PRIVATE METHODS
1801    
1802    You could call those directly, but you don't have to. I hope.
1803    
1804    =head2 _set_info
1805    
1806    Set information for node
1807    
1808      $node->_set_info;
1809    
1810    =cut
1811    
1812    sub _set_info {
1813            my $self = shift;
1814    
1815            $self->{status} = -1;
1816            return unless ($self->{url});
1817    
1818            my $resbody;
1819            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1820                    'text/plain',
1821                    undef,
1822                    \$resbody,
1823            );
1824    
1825            return if ($rv != 200 || !$resbody);
1826    
1827            my @lines = split(/[\r\n]/,$resbody);
1828    
1829            $self->{inform} = {};
1830    
1831            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1832                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1833    
1834            return $resbody unless (@lines);
1835    
1836            shift @lines;
1837    
1838            while(my $admin = shift @lines) {
1839                    push @{$self->{inform}->{admins}}, $admin;
1840          }          }
1841    
1842          my $line = <$sock>;          while(my $guest = shift @lines) {
1843          chomp($line);                  push @{$self->{inform}->{guests}}, $guest;
1844          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});  
         };  
1845    
1846          # read body          while(my $link = shift @lines) {
1847          $len = 0;                  push @{$self->{inform}->{links}}, $link;
1848          do {          }
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1849    
1850          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          return $resbody;
1851    
         return $self->{status};  
1852  }  }
1853    
1854  ###  ###
Legend:
Removed from v.47  
changed lines
  Added in v.126
  ViewVC Help
Powered by ViewVC 1.1.26