/[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 58 by dpavlin, Fri Jan 6 21:05:05 2006 UTC revision 160 by dpavlin, Sat Jun 24 15:34:42 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_2';
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 {
# 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 700  use URI::Escape qw/uri_escape/; Line 867  use URI::Escape qw/uri_escape/;
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 707  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          my $args = {@_};          if ($#_ == 0) {
938                    $self->{url} = shift;
939            } 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          $self->{debug} = $args->{debug};          if ($self->{create}) {
954          warn "## Node debug on\n" if ($self->{debug});                  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;
967  }  }
# Line 812  Add a document Line 1053  Add a document
1053    
1054    $node->put_doc( $document_draft ) or die "can't add document";    $node->put_doc( $document_draft ) or die "can't add document";
1055    
1056  Return true on success or false on failture.  Return true on success or false on failure.
1057    
1058  =cut  =cut
1059    
# Line 820  sub put_doc { Line 1061  sub put_doc {
1061          my $self = shift;          my $self = shift;
1062          my $doc = shift || return;          my $doc = shift || return;
1063          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1064          $self->shuttle_url( $self->{url} . '/put_doc',          if ($self->shuttle_url( $self->{url} . '/put_doc',
1065                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1066                  $doc->dump_draft,                  $doc->dump_draft,
1067                  undef                  undef
1068          ) == 200;          ) == 200) {
1069                    $self->_clear_info;
1070                    return 1;
1071            }
1072            return undef;
1073  }  }
1074    
1075    
# Line 843  sub out_doc { Line 1088  sub out_doc {
1088          my $id = shift || return;          my $id = shift || return;
1089          return unless ($self->{url});          return unless ($self->{url});
1090          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1091          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1092                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1093                  "id=$id",                  "id=$id",
1094                  undef                  undef
1095          ) == 200;          ) == 200) {
1096                    $self->_clear_info;
1097                    return 1;
1098            }
1099            return undef;
1100  }  }
1101    
1102    
# Line 865  sub out_doc_by_uri { Line 1114  sub out_doc_by_uri {
1114          my $self = shift;          my $self = shift;
1115          my $uri = shift || return;          my $uri = shift || return;
1116          return unless ($self->{url});          return unless ($self->{url});
1117          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1118                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1119                  "uri=" . uri_escape($uri),                  "uri=" . uri_escape($uri),
1120                  undef                  undef
1121          ) == 200;          ) == 200) {
1122                    $self->_clear_info;
1123                    return 1;
1124            }
1125            return undef;
1126  }  }
1127    
1128    
# Line 887  sub edit_doc { Line 1140  sub edit_doc {
1140          my $self = shift;          my $self = shift;
1141          my $doc = shift || return;          my $doc = shift || return;
1142          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1143          $self->shuttle_url( $self->{url} . '/edit_doc',          if ($self->shuttle_url( $self->{url} . '/edit_doc',
1144                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1145                  $doc->dump_draft,                  $doc->dump_draft,
1146                  undef                  undef
1147          ) == 200;          ) == 200) {
1148                    $self->_clear_info;
1149                    return 1;
1150            }
1151            return undef;
1152  }  }
1153    
1154    
# Line 1000  Get ID of document specified by URI Line 1257  Get ID of document specified by URI
1257    
1258    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1259    
1260    This method won't croak, even if using C<croak_on_error>.
1261    
1262  =cut  =cut
1263    
1264  sub uri_to_id {  sub uri_to_id {
1265          my $self = shift;          my $self = shift;
1266          my $uri = shift || return;          my $uri = shift || return;
1267          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 );
1268  }  }
1269    
1270    
# Line 1065  sub _fetch_doc { Line 1324  sub _fetch_doc {
1324                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1325                  $arg,                  $arg,
1326                  \$resbody,                  \$resbody,
1327                    $a->{croak_on_error},
1328          );          );
1329    
1330          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1355  sub _fetch_doc {
1355    
1356  sub name {  sub name {
1357          my $self = shift;          my $self = shift;
1358          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1359          return $self->{name};          return $self->{inform}->{name};
1360  }  }
1361    
1362    
# Line 1108  sub name { Line 1368  sub name {
1368    
1369  sub label {  sub label {
1370          my $self = shift;          my $self = shift;
1371          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1372          return $self->{label};          return $self->{inform}->{label};
1373  }  }
1374    
1375    
# Line 1121  sub label { Line 1381  sub label {
1381    
1382  sub doc_num {  sub doc_num {
1383          my $self = shift;          my $self = shift;
1384          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1385          return $self->{dnum};          return $self->{inform}->{dnum};
1386  }  }
1387    
1388    
# Line 1134  sub doc_num { Line 1394  sub doc_num {
1394    
1395  sub word_num {  sub word_num {
1396          my $self = shift;          my $self = shift;
1397          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1398          return $self->{wnum};          return $self->{inform}->{wnum};
1399  }  }
1400    
1401    
# Line 1147  sub word_num { Line 1407  sub word_num {
1407    
1408  sub size {  sub size {
1409          my $self = shift;          my $self = shift;
1410          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1411          return $self->{size};          return $self->{inform}->{size};
1412  }  }
1413    
1414    
# Line 1176  sub search { Line 1436  sub search {
1436    
1437          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1438                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1439                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1440                  \$resbody,                  \$resbody,
1441          );          );
1442          return if ($rv != 200);          return if ($rv != 200);
1443    
1444          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1445            my $hintsText   = splice @records, 0, 2; # starts with empty record
1446          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1447          return unless (@lines);  
1448            # process records
1449          my $border = $lines[0];          my $docs = [];
1450          my $isend = 0;          foreach my $record (@records)
1451          my $lnum = 1;          {
1452                    # split into keys and snippets
1453          while ( $lnum <= $#lines ) {                  my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
                 my $line = $lines[$lnum];  
                 $lnum++;  
   
                 #warn "## $line\n";  
                 if ($line && $line =~ m/^\Q$border\E(:END)*$/) {  
                         $isend = $1;  
                         last;  
                 }  
   
                 if ($line =~ /\t/) {  
                         my ($k,$v) = split(/\t/, $line, 2);  
                         $hints->{$k} = $v;  
                 }  
         }  
   
         my $snum = $lnum;  
   
         while( ! $isend && $lnum <= $#lines ) {  
                 my $line = $lines[$lnum];  
                 #warn "# $lnum: $line\n";  
                 $lnum++;  
   
                 if ($line && $line =~ m/^\Q$border\E/) {  
                         if ($lnum > $snum) {  
                                 my $rdattrs;  
                                 my $rdvector;  
                                 my $rdsnippet;  
                                   
                                 my $rlnum = $snum;  
                                 while ($rlnum < $lnum - 1 ) {  
                                         #my $rdline = $self->_s($lines[$rlnum]);  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         last unless ($rdline);  
                                         if ($rdline =~ /^%/) {  
                                                 $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);  
                                         } elsif($rdline =~ /=/) {  
                                                 $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);  
                                         } else {  
                                                 confess "invalid format of response";  
                                         }  
                                 }  
                                 while($rlnum < $lnum - 1) {  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         $rdsnippet .= "$rdline\n";  
                                 }  
                                 #warn Dumper($rdvector, $rdattrs, $rdsnippet);  
                                 if (my $rduri = $rdattrs->{'@uri'}) {  
                                         push @docs, new Search::Estraier::ResultDocument(  
                                                 uri => $rduri,  
                                                 attrs => $rdattrs,  
                                                 snippet => $rdsnippet,  
                                                 keywords => $rdvector,  
                                         );  
                                 }  
                         }  
                         $snum = $lnum;  
                         #warn "### $line\n";  
                         $isend = 1 if ($line =~ /:END$/);  
                 }  
   
         }  
1454    
1455          if (! $isend) {                  # create document hash
1456                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1457                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1458                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1459                    $doc->{snippet}         = $snippet;
1460    
1461                    push @$docs, new Search::Estraier::ResultDocument(
1462                            attrs           => $doc,
1463                            uri             => $doc->{'@uri'},
1464                            snippet         => $snippet,
1465                            keywords        => $doc->{'keywords'},
1466                    );
1467          }          }
1468    
1469          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1470  }  }
1471    
1472    
# Line 1270  sub search { Line 1474  sub search {
1474    
1475  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1476    
1477    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1478    
1479  =cut  =cut
1480    
# Line 1279  sub cond_to_query { Line 1483  sub cond_to_query {
1483    
1484          my $cond = shift || return;          my $cond = shift || return;
1485          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1486            my $depth = shift;
1487    
1488          my @args;          my @args;
1489    
# Line 1288  sub cond_to_query { Line 1493  sub cond_to_query {
1493    
1494          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1495                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1496                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1497                  }                  }
1498          }          }
1499    
# Line 1306  sub cond_to_query { Line 1511  sub cond_to_query {
1511                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1512          }          }
1513    
1514          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1515          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1516          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1517          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1518            push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
1519    
1520          return join('&', @args);          return join('&', @args);
1521  }  }
# Line 1317  sub cond_to_query { Line 1523  sub cond_to_query {
1523    
1524  =head2 shuttle_url  =head2 shuttle_url
1525    
1526  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
1527  master.  master.
1528    
1529    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
# Line 1327  body will be saved within object. Line 1533  body will be saved within object.
1533    
1534  =cut  =cut
1535    
1536    use LWP::UserAgent;
1537    
1538  sub shuttle_url {  sub shuttle_url {
1539          my $self = shift;          my $self = shift;
1540    
1541          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1542    
1543            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1544    
1545          $self->{status} = -1;          $self->{status} = -1;
1546    
# Line 1345  sub shuttle_url { Line 1555  sub shuttle_url {
1555                  return -1;                  return -1;
1556          }          }
1557    
1558          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1559            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
         if ($self->{pxhost}) {  
                 ($host,$port) = ($self->{pxhost}, $self->{pxport});  
                 $query = "http://$host:$port/$query";  
         }  
   
         $query .= '?' . $url->query if ($url->query && ! $reqbody);  
   
         my $headers;  
1560    
1561            my $req;
1562          if ($reqbody) {          if ($reqbody) {
1563                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1564          } else {          } else {
1565                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1566          }          }
1567    
1568          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1569          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1570          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1571          $headers .= "Content-Type: $content_type\r\n";          $req->content_type( $content_type );
         $headers .= "Authorization: Basic $self->{auth}\r\n";  
         my $len = 0;  
         {  
                 use bytes;  
                 $len = length($reqbody) if ($reqbody);  
         }  
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
1572    
1573          my $sock = IO::Socket::INET->new(          warn $req->headers->as_string,"\n" if ($self->{debug});
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1574    
1575          if (! $sock) {          if ($reqbody) {
1576                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1577                  return -1;                  $req->content( $reqbody );
1578          }          }
1579    
1580          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1581    
1582          print $sock $headers or          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1583    
1584          if ($reqbody) {          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
                 warn "$reqbody\n" if ($self->{debug});  
                 print $sock $reqbody or  
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
         }  
1585    
1586          my $line = <$sock>;          if (! $res->is_success) {
1587          chomp($line);                  if ($croak_on_error) {
1588          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1589          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1590                            return -1;
1591          $self->{status} = $res_status;                  }
1592          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});  
         };  
1593    
1594          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1595    
1596          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1597    
# Line 1490  sub set_user { Line 1662  sub set_user {
1662          croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);          croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1663    
1664          $self->shuttle_url( $self->{url} . '/_set_user',          $self->shuttle_url( $self->{url} . '/_set_user',
1665                  'text/plain',                  'application/x-www-form-urlencoded',
1666                  'name=' . uri_escape($name) . '&mode=' . $mode,                  'name=' . uri_escape($name) . '&mode=' . $mode,
1667                  undef                  undef
1668          ) == 200;          ) == 200;
# Line 1517  sub set_link { Line 1689  sub set_link {
1689          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1690          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1691    
1692          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1693                  'text/plain',                  'application/x-www-form-urlencoded',
1694                  $reqbody,                  $reqbody,
1695                  undef                  undef
1696          ) == 200;          ) == 200) {
1697                    # refresh node info after adding link
1698                    $self->_clear_info;
1699                    return 1;
1700            }
1701            return undef;
1702    }
1703    
1704    =head2 admins
1705    
1706     my @admins = @{ $node->admins };
1707    
1708    Return array of users with admin rights on node
1709    
1710    =cut
1711    
1712    sub admins {
1713            my $self = shift;
1714            $self->_set_info unless ($self->{inform}->{name});
1715            return $self->{inform}->{admins};
1716    }
1717    
1718    =head2 guests
1719    
1720     my @guests = @{ $node->guests };
1721    
1722    Return array of users with guest rights on node
1723    
1724    =cut
1725    
1726    sub guests {
1727            my $self = shift;
1728            $self->_set_info unless ($self->{inform}->{name});
1729            return $self->{inform}->{guests};
1730  }  }
1731    
1732    =head2 links
1733    
1734     my $links = @{ $node->links };
1735    
1736    Return array of links for this node
1737    
1738    =cut
1739    
1740    sub links {
1741            my $self = shift;
1742            $self->_set_info unless ($self->{inform}->{name});
1743            return $self->{inform}->{links};
1744    }
1745    
1746    =head2 cacheusage
1747    
1748    Return cache usage for a node
1749    
1750      my $cache = $node->cacheusage;
1751    
1752    =cut
1753    
1754    sub cacheusage {
1755            my $self = shift;
1756    
1757            return unless ($self->{url});
1758    
1759            my $resbody;
1760            my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
1761                    'text/plain',
1762                    undef,
1763                    \$resbody,
1764            );
1765    
1766            return if ($rv != 200 || !$resbody);
1767    
1768            return $resbody;
1769    }
1770    
1771    =head2 master
1772    
1773    Set actions on Hyper Estraier node master (C<estmaster> process)
1774    
1775      $node->master(
1776            action => 'sync'
1777      );
1778    
1779    All available actions are documented in
1780    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1781    
1782    =cut
1783    
1784    my $estmaster_rest = {
1785            shutdown => {
1786                    status => 202,
1787            },
1788            sync => {
1789                    status => 202,
1790            },
1791            backup => {
1792                    status => 202,
1793            },
1794            userlist => {
1795                    status => 200,
1796                    returns => [ qw/name passwd flags fname misc/ ],
1797            },
1798            useradd => {
1799                    required => [ qw/name passwd flags/ ],
1800                    optional => [ qw/fname misc/ ],
1801                    status => 200,
1802            },
1803            userdel => {
1804                    required => [ qw/name/ ],
1805                    status => 200,
1806            },
1807            nodelist => {
1808                    status => 200,
1809                    returns => [ qw/name label doc_num word_num size/ ],
1810            },
1811            nodeadd => {
1812                    required => [ qw/name/ ],
1813                    optional => [ qw/label/ ],
1814                    status => 200,
1815            },
1816            nodedel => {
1817                    required => [ qw/name/ ],
1818                    status => 200,
1819            },
1820            nodeclr => {
1821                    required => [ qw/name/ ],
1822                    status => 200,
1823            },
1824            nodertt => {
1825                    status => 200,  
1826            },
1827    };
1828    
1829    sub master {
1830            my $self = shift;
1831    
1832            my $args = {@_};
1833    
1834            # have action?
1835            my $action = $args->{action} || croak "need action, available: ",
1836                    join(", ",keys %{ $estmaster_rest });
1837    
1838            # check if action is valid
1839            my $rest = $estmaster_rest->{$action};
1840            croak "action '$action' is not supported, available actions: ",
1841                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1842    
1843            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1844    
1845            my @args;
1846    
1847            if ($rest->{required} || $rest->{optional}) {
1848    
1849                    map {
1850                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1851                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1852                    } ( @{ $rest->{required} } );
1853    
1854                    map {
1855                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1856                    } ( @{ $rest->{optional} } );
1857    
1858            }
1859    
1860            my $uri = new URI( $self->{url} );
1861    
1862            my $resbody;
1863    
1864            my $status = $self->shuttle_url(
1865                    'http://' . $uri->host_port . '/master?action=' . $action ,
1866                    'application/x-www-form-urlencoded',
1867                    join('&', @args),
1868                    \$resbody,
1869                    1,
1870            ) or confess "shuttle_url failed";
1871    
1872            if ($status == $rest->{status}) {
1873    
1874                    # refresh node info after sync
1875                    $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
1876    
1877                    if ($rest->{returns} && wantarray) {
1878    
1879                            my @results;
1880                            my $fields = $#{$rest->{returns}};
1881    
1882                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1883                                    my @e = split(/\t/, $line, $fields + 1);
1884                                    my $row;
1885                                    foreach my $i ( 0 .. $fields) {
1886                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1887                                    }
1888                                    push @results, $row;
1889                            }
1890    
1891                            return @results;
1892    
1893                    } elsif ($resbody) {
1894                            chomp $resbody;
1895                            return $resbody;
1896                    } else {
1897                            return 0E0;
1898                    }
1899            }
1900    
1901            carp "expected status $rest->{status}, but got $status";
1902            return undef;
1903    }
1904    
1905  =head1 PRIVATE METHODS  =head1 PRIVATE METHODS
1906    
# Line 1552  sub _set_info { Line 1929  sub _set_info {
1929    
1930          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1931    
1932          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1933          $resbody =~ s/[\r\n]+$//;  
1934            $self->_clear_info;
1935    
1936            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1937                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1938    
1939            return $resbody unless (@lines);
1940    
1941            shift @lines;
1942    
1943          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          while(my $admin = shift @lines) {
1944                  split(/\t/, $resbody, 5);                  push @{$self->{inform}->{admins}}, $admin;
1945            }
1946    
1947            while(my $guest = shift @lines) {
1948                    push @{$self->{inform}->{guests}}, $guest;
1949            }
1950    
1951            while(my $link = shift @lines) {
1952                    push @{$self->{inform}->{links}}, $link;
1953            }
1954    
1955            return $resbody;
1956    
1957    }
1958    
1959    =head2 _clear_info
1960    
1961    Clear information for node
1962    
1963      $node->_clear_info;
1964    
1965    On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
1966    info will be fetch again from Hyper Estraier.
1967    
1968    =cut
1969    sub _clear_info {
1970            my $self = shift;
1971            $self->{inform} = {
1972                    dnum => -1,
1973                    wnum => -1,
1974                    size => -1.0,
1975            };
1976  }  }
1977    
1978  ###  ###
# Line 1576  Hyper Estraier Ruby interface on which t Line 1991  Hyper Estraier Ruby interface on which t
1991    
1992  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1993    
1994    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1995    
1996  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1997    
Legend:
Removed from v.58  
changed lines
  Added in v.160
  ViewVC Help
Powered by ViewVC 1.1.26