/[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 30 by dpavlin, Thu Jan 5 15:33:48 2006 UTC revision 173 by dpavlin, Sun Aug 6 18:15:11 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_3';
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
93    
94    This methods should really move somewhere else.
95    
96  =head2 _s  =head2 _s
97    
98  Remove multiple whitespaces from string, as well as whitespaces at beginning or end  Remove multiple whitespaces from string, as well as whitespaces at beginning or end
# Line 37  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 53  our @ISA = qw/Search::Estraier/; Line 120  our @ISA = qw/Search::Estraier/;
120    
121  =head1 Search::Estraier::Document  =head1 Search::Estraier::Document
122    
123  This class implements Document which is collection of attributes  This class implements Document which is single item in Hyper Estraier.
124  (key=value), vectors (also key value) display text and hidden text.  
125    It's is collection of:
126    
127    =over 4
128    
129    =item attributes
130    
131    C<< 'key' => 'value' >> pairs which can later be used for filtering of results
132    
133    You can add common filters to C<attrindex> in estmaster's C<_conf>
134    file for better performance. See C<attrindex> in
135    L<Hyper Estraier P2P Guide|http://hyperestraier.sourceforge.net/nguide-en.html>.
136    
137    =item vectors
138    
139    also C<< 'key' => 'value' >> pairs
140    
141    =item display text
142    
143    Text which will be used to create searchable corpus of your index and
144    included in snippet output.
145    
146    =item hidden text
147    
148    Text which will be searchable, but will not be included in snippet.
149    
150    =back
151    
152  =head2 new  =head2 new
153    
# Line 89  sub new { Line 182  sub new {
182    
183                          if ($line =~ m/^%VECTOR\t(.+)$/) {                          if ($line =~ m/^%VECTOR\t(.+)$/) {
184                                  my @fields = split(/\t/, $1);                                  my @fields = split(/\t/, $1);
185                                  for my $i ( 0 .. ($#fields - 1) ) {                                  if ($#fields % 2 == 1) {
186                                          $self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];                                          $self->{kwords} = { @fields };
187                                          $i++;                                  } else {
188                                            warn "can't decode $line\n";
189                                  }                                  }
190                                  next;                                  next;
191                          } elsif ($line =~ m/^%/) {                          } elsif ($line =~ m/^%/) {
# Line 101  sub new { Line 195  sub new {
195                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
196                                  $in_text = 1;                                  $in_text = 1;
197                                  next;                                  next;
198                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
199                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
200                                  next;                                  next;
201                          }                          }
202    
203                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
204                  }                  }
205          }          }
206    
# Line 175  sub add_hidden_text { Line 269  sub add_hidden_text {
269          push @{ $self->{htexts} }, $self->_s($text);          push @{ $self->{htexts} }, $self->_s($text);
270  }  }
271    
272    =head2 add_vectors
273    
274    Add a vectors
275    
276      $doc->add_vector(
277            'vector_name' => 42,
278            'another' => 12345,
279      );
280    
281    =cut
282    
283    sub add_vectors {
284            my $self = shift;
285            return unless (@_);
286    
287            # this is ugly, but works
288            die "add_vector needs HASH as argument" unless ($#_ % 2 == 1);
289    
290            $self->{kwords} = {@_};
291    }
292    
293    
294  =head2 id  =head2 id
295    
296  Get the ID number of document. If the object has never been registred, C<-1> is returned.  Get the ID number of document. If the object has never been registred, C<-1> is returned.
# Line 188  sub id { Line 304  sub id {
304          return $self->{id};          return $self->{id};
305  }  }
306    
307    
308  =head2 attr_names  =head2 attr_names
309    
310  Returns array with attribute names from document object.  Returns array with attribute names from document object.
# Line 198  Returns array with attribute names from Line 315  Returns array with attribute names from
315    
316  sub attr_names {  sub attr_names {
317          my $self = shift;          my $self = shift;
318          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
319            #croak "attr_names return array, not scalar" if (! wantarray);
320          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
321  }  }
322    
# Line 214  Returns value of an attribute. Line 332  Returns value of an attribute.
332  sub attr {  sub attr {
333          my $self = shift;          my $self = shift;
334          my $name = shift;          my $name = shift;
335            return unless (defined($name) && $self->{attrs});
336          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
337  }  }
338    
339    
# Line 229  Returns array with text sentences. Line 347  Returns array with text sentences.
347    
348  sub texts {  sub texts {
349          my $self = shift;          my $self = shift;
350          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
351          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
352  }  }
353    
354    
355  =head2 cat_texts  =head2 cat_texts
356    
357  Return whole text as single scalar.  Return whole text as single scalar.
# Line 243  Return whole text as single scalar. Line 362  Return whole text as single scalar.
362    
363  sub cat_texts {  sub cat_texts {
364          my $self = shift;          my $self = shift;
365          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
366  }  }
367    
368    
369  =head2 dump_draft  =head2 dump_draft
370    
371  Dump draft data from document object.  Dump draft data from document object.
# Line 259  sub dump_draft { Line 379  sub dump_draft {
379          my $draft;          my $draft;
380    
381          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
382                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
383                    $draft .= $attr_name . '=' . $v . "\n";
384          }          }
385    
386          if ($self->{kwords}) {          if ($self->{kwords}) {
387                  $draft .= '%%VECTOR';                  $draft .= '%VECTOR';
388                  while (my ($key, $value) = each %{ $self->{kwords} }) {                  while (my ($key, $value) = each %{ $self->{kwords} }) {
389                          $draft .= "\t$key\t$value";                          $draft .= "\t$key\t$value";
390                  }                  }
# Line 272  sub dump_draft { Line 393  sub dump_draft {
393    
394          $draft .= "\n";          $draft .= "\n";
395    
396          $draft .= join("\n", @{ $self->{dtexts} }) . "\n";          $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
397          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
398    
399          return $draft;          return $draft;
400  }  }
401    
402    
403  =head2 delete  =head2 delete
404    
405  Empty document object  Empty document object
# Line 306  sub delete { Line 428  sub delete {
428    
429  package Search::Estraier::Condition;  package Search::Estraier::Condition;
430    
431  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
432    
433  use Search::Estraier;  use Search::Estraier;
434  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 330  sub new { Line 452  sub new {
452          $self ? return $self : return undef;          $self ? return $self : return undef;
453  }  }
454    
455    
456  =head2 set_phrase  =head2 set_phrase
457    
458    $cond->set_phrase('search phrase');    $cond->set_phrase('search phrase');
# Line 341  sub set_phrase { Line 464  sub set_phrase {
464          $self->{phrase} = $self->_s( shift );          $self->{phrase} = $self->_s( shift );
465  }  }
466    
467    
468  =head2 add_attr  =head2 add_attr
469    
470    $cond->add_attr('@URI STRINC /~dpavlin/');    $cond->add_attr('@URI STRINC /~dpavlin/');
# Line 353  sub add_attr { Line 477  sub add_attr {
477          push @{ $self->{attrs} }, $self->_s( $attr );          push @{ $self->{attrs} }, $self->_s( $attr );
478  }  }
479    
480    
481  =head2 set_order  =head2 set_order
482    
483    $cond->set_order('@mdate NUMD');    $cond->set_order('@mdate NUMD');
# Line 364  sub set_order { Line 489  sub set_order {
489          $self->{order} = shift;          $self->{order} = shift;
490  }  }
491    
492    
493  =head2 set_max  =head2 set_max
494    
495    $cond->set_max(42);    $cond->set_max(42);
# Line 373  sub set_order { Line 499  sub set_order {
499  sub set_max {  sub set_max {
500          my $self = shift;          my $self = shift;
501          my $max = shift;          my $max = shift;
502          croak "set_max needs number" unless ($max =~ m/^\d+$/);          croak "set_max needs number, not '$max'" unless ($max =~ m/^\d+$/);
503          $self->{max} = $max;          $self->{max} = $max;
504  }  }
505    
506    
507  =head2 set_options  =head2 set_options
508    
509    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
510    
511      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
512    
513    Possible options are:
514    
515    =over 8
516    
517    =item SURE
518    
519    check every N-gram
520    
521    =item USUAL
522    
523    check every second N-gram
524    
525    =item FAST
526    
527    check every third N-gram
528    
529    =item AGITO
530    
531    check every fourth N-gram
532    
533    =item NOIDF
534    
535    don't perform TF-IDF tuning
536    
537    =item SIMPLE
538    
539    use simplified query phrase
540    
541    =back
542    
543    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
544    options;
545    
546    This option changed in version C<0.04> of this module. It's backwards compatibile.
547    
548  =cut  =cut
549    
550  my $options = {  my $options = {
         # check N-gram keys skipping by three  
551          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
552          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
553          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
554          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
555          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
556          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
557  };  };
558    
559  sub set_options {  sub set_options {
560          my $self = shift;          my $self = shift;
561          my $option = shift;          my $opt = 0;
562          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
563          $self->{options} ||= $options->{$option};                  my $mask;
564                    unless ($mask = $options->{$option}) {
565                            if ($option eq '1') {
566                                    next;
567                            } else {
568                                    croak "unknown option $option";
569                            }
570                    }
571                    $opt += $mask;
572            }
573            $self->{options} = $opt;
574  }  }
575    
576    
577  =head2 phrase  =head2 phrase
578    
579  Return search phrase.  Return search phrase.
# Line 418  sub phrase { Line 587  sub phrase {
587          return $self->{phrase};          return $self->{phrase};
588  }  }
589    
590    
591  =head2 order  =head2 order
592    
593  Return search result order.  Return search result order.
# Line 431  sub order { Line 601  sub order {
601          return $self->{order};          return $self->{order};
602  }  }
603    
604    
605  =head2 attrs  =head2 attrs
606    
607  Return search result attrs.  Return search result attrs.
# Line 442  Return search result attrs. Line 613  Return search result attrs.
613  sub attrs {  sub attrs {
614          my $self = shift;          my $self = shift;
615          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
616          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
617  }  }
618    
619    
620  =head2 max  =head2 max
621    
622  Return maximum number of results.  Return maximum number of results.
# Line 460  sub max { Line 632  sub max {
632          return $self->{max};          return $self->{max};
633  }  }
634    
635    
636  =head2 options  =head2 options
637    
638  Return options for this condition.  Return options for this condition.
# Line 476  sub options { Line 649  sub options {
649  }  }
650    
651    
652    =head2 set_skip
653    
654    Set number of skipped documents from beginning of results
655    
656      $cond->set_skip(42);
657    
658    Similar to C<offset> in RDBMS.
659    
660    =cut
661    
662    sub set_skip {
663            my $self = shift;
664            $self->{skip} = shift;
665    }
666    
667    =head2 skip
668    
669    Return skip for this condition.
670    
671      print $cond->skip;
672    
673    =cut
674    
675    sub skip {
676            my $self = shift;
677            return $self->{skip};
678    }
679    
680    =head2 set_mask
681    
682    Select just some links when searching and not all.
683    
684    Argument array of link numbers, starting with 0.
685    
686      $cond->set_mask(qw/0 1 4/);
687    
688    =cut
689    
690    sub set_mask {
691            my $self = shift;
692            return unless (@_);
693            $self->{mask} = \@_;
694    }
695    
696    
697  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
698    
699  use Carp qw/croak/;  use Carp qw/croak/;
# Line 504  sub new { Line 722  sub new {
722          my $self = {@_};          my $self = {@_};
723          bless($self, $class);          bless($self, $class);
724    
725          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});  
         }  
726    
727          $self ? return $self : return undef;          $self ? return $self : return undef;
728  }  }
729    
730    
731  =head2 uri  =head2 uri
732    
733  Return URI of result document  Return URI of result document
# Line 539  sub attr_names { Line 756  sub attr_names {
756          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
757  }  }
758    
759    
760  =head2 attr  =head2 attr
761    
762  Returns value of an attribute.  Returns value of an attribute.
# Line 553  sub attr { Line 771  sub attr {
771          return $self->{attrs}->{ $name };          return $self->{attrs}->{ $name };
772  }  }
773    
774    
775  =head2 snippet  =head2 snippet
776    
777  Return snippet from result document  Return snippet from result document
# Line 566  sub snippet { Line 785  sub snippet {
785          return $self->{snippet};          return $self->{snippet};
786  }  }
787    
788    
789  =head2 keywords  =head2 keywords
790    
791  Return keywords from result document  Return keywords from result document
# Line 610  sub new { Line 830  sub new {
830          $self ? return $self : return undef;          $self ? return $self : return undef;
831  }  }
832    
833    
834  =head2 doc_num  =head2 doc_num
835    
836  Return number of documents  Return number of documents
837    
838    print $res->doc_num;    print $res->doc_num;
839    
840    This will return real number of documents (limited by C<max>).
841    If you want to get total number of hits, see C<hits>.
842    
843  =cut  =cut
844    
845  sub doc_num {  sub doc_num {
846          my $self = shift;          my $self = shift;
847          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
848  }  }
849    
850    
851  =head2 get_doc  =head2 get_doc
852    
853  Return single document  Return single document
# Line 636  Returns undef if document doesn't exist. Line 861  Returns undef if document doesn't exist.
861  sub get_doc {  sub get_doc {
862          my $self = shift;          my $self = shift;
863          my $num = shift;          my $num = shift;
864          croak "expect number as argument" unless ($num =~ m/^\d+$/);          croak "expect number as argument, not '$num'" unless ($num =~ m/^\d+$/);
865          return undef if ($num < 0 || $num > $self->{docs});          return undef if ($num < 0 || $num > $self->{docs});
866          return $self->{docs}->[$num];          return $self->{docs}->[$num];
867  }  }
868    
869    
870  =head2 hint  =head2 hint
871    
872  Return specific hint from results.  Return specific hint from results.
873    
874    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
875    
876  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>,
877  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 658  sub hint { Line 884  sub hint {
884          return $self->{hints}->{$key};          return $self->{hints}->{$key};
885  }  }
886    
887    =head2 hints
888    
889    More perlish version of C<hint>. This one returns hash.
890    
891      my %hints = $res->hints;
892    
893    =cut
894    
895    sub hints {
896            my $self = shift;
897            return $self->{hints};
898    }
899    
900    =head2 hits
901    
902    Syntaxtic sugar for total number of hits for this query
903    
904      print $res->hits;
905    
906    It's same as
907    
908      print $res->hint('HIT');
909    
910    but shorter.
911    
912    =cut
913    
914    sub hits {
915            my $self = shift;
916            return $self->{hints}->{'HIT'} || 0;
917    }
918    
919  package Search::Estraier::Node;  package Search::Estraier::Node;
920    
921  use Carp qw/croak/;  use Carp qw/carp croak confess/;
922    use URI;
923    use MIME::Base64;
924    use IO::Socket::INET;
925    use URI::Escape qw/uri_escape/;
926    
927  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
928    
# Line 669  use Carp qw/croak/; Line 930  use Carp qw/croak/;
930    
931    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
932    
933    or optionally with C<url> as parametar
934    
935      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
936    
937    or in more verbose form
938    
939      my $node = new Search::HyperEstraier::Node(
940            url => 'http://localhost:1978/node/test',
941            user => 'admin',
942            passwd => 'admin'
943            create => 1,
944            label => 'optional node label',
945            debug => 1,
946            croak_on_error => 1
947      );
948    
949    with following arguments:
950    
951    =over 4
952    
953    =item url
954    
955    URL to node
956    
957    =item user
958    
959    specify username for node server authentication
960    
961    =item passwd
962    
963    password for authentication
964    
965    =item create
966    
967    create node if it doesn't exists
968    
969    =item label
970    
971    optional label for new node if C<create> is used
972    
973    =item debug
974    
975    dumps a B<lot> of debugging output
976    
977    =item croak_on_error
978    
979    very helpful during development. It will croak on all errors instead of
980    silently returning C<-1> (which is convention of Hyper Estraier API in other
981    languages).
982    
983    =back
984    
985  =cut  =cut
986    
987  sub new {  sub new {
988          my $class = shift;          my $class = shift;
989          my $self = {          my $self = {
990                  pxport => -1,                  pxport => -1,
991                  timeout => -1,                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
992                  wwidth => 480,                  wwidth => 480,
993                  hwidth => 96,                  hwidth => 96,
994                  awidth => 96,                  awidth => 96,
995                  status => -1,                  status => -1,
996          };          };
997    
998          bless($self, $class);          bless($self, $class);
999    
1000            if ($#_ == 0) {
1001                    $self->{url} = shift;
1002            } else {
1003                    %$self = ( %$self, @_ );
1004    
1005                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
1006    
1007                    warn "## Node debug on\n" if ($self->{debug});
1008            }
1009    
1010            $self->{inform} = {
1011                    dnum => -1,
1012                    wnum => -1,
1013                    size => -1.0,
1014            };
1015    
1016            if ($self->{create}) {
1017                    if (! eval { $self->name } || $@) {
1018                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
1019                            croak "can't find node name in '$self->{url}'" unless ($name);
1020                            my $label = $self->{label} || $name;
1021                            $self->master(
1022                                    action => 'nodeadd',
1023                                    name => $name,
1024                                    label => $label,
1025                            ) || croak "can't create node $name ($label)";
1026                    }
1027            }
1028    
1029          $self ? return $self : return undef;          $self ? return $self : return undef;
1030  }  }
1031    
1032    
1033  =head2 set_url  =head2 set_url
1034    
1035  Specify URL to node server  Specify URL to node server
# Line 702  sub set_url { Line 1043  sub set_url {
1043          $self->{url} = shift;          $self->{url} = shift;
1044  }  }
1045    
1046    
1047  =head2 set_proxy  =head2 set_proxy
1048    
1049  Specify proxy server to connect to node server  Specify proxy server to connect to node server
# Line 713  Specify proxy server to connect to node Line 1055  Specify proxy server to connect to node
1055  sub set_proxy {  sub set_proxy {
1056          my $self = shift;          my $self = shift;
1057          my ($host,$port) = @_;          my ($host,$port) = @_;
1058          croak "proxy port must be number" unless ($port =~ m/^\d+$/);          croak "proxy port must be number, not '$port'" unless ($port =~ m/^\d+$/);
1059          $self->{pxhost} = $host;          $self->{pxhost} = $host;
1060          $self->{pxport} = $port;          $self->{pxport} = $port;
1061  }  }
1062    
1063    
1064  =head2 set_timeout  =head2 set_timeout
1065    
1066  Specify timeout of connection in seconds  Specify timeout of connection in seconds
# Line 729  Specify timeout of connection in seconds Line 1072  Specify timeout of connection in seconds
1072  sub set_timeout {  sub set_timeout {
1073          my $self = shift;          my $self = shift;
1074          my $sec = shift;          my $sec = shift;
1075          croak "timeout must be number" unless ($sec =~ m/^\d+$/);          croak "timeout must be number, not '$sec'" unless ($sec =~ m/^\d+$/);
1076          $self->{timeout} = $sec;          $self->{timeout} = $sec;
1077  }  }
1078    
 package Search::Estraier::Master;  
1079    
1080  use Carp;  =head2 set_auth
1081    
1082    Specify name and password for authentication to node server.
1083    
1084      $node->set_auth('clint','eastwood');
1085    
1086    =cut
1087    
1088    sub set_auth {
1089            my $self = shift;
1090            my ($login,$passwd) = @_;
1091            my $basic_auth = encode_base64( "$login:$passwd" );
1092            chomp($basic_auth);
1093            $self->{auth} = $basic_auth;
1094    }
1095    
1096    
1097    =head2 status
1098    
1099    Return status code of last request.
1100    
1101      print $node->status;
1102    
1103    C<-1> means connection failure.
1104    
1105    =cut
1106    
1107    sub status {
1108            my $self = shift;
1109            return $self->{status};
1110    }
1111    
1112    
1113    =head2 put_doc
1114    
1115    Add a document
1116    
1117  =head1 Search::Estraier::Master    $node->put_doc( $document_draft ) or die "can't add document";
1118    
1119  Controll node master. This requires user with administration priviledges.  Return true on success or false on failure.
1120    
1121  =cut  =cut
1122    
1123  {  sub put_doc {
1124          package RequestAgent;          my $self = shift;
1125          our @ISA = qw(LWP::UserAgent);          my $doc = shift || return;
1126            return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1127            if ($self->shuttle_url( $self->{url} . '/put_doc',
1128                    'text/x-estraier-draft',
1129                    $doc->dump_draft,
1130                    undef
1131            ) == 200) {
1132                    $self->_clear_info;
1133                    return 1;
1134            }
1135            return undef;
1136    }
1137    
1138    
1139    =head2 out_doc
1140    
1141          sub new {  Remove a document
1142                  my $self = LWP::UserAgent::new(@_);  
1143                  $self->agent("Search-Estraier/$Search::Estraer::VERSION");    $node->out_doc( document_id ) or "can't remove document";
1144                  $self;  
1145    Return true on success or false on failture.
1146    
1147    =cut
1148    
1149    sub out_doc {
1150            my $self = shift;
1151            my $id = shift || return;
1152            return unless ($self->{url});
1153            croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1154            if ($self->shuttle_url( $self->{url} . '/out_doc',
1155                    'application/x-www-form-urlencoded',
1156                    "id=$id",
1157                    undef
1158            ) == 200) {
1159                    $self->_clear_info;
1160                    return 1;
1161          }          }
1162            return undef;
1163    }
1164    
1165    
1166    =head2 out_doc_by_uri
1167    
1168          sub get_basic_credentials {  Remove a registrated document using it's uri
1169                  my($self, $realm, $uri) = @_;  
1170  #               return ($user, $password);    $node->out_doc_by_uri( 'file:///document/uri/42' ) or "can't remove document";
1171    
1172    Return true on success or false on failture.
1173    
1174    =cut
1175    
1176    sub out_doc_by_uri {
1177            my $self = shift;
1178            my $uri = shift || return;
1179            return unless ($self->{url});
1180            if ($self->shuttle_url( $self->{url} . '/out_doc',
1181                    'application/x-www-form-urlencoded',
1182                    "uri=" . uri_escape($uri),
1183                    undef
1184            ) == 200) {
1185                    $self->_clear_info;
1186                    return 1;
1187          }          }
1188            return undef;
1189  }  }
1190    
1191    
1192    =head2 edit_doc
1193    
1194  =head2 new  Edit attributes of a document
1195    
1196  Create new connection to node master.    $node->edit_doc( $document_draft ) or die "can't edit document";
1197    
1198    my $master = new Search::Estraier::Master(  Return true on success or false on failture.
1199          url => 'http://localhost:1978',  
1200          user => 'admin',  =cut
1201          passwd => 'admin',  
1202    sub edit_doc {
1203            my $self = shift;
1204            my $doc = shift || return;
1205            return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1206            if ($self->shuttle_url( $self->{url} . '/edit_doc',
1207                    'text/x-estraier-draft',
1208                    $doc->dump_draft,
1209                    undef
1210            ) == 200) {
1211                    $self->_clear_info;
1212                    return 1;
1213            }
1214            return undef;
1215    }
1216    
1217    
1218    =head2 get_doc
1219    
1220    Retreive document
1221    
1222      my $doc = $node->get_doc( document_id ) or die "can't get document";
1223    
1224    Return true on success or false on failture.
1225    
1226    =cut
1227    
1228    sub get_doc {
1229            my $self = shift;
1230            my $id = shift || return;
1231            return $self->_fetch_doc( id => $id );
1232    }
1233    
1234    
1235    =head2 get_doc_by_uri
1236    
1237    Retreive document
1238    
1239      my $doc = $node->get_doc_by_uri( 'file:///document/uri/42' ) or die "can't get document";
1240    
1241    Return true on success or false on failture.
1242    
1243    =cut
1244    
1245    sub get_doc_by_uri {
1246            my $self = shift;
1247            my $uri = shift || return;
1248            return $self->_fetch_doc( uri => $uri );
1249    }
1250    
1251    
1252    =head2 get_doc_attr
1253    
1254    Retrieve the value of an atribute from object
1255    
1256      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1257            die "can't get document attribute";
1258    
1259    =cut
1260    
1261    sub get_doc_attr {
1262            my $self = shift;
1263            my ($id,$name) = @_;
1264            return unless ($id && $name);
1265            return $self->_fetch_doc( id => $id, attr => $name );
1266    }
1267    
1268    
1269    =head2 get_doc_attr_by_uri
1270    
1271    Retrieve the value of an atribute from object
1272    
1273      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1274            die "can't get document attribute";
1275    
1276    =cut
1277    
1278    sub get_doc_attr_by_uri {
1279            my $self = shift;
1280            my ($uri,$name) = @_;
1281            return unless ($uri && $name);
1282            return $self->_fetch_doc( uri => $uri, attr => $name );
1283    }
1284    
1285    
1286    =head2 etch_doc
1287    
1288    Exctract document keywords
1289    
1290      my $keywords = $node->etch_doc( document_id ) or die "can't etch document";
1291    
1292    =cut
1293    
1294    sub etch_doc {
1295            my $self = shift;
1296            my $id = shift || return;
1297            return $self->_fetch_doc( id => $id, etch => 1 );
1298    }
1299    
1300    =head2 etch_doc_by_uri
1301    
1302    Retreive document
1303    
1304      my $keywords = $node->etch_doc_by_uri( 'file:///document/uri/42' ) or die "can't etch document";
1305    
1306    Return true on success or false on failture.
1307    
1308    =cut
1309    
1310    sub etch_doc_by_uri {
1311            my $self = shift;
1312            my $uri = shift || return;
1313            return $self->_fetch_doc( uri => $uri, etch => 1 );
1314    }
1315    
1316    
1317    =head2 uri_to_id
1318    
1319    Get ID of document specified by URI
1320    
1321      my $id = $node->uri_to_id( 'file:///document/uri/42' );
1322    
1323    This method won't croak, even if using C<croak_on_error>.
1324    
1325    =cut
1326    
1327    sub uri_to_id {
1328            my $self = shift;
1329            my $uri = shift || return;
1330            return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1, croak_on_error => 0 );
1331    }
1332    
1333    
1334    =head2 _fetch_doc
1335    
1336    Private function used for implementing of C<get_doc>, C<get_doc_by_uri>,
1337    C<etch_doc>, C<etch_doc_by_uri>.
1338    
1339     # this will decode received draft into Search::Estraier::Document object
1340     my $doc = $node->_fetch_doc( id => 42 );
1341     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42' );
1342    
1343     # to extract keywords, add etch
1344     my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1345     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1346    
1347     # to get document attrubute add attr
1348     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1349     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1350    
1351     # more general form which allows implementation of
1352     # uri_to_id
1353     my $id = $node->_fetch_doc(
1354            uri => 'file:///document/uri/42',
1355            path => '/uri_to_id',
1356            chomp_resbody => 1
1357     );
1358    
1359    =cut
1360    
1361    sub _fetch_doc {
1362            my $self = shift;
1363            my $a = {@_};
1364            return unless ( ($a->{id} || $a->{uri}) && $self->{url} );
1365    
1366            my ($arg, $resbody);
1367    
1368            my $path = $a->{path} || '/get_doc';
1369            $path = '/etch_doc' if ($a->{etch});
1370    
1371            if ($a->{id}) {
1372                    croak "id must be number not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
1373                    $arg = 'id=' . $a->{id};
1374            } elsif ($a->{uri}) {
1375                    $arg = 'uri=' . uri_escape($a->{uri});
1376            } else {
1377                    confess "unhandled argument. Need id or uri.";
1378            }
1379    
1380            if ($a->{attr}) {
1381                    $path = '/get_doc_attr';
1382                    $arg .= '&attr=' . uri_escape($a->{attr});
1383                    $a->{chomp_resbody} = 1;
1384            }
1385    
1386            my $rv = $self->shuttle_url( $self->{url} . $path,
1387                    'application/x-www-form-urlencoded',
1388                    $arg,
1389                    \$resbody,
1390                    $a->{croak_on_error},
1391            );
1392    
1393            return if ($rv != 200);
1394    
1395            if ($a->{etch}) {
1396                    $self->{kwords} = {};
1397                    return +{} unless ($resbody);
1398                    foreach my $l (split(/\n/, $resbody)) {
1399                            my ($k,$v) = split(/\t/, $l, 2);
1400                            $self->{kwords}->{$k} = $v if ($v);
1401                    }
1402                    return $self->{kwords};
1403            } elsif ($a->{chomp_resbody}) {
1404                    return unless (defined($resbody));
1405                    chomp($resbody);
1406                    return $resbody;
1407            } else {
1408                    return new Search::Estraier::Document($resbody);
1409            }
1410    }
1411    
1412    
1413    =head2 name
1414    
1415      my $node_name = $node->name;
1416    
1417    =cut
1418    
1419    sub name {
1420            my $self = shift;
1421            $self->_set_info unless ($self->{inform}->{name});
1422            return $self->{inform}->{name};
1423    }
1424    
1425    
1426    =head2 label
1427    
1428      my $node_label = $node->label;
1429    
1430    =cut
1431    
1432    sub label {
1433            my $self = shift;
1434            $self->_set_info unless ($self->{inform}->{label});
1435            return $self->{inform}->{label};
1436    }
1437    
1438    
1439    =head2 doc_num
1440    
1441      my $documents_in_node = $node->doc_num;
1442    
1443    =cut
1444    
1445    sub doc_num {
1446            my $self = shift;
1447            $self->_set_info if ($self->{inform}->{dnum} < 0);
1448            return $self->{inform}->{dnum};
1449    }
1450    
1451    
1452    =head2 word_num
1453    
1454      my $words_in_node = $node->word_num;
1455    
1456    =cut
1457    
1458    sub word_num {
1459            my $self = shift;
1460            $self->_set_info if ($self->{inform}->{wnum} < 0);
1461            return $self->{inform}->{wnum};
1462    }
1463    
1464    
1465    =head2 size
1466    
1467      my $node_size = $node->size;
1468    
1469    =cut
1470    
1471    sub size {
1472            my $self = shift;
1473            $self->_set_info if ($self->{inform}->{size} < 0);
1474            return $self->{inform}->{size};
1475    }
1476    
1477    
1478    =head2 search
1479    
1480    Search documents which match condition
1481    
1482      my $nres = $node->search( $cond, $depth );
1483    
1484    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1485    depth for meta search.
1486    
1487    Function results C<Search::Estraier::NodeResult> object.
1488    
1489    =cut
1490    
1491    sub search {
1492            my $self = shift;
1493            my ($cond, $depth) = @_;
1494            return unless ($cond && defined($depth) && $self->{url});
1495            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1496            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1497    
1498            my $resbody;
1499    
1500            my $rv = $self->shuttle_url( $self->{url} . '/search',
1501                    'application/x-www-form-urlencoded',
1502                    $self->cond_to_query( $cond, $depth ),
1503                    \$resbody,
1504            );
1505            return if ($rv != 200);
1506    
1507            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1508            my $hintsText   = splice @records, 0, 2; # starts with empty record
1509            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1510    
1511            # process records
1512            my $docs = [];
1513            foreach my $record (@records)
1514            {
1515                    # split into keys and snippets
1516                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1517    
1518                    # create document hash
1519                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1520                    $doc->{'@keywords'}     = $doc->{keywords};
1521                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1522                    $doc->{snippet}         = $snippet;
1523    
1524                    push @$docs, new Search::Estraier::ResultDocument(
1525                            attrs           => $doc,
1526                            uri             => $doc->{'@uri'},
1527                            snippet         => $snippet,
1528                            keywords        => $doc->{'keywords'},
1529                    );
1530            }
1531    
1532            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1533    }
1534    
1535    
1536    =head2 cond_to_query
1537    
1538    Return URI encoded string generated from Search::Estraier::Condition
1539    
1540      my $args = $node->cond_to_query( $cond, $depth );
1541    
1542    =cut
1543    
1544    sub cond_to_query {
1545            my $self = shift;
1546    
1547            my $cond = shift || return;
1548            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1549            my $depth = shift;
1550    
1551            my @args;
1552    
1553            if (my $phrase = $cond->phrase) {
1554                    push @args, 'phrase=' . uri_escape($phrase);
1555            }
1556    
1557            if (my @attrs = $cond->attrs) {
1558                    for my $i ( 0 .. $#attrs ) {
1559                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1560                    }
1561            }
1562    
1563            if (my $order = $cond->order) {
1564                    push @args, 'order=' . uri_escape($order);
1565            }
1566                    
1567            if (my $max = $cond->max) {
1568                    push @args, 'max=' . $max;
1569            } else {
1570                    push @args, 'max=' . (1 << 30);
1571            }
1572    
1573            if (my $options = $cond->options) {
1574                    push @args, 'options=' . $options;
1575            }
1576    
1577            push @args, 'depth=' . $depth if ($depth);
1578            push @args, 'wwidth=' . $self->{wwidth};
1579            push @args, 'hwidth=' . $self->{hwidth};
1580            push @args, 'awidth=' . $self->{awidth};
1581            push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
1582    
1583            if ($cond->{mask}) {
1584                    my $mask = 0;
1585                    map { $mask += ( 2 ** $_ ) } @{ $cond->{mask} };
1586    
1587                    push @args, 'mask=' . $mask if ($mask);
1588            }
1589    
1590            return join('&', @args);
1591    }
1592    
1593    
1594    =head2 shuttle_url
1595    
1596    This is method which uses C<LWP::UserAgent> to communicate with Hyper Estraier node
1597    master.
1598    
1599      my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1600    
1601    C<$resheads> and C<$resbody> booleans controll if response headers and/or response
1602    body will be saved within object.
1603    
1604    =cut
1605    
1606    use LWP::UserAgent;
1607    
1608    sub shuttle_url {
1609            my $self = shift;
1610    
1611            my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1612    
1613            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1614    
1615            $self->{status} = -1;
1616    
1617            warn "## $url\n" if ($self->{debug});
1618    
1619            $url = new URI($url);
1620            if (
1621                            !$url || !$url->scheme || !$url->scheme eq 'http' ||
1622                            !$url->host || !$url->port || $url->port < 1
1623                    ) {
1624                    carp "can't parse $url\n";
1625                    return -1;
1626            }
1627    
1628            my $ua = LWP::UserAgent->new;
1629            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1630    
1631            my $req;
1632            if ($reqbody) {
1633                    $req = HTTP::Request->new(POST => $url);
1634            } else {
1635                    $req = HTTP::Request->new(GET => $url);
1636            }
1637    
1638            $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1639            $req->headers->header( 'Connection', 'close' );
1640            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1641            $req->content_type( $content_type );
1642    
1643            warn $req->headers->as_string,"\n" if ($self->{debug});
1644    
1645            if ($reqbody) {
1646                    warn "$reqbody\n" if ($self->{debug});
1647                    $req->content( $reqbody );
1648            }
1649    
1650            my $res = $ua->request($req) || croak "can't make request to $url: $!";
1651    
1652            warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1653    
1654            ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1655    
1656            if (! $res->is_success) {
1657                    if ($croak_on_error) {
1658                            croak("can't get $url: ",$res->status_line);
1659                    } else {
1660                            return -1;
1661                    }
1662            }
1663    
1664            $$resbody .= $res->content;
1665    
1666            warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1667    
1668            return $self->{status};
1669    }
1670    
1671    
1672    =head2 set_snippet_width
1673    
1674    Set width of snippets in results
1675    
1676      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1677    
1678    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1679    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1680    
1681    C<$hwidth> specified width of strings from beginning of string. Default
1682    value is C<96>. Negative or zero value keep previous value.
1683    
1684    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1685    If negative of zero value is provided previous value is kept unchanged.
1686    
1687    =cut
1688    
1689    sub set_snippet_width {
1690            my $self = shift;
1691    
1692            my ($wwidth, $hwidth, $awidth) = @_;
1693            $self->{wwidth} = $wwidth;
1694            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1695            $self->{awidth} = $awidth if ($awidth >= 0);
1696    }
1697    
1698    
1699    =head2 set_user
1700    
1701    Manage users of node
1702    
1703      $node->set_user( 'name', $mode );
1704    
1705    C<$mode> can be one of:
1706    
1707    =over 4
1708    
1709    =item 0
1710    
1711    delete account
1712    
1713    =item 1
1714    
1715    set administrative right for user
1716    
1717    =item 2
1718    
1719    set user account as guest
1720    
1721    =back
1722    
1723    Return true on success, otherwise false.
1724    
1725    =cut
1726    
1727    sub set_user {
1728            my $self = shift;
1729            my ($name, $mode) = @_;
1730    
1731            return unless ($self->{url});
1732            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1733    
1734            $self->shuttle_url( $self->{url} . '/_set_user',
1735                    'application/x-www-form-urlencoded',
1736                    'name=' . uri_escape($name) . '&mode=' . $mode,
1737                    undef
1738            ) == 200;
1739    }
1740    
1741    
1742    =head2 set_link
1743    
1744    Manage node links
1745    
1746      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1747    
1748    If C<$credit> is negative, link is removed.
1749    
1750    =cut
1751    
1752    sub set_link {
1753            my $self = shift;
1754            my ($url, $label, $credit) = @_;
1755    
1756            return unless ($self->{url});
1757            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1758    
1759            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1760            $reqbody .= '&credit=' . $credit if ($credit > 0);
1761    
1762            if ($self->shuttle_url( $self->{url} . '/_set_link',
1763                    'application/x-www-form-urlencoded',
1764                    $reqbody,
1765                    undef
1766            ) == 200) {
1767                    # refresh node info after adding link
1768                    $self->_clear_info;
1769                    return 1;
1770            }
1771            return undef;
1772    }
1773    
1774    =head2 admins
1775    
1776     my @admins = @{ $node->admins };
1777    
1778    Return array of users with admin rights on node
1779    
1780    =cut
1781    
1782    sub admins {
1783            my $self = shift;
1784            $self->_set_info unless ($self->{inform}->{name});
1785            return $self->{inform}->{admins};
1786    }
1787    
1788    =head2 guests
1789    
1790     my @guests = @{ $node->guests };
1791    
1792    Return array of users with guest rights on node
1793    
1794    =cut
1795    
1796    sub guests {
1797            my $self = shift;
1798            $self->_set_info unless ($self->{inform}->{name});
1799            return $self->{inform}->{guests};
1800    }
1801    
1802    =head2 links
1803    
1804     my $links = @{ $node->links };
1805    
1806    Return array of links for this node
1807    
1808    =cut
1809    
1810    sub links {
1811            my $self = shift;
1812            $self->_set_info unless ($self->{inform}->{name});
1813            return $self->{inform}->{links};
1814    }
1815    
1816    =head2 cacheusage
1817    
1818    Return cache usage for a node
1819    
1820      my $cache = $node->cacheusage;
1821    
1822    =cut
1823    
1824    sub cacheusage {
1825            my $self = shift;
1826    
1827            return unless ($self->{url});
1828    
1829            my $resbody;
1830            my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
1831                    'text/plain',
1832                    undef,
1833                    \$resbody,
1834            );
1835    
1836            return if ($rv != 200 || !$resbody);
1837    
1838            return $resbody;
1839    }
1840    
1841    =head2 master
1842    
1843    Set actions on Hyper Estraier node master (C<estmaster> process)
1844    
1845      $node->master(
1846            action => 'sync'
1847    );    );
1848    
1849    All available actions are documented in
1850    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1851    
1852  =cut  =cut
1853    
1854  sub new {  my $estmaster_rest = {
1855          my $class = shift;          shutdown => {
1856          my $self = {@_};                  status => 202,
1857          bless($self, $class);          },
1858            sync => {
1859                    status => 202,
1860            },
1861            backup => {
1862                    status => 202,
1863            },
1864            userlist => {
1865                    status => 200,
1866                    returns => [ qw/name passwd flags fname misc/ ],
1867            },
1868            useradd => {
1869                    required => [ qw/name passwd flags/ ],
1870                    optional => [ qw/fname misc/ ],
1871                    status => 200,
1872            },
1873            userdel => {
1874                    required => [ qw/name/ ],
1875                    status => 200,
1876            },
1877            nodelist => {
1878                    status => 200,
1879                    returns => [ qw/name label doc_num word_num size/ ],
1880            },
1881            nodeadd => {
1882                    required => [ qw/name/ ],
1883                    optional => [ qw/label/ ],
1884                    status => 200,
1885            },
1886            nodedel => {
1887                    required => [ qw/name/ ],
1888                    status => 200,
1889            },
1890            nodeclr => {
1891                    required => [ qw/name/ ],
1892                    status => 200,
1893            },
1894            nodertt => {
1895                    status => 200,  
1896            },
1897    };
1898    
1899    sub master {
1900            my $self = shift;
1901    
1902            my $args = {@_};
1903    
1904            # have action?
1905            my $action = $args->{action} || croak "need action, available: ",
1906                    join(", ",keys %{ $estmaster_rest });
1907    
1908            # check if action is valid
1909            my $rest = $estmaster_rest->{$action};
1910            croak "action '$action' is not supported, available actions: ",
1911                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1912    
1913            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1914    
1915            my @args;
1916    
1917            if ($rest->{required} || $rest->{optional}) {
1918    
1919                    map {
1920                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1921                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1922                    } ( @{ $rest->{required} } );
1923    
1924                    map {
1925                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1926                    } ( @{ $rest->{optional} } );
1927    
         foreach my $p (qw/url user passwd/) {  
                 croak "need $p" unless ($self->{$p});  
1928          }          }
1929    
1930          $self ? return $self : return undef;          my $uri = new URI( $self->{url} );
1931    
1932            my $resbody;
1933    
1934            my $status = $self->shuttle_url(
1935                    'http://' . $uri->host_port . '/master?action=' . $action ,
1936                    'application/x-www-form-urlencoded',
1937                    join('&', @args),
1938                    \$resbody,
1939                    1,
1940            ) or confess "shuttle_url failed";
1941    
1942            if ($status == $rest->{status}) {
1943    
1944                    # refresh node info after sync
1945                    $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
1946    
1947                    if ($rest->{returns} && wantarray) {
1948    
1949                            my @results;
1950                            my $fields = $#{$rest->{returns}};
1951    
1952                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1953                                    my @e = split(/\t/, $line, $fields + 1);
1954                                    my $row;
1955                                    foreach my $i ( 0 .. $fields) {
1956                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1957                                    }
1958                                    push @results, $row;
1959                            }
1960    
1961                            return @results;
1962    
1963                    } elsif ($resbody) {
1964                            chomp $resbody;
1965                            return $resbody;
1966                    } else {
1967                            return 0E0;
1968                    }
1969            }
1970    
1971            carp "expected status $rest->{status}, but got $status";
1972            return undef;
1973  }  }
1974    
1975    =head1 PRIVATE METHODS
1976    
1977    You could call those directly, but you don't have to. I hope.
1978    
1979    =head2 _set_info
1980    
1981    Set information for node
1982    
1983      $node->_set_info;
1984    
1985    =cut
1986    
1987    sub _set_info {
1988            my $self = shift;
1989    
1990            $self->{status} = -1;
1991            return unless ($self->{url});
1992    
1993            my $resbody;
1994            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1995                    'text/plain',
1996                    undef,
1997                    \$resbody,
1998            );
1999    
2000            return if ($rv != 200 || !$resbody);
2001    
2002            my @lines = split(/[\r\n]/,$resbody);
2003    
2004            $self->_clear_info;
2005    
2006            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
2007                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
2008    
2009            return $resbody unless (@lines);
2010    
2011            shift @lines;
2012    
2013            while(my $admin = shift @lines) {
2014                    push @{$self->{inform}->{admins}}, $admin;
2015            }
2016    
2017            while(my $guest = shift @lines) {
2018                    push @{$self->{inform}->{guests}}, $guest;
2019            }
2020    
2021            while(my $link = shift @lines) {
2022                    push @{$self->{inform}->{links}}, $link;
2023            }
2024    
2025            return $resbody;
2026    
2027    }
2028    
2029    =head2 _clear_info
2030    
2031    Clear information for node
2032    
2033      $node->_clear_info;
2034    
2035    On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
2036    info will be fetch again from Hyper Estraier.
2037    
2038    =cut
2039    sub _clear_info {
2040            my $self = shift;
2041            $self->{inform} = {
2042                    dnum => -1,
2043                    wnum => -1,
2044                    size => -1.0,
2045            };
2046    }
2047    
2048  ###  ###
2049    
# Line 799  L<http://hyperestraier.sourceforge.net/> Line 2057  L<http://hyperestraier.sourceforge.net/>
2057    
2058  Hyper Estraier Ruby interface on which this module is based.  Hyper Estraier Ruby interface on which this module is based.
2059    
2060    Hyper Estraier now also has pure-perl binding included in distribution. It's
2061    a faster way to access databases directly if you are not running
2062    C<estmaster> P2P server.
2063    
2064  =head1 AUTHOR  =head1 AUTHOR
2065    
2066  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
2067    
2068    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
2069    
2070  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
2071    
Legend:
Removed from v.30  
changed lines
  Added in v.173
  ViewVC Help
Powered by ViewVC 1.1.26