/[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 6 by dpavlin, Wed Jan 4 14:48:11 2006 UTC revision 166 by dpavlin, Sun Aug 6 12:48:02 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  require Exporter;  our $VERSION = '0.07_3';
   
 our @ISA = qw(Exporter);  
   
 our %EXPORT_TAGS = ( 'all' => [ qw(  
 ) ] );  
   
 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );  
   
 our @EXPORT = qw(  
 );  
   
 our $VERSION = '0.00';  
   
 use Carp;  
8    
9  =head1 NAME  =head1 NAME
10    
# Line 26  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 39  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
91    
92    =head1 Inheritable common methods
93    
94    This methods should really move somewhere else.
95    
96    =head2 _s
97    
98    Remove multiple whitespaces from string, as well as whitespaces at beginning or end
99    
100     my $text = $self->_s(" this  is a text  ");
101     $text = 'this is a text';
102    
103  =cut  =cut
104    
105    sub _s {
106            my $text = $_[1];
107            return unless defined($text);
108            $text =~ s/\s\s+/ /gs;
109            $text =~ s/^\s+//;
110            $text =~ s/\s+$//;
111            return $text;
112    }
113    
114  package Search::Estraier::Document;  package Search::Estraier::Document;
115    
116    use Carp qw/croak confess/;
117    
118    use Search::Estraier;
119    our @ISA = qw/Search::Estraier/;
120    
121  =head1 Search::Estraier::Document  =head1 Search::Estraier::Document
122    
123  Document for HyperEstraier  This class implements Document which is single item in Hyper Estraier.
124    
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    
154    Create new document, empty or from draft.
155    
156    my $doc = new Search::HyperEstraier::Document;    my $doc = new Search::HyperEstraier::Document;
157      my $doc2 = new Search::HyperEstraier::Document( $draft );
158    
159  =cut  =cut
160    
161  sub new {  sub new {
162          my $class = shift;          my $class = shift;
163          my $self = {@_};          my $self = {};
164          bless($self, $class);          bless($self, $class);
165    
166          $self->{id} = -1;          $self->{id} = -1;
167    
168            my $draft = shift;
169    
170            if ($draft) {
171                    my $in_text = 0;
172                    foreach my $line (split(/\n/, $draft)) {
173    
174                            if ($in_text) {
175                                    if ($line =~ /^\t/) {
176                                            push @{ $self->{htexts} }, substr($line, 1);
177                                    } else {
178                                            push @{ $self->{dtexts} }, $line;
179                                    }
180                                    next;
181                            }
182    
183                            if ($line =~ m/^%VECTOR\t(.+)$/) {
184                                    my @fields = split(/\t/, $1);
185                                    if ($#fields % 2 == 1) {
186                                            $self->{kwords} = { @fields };
187                                    } else {
188                                            warn "can't decode $line\n";
189                                    }
190                                    next;
191                            } elsif ($line =~ m/^%/) {
192                                    # What is this? comment?
193                                    #warn "$line\n";
194                                    next;
195                            } elsif ($line =~ m/^$/) {
196                                    $in_text = 1;
197                                    next;
198                            } elsif ($line =~ m/^(.+)=(.*)$/) {
199                                    $self->{attrs}->{ $1 } = $2;
200                                    next;
201                            }
202    
203                            warn "draft ignored: '$line'\n";
204                    }
205            }
206    
207          $self ? return $self : return undef;          $self ? return $self : return undef;
208  }  }
209    
# Line 70  Add an attribute. Line 214  Add an attribute.
214    
215    $doc->add_attr( name => 'value' );    $doc->add_attr( name => 'value' );
216    
217  B<FIXME>: delete attribute using  Delete attribute using
218    
219    $doc->add_attr( name => undef );    $doc->add_attr( name => undef );
220    
# Line 81  sub add_attr { Line 225  sub add_attr {
225          my $attrs = {@_};          my $attrs = {@_};
226    
227          while (my ($name, $value) = each %{ $attrs }) {          while (my ($name, $value) = each %{ $attrs }) {
228                  push @{ $self->{attrs}->{_s($name)} }, _s($value);                  if (! defined($value)) {
229                            delete( $self->{attrs}->{ $self->_s($name) } );
230                    } else {
231                            $self->{attrs}->{ $self->_s($name) } = $self->_s($value);
232                    }
233          }          }
234    
235            return 1;
236  }  }
237    
238    
# Line 99  sub add_text { Line 249  sub add_text {
249          my $text = shift;          my $text = shift;
250          return unless defined($text);          return unless defined($text);
251    
252          push @{ $self->{dtexts} }, _s($text);          push @{ $self->{dtexts} }, $self->_s($text);
253  }  }
254    
255    
# Line 116  sub add_hidden_text { Line 266  sub add_hidden_text {
266          my $text = shift;          my $text = shift;
267          return unless defined($text);          return unless defined($text);
268    
269          push @{ $self->{htexts} }, _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 132  sub id { Line 304  sub id {
304          return $self->{id};          return $self->{id};
305  }  }
306    
307    
308    =head2 attr_names
309    
310    Returns array with attribute names from document object.
311    
312      my @attrs = $doc->attr_names;
313    
314    =cut
315    
316    sub attr_names {
317            my $self = shift;
318            return unless ($self->{attrs});
319            #croak "attr_names return array, not scalar" if (! wantarray);
320            return sort keys %{ $self->{attrs} };
321    }
322    
323    
324    =head2 attr
325    
326    Returns value of an attribute.
327    
328      my $value = $doc->attr( 'attribute' );
329    
330    =cut
331    
332    sub attr {
333            my $self = shift;
334            my $name = shift;
335            return unless (defined($name) && $self->{attrs});
336            return $self->{attrs}->{ $name };
337    }
338    
339    
340    =head2 texts
341    
342    Returns array with text sentences.
343    
344      my @texts = $doc->texts;
345    
346    =cut
347    
348    sub texts {
349            my $self = shift;
350            #confess "texts return array, not scalar" if (! wantarray);
351            return @{ $self->{dtexts} } if ($self->{dtexts});
352    }
353    
354    
355    =head2 cat_texts
356    
357    Return whole text as single scalar.
358    
359     my $text = $doc->cat_texts;
360    
361    =cut
362    
363    sub cat_texts {
364            my $self = shift;
365            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.
372    
373    print $doc->dump_draft;    print $doc->dump_draft;
374    
375  =cut  =cut
376    
377  sub dump_draft {  sub dump_draft {
378            my $self = shift;
379            my $draft;
380    
381            foreach my $attr_name (sort keys %{ $self->{attrs} }) {
382                    next unless defined(my $v = $self->{attrs}->{$attr_name});
383                    $draft .= $attr_name . '=' . $v . "\n";
384            }
385    
386            if ($self->{kwords}) {
387                    $draft .= '%VECTOR';
388                    while (my ($key, $value) = each %{ $self->{kwords} }) {
389                            $draft .= "\t$key\t$value";
390                    }
391                    $draft .= "\n";
392            }
393    
394            $draft .= "\n";
395    
396            $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
397            $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
398    
399            return $draft;
400  }  }
401    
402    
403  =head2 delete  =head2 delete
404    
405  Empty document object  Empty document object
406    
407    $doc->delete;    $doc->delete;
408    
409    This function is addition to original Ruby API, and since it was included in C wrappers it's here as a
410    convinience. Document objects which go out of scope will be destroyed
411    automatically.
412    
413  =cut  =cut
414    
415  sub delete {  sub delete {
416          my $self = shift;          my $self = shift;
417    
418          foreach my $data (qw/attrs dtexts stexts/) {          foreach my $data (qw/attrs dtexts stexts kwords/) {
419                  delete($self->{$data});                  delete($self->{$data});
420          }          }
421    
422            $self->{id} = -1;
423    
424          return 1;          return 1;
425  }  }
426    
427    
 =head2 _s  
428    
429  Remove multiple whitespaces from string, as well as whitespaces at beginning or end  package Search::Estraier::Condition;
430    
431   my $text = _s(" this  is a text  ");  use Carp qw/carp confess croak/;
432   $text = 'this is a text';  
433    use Search::Estraier;
434    our @ISA = qw/Search::Estraier/;
435    
436    =head1 Search::Estraier::Condition
437    
438    =head2 new
439    
440      my $cond = new Search::HyperEstraier::Condition;
441    
442  =cut  =cut
443    
444  sub _s {  sub new {
445          my $text = shift || return;          my $class = shift;
446          $text =~ s/\s\s+/ /gs;          my $self = {};
447          $text =~ s/^\s+//;          bless($self, $class);
448          $text =~ s/\s+$//;  
449          return $text;          $self->{max} = -1;
450            $self->{options} = 0;
451    
452            $self ? return $self : return undef;
453    }
454    
455    
456    =head2 set_phrase
457    
458      $cond->set_phrase('search phrase');
459    
460    =cut
461    
462    sub set_phrase {
463            my $self = shift;
464            $self->{phrase} = $self->_s( shift );
465    }
466    
467    
468    =head2 add_attr
469    
470      $cond->add_attr('@URI STRINC /~dpavlin/');
471    
472    =cut
473    
474    sub add_attr {
475            my $self = shift;
476            my $attr = shift || return;
477            push @{ $self->{attrs} }, $self->_s( $attr );
478  }  }
479    
480    
481    =head2 set_order
482    
483  package Search::Estraier::Master;    $cond->set_order('@mdate NUMD');
484    
485  use Carp;  =cut
486    
487    sub set_order {
488            my $self = shift;
489            $self->{order} = shift;
490    }
491    
 =head1 Search::Estraier::Master  
492    
493  Controll node master. This requires user with administration priviledges.  =head2 set_max
494    
495      $cond->set_max(42);
496    
497  =cut  =cut
498    
499  {  sub set_max {
500          package RequestAgent;          my $self = shift;
501          @ISA = qw(LWP::UserAgent);          my $max = shift;
502            croak "set_max needs number, not '$max'" unless ($max =~ m/^\d+$/);
503            $self->{max} = $max;
504    }
505    
506          sub new {  
507                  my $self = LWP::UserAgent::new(@_);  =head2 set_options
508                  $self->agent("Search-Estraier/$Search::Estraer::VERSION");  
509                  $self;    $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
549    
550    my $options = {
551            SURE => 1 << 0,
552            USUAL => 1 << 1,
553            FAST => 1 << 2,
554            AGITO => 1 << 3,
555            NOIDF => 1 << 4,
556            SIMPLE => 1 << 10,
557    };
558    
559    sub set_options {
560            my $self = shift;
561            my $opt = 0;
562            foreach my $option (@_) {
563                    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
578    
579    Return search phrase.
580    
581      print $cond->phrase;
582    
583    =cut
584    
585    sub phrase {
586            my $self = shift;
587            return $self->{phrase};
588    }
589    
590    
591    =head2 order
592    
593    Return search result order.
594    
595      print $cond->order;
596    
597    =cut
598    
599    sub order {
600            my $self = shift;
601            return $self->{order};
602    }
603    
604    
605    =head2 attrs
606    
607    Return search result attrs.
608    
609      my @cond_attrs = $cond->attrs;
610    
611    =cut
612    
613    sub attrs {
614            my $self = shift;
615            #croak "attrs return array, not scalar" if (! wantarray);
616            return @{ $self->{attrs} } if ($self->{attrs});
617    }
618    
619    
620    =head2 max
621    
622    Return maximum number of results.
623    
624      print $cond->max;
625    
626    C<-1> is returned for unitialized value, C<0> is unlimited.
627    
628    =cut
629    
630    sub max {
631            my $self = shift;
632            return $self->{max};
633    }
634    
635    
636    =head2 options
637    
638    Return options for this condition.
639    
640      print $cond->options;
641    
642    Options are returned in numerical form.
643    
644    =cut
645    
646    sub options {
647            my $self = shift;
648            return $self->{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    
681    package Search::Estraier::ResultDocument;
682    
683    use Carp qw/croak/;
684    
685    #use Search::Estraier;
686    #our @ISA = qw/Search::Estraier/;
687    
688    =head1 Search::Estraier::ResultDocument
689    
690    =head2 new
691    
692      my $rdoc = new Search::HyperEstraier::ResultDocument(
693            uri => 'http://localhost/document/uri/42',
694            attrs => {
695                    foo => 1,
696                    bar => 2,
697            },
698            snippet => 'this is a text of snippet'
699            keywords => 'this\tare\tkeywords'
700      );
701    
702    =cut
703    
704    sub new {
705            my $class = shift;
706            my $self = {@_};
707            bless($self, $class);
708    
709            croak "missing uri for ResultDocument" unless defined($self->{uri});
710    
711            $self ? return $self : return undef;
712    }
713    
714    
715    =head2 uri
716    
717    Return URI of result document
718    
719      print $rdoc->uri;
720    
721    =cut
722    
723    sub uri {
724            my $self = shift;
725            return $self->{uri};
726    }
727    
728    
729    =head2 attr_names
730    
731    Returns array with attribute names from result document object.
732    
733      my @attrs = $rdoc->attr_names;
734    
735    =cut
736    
737    sub attr_names {
738            my $self = shift;
739            croak "attr_names return array, not scalar" if (! wantarray);
740            return sort keys %{ $self->{attrs} };
741    }
742    
743          sub get_basic_credentials {  
744                  my($self, $realm, $uri) = @_;  =head2 attr
745  #               return ($user, $password);  
746    Returns value of an attribute.
747    
748      my $value = $rdoc->attr( 'attribute' );
749    
750    =cut
751    
752    sub attr {
753            my $self = shift;
754            my $name = shift || return;
755            return $self->{attrs}->{ $name };
756    }
757    
758    
759    =head2 snippet
760    
761    Return snippet from result document
762    
763      print $rdoc->snippet;
764    
765    =cut
766    
767    sub snippet {
768            my $self = shift;
769            return $self->{snippet};
770    }
771    
772    
773    =head2 keywords
774    
775    Return keywords from result document
776    
777      print $rdoc->keywords;
778    
779    =cut
780    
781    sub keywords {
782            my $self = shift;
783            return $self->{keywords};
784    }
785    
786    
787    package Search::Estraier::NodeResult;
788    
789    use Carp qw/croak/;
790    
791    #use Search::Estraier;
792    #our @ISA = qw/Search::Estraier/;
793    
794    =head1 Search::Estraier::NodeResult
795    
796    =head2 new
797    
798      my $res = new Search::HyperEstraier::NodeResult(
799            docs => @array_of_rdocs,
800            hits => %hash_with_hints,
801      );
802    
803    =cut
804    
805    sub new {
806            my $class = shift;
807            my $self = {@_};
808            bless($self, $class);
809    
810            foreach my $f (qw/docs hints/) {
811                    croak "missing $f for ResultDocument" unless defined($self->{$f});
812          }          }
813    
814            $self ? return $self : return undef;
815    }
816    
817    
818    =head2 doc_num
819    
820    Return number of documents
821    
822      print $res->doc_num;
823    
824    This will return real number of documents (limited by C<max>).
825    If you want to get total number of hits, see C<hits>.
826    
827    =cut
828    
829    sub doc_num {
830            my $self = shift;
831            return $#{$self->{docs}} + 1;
832    }
833    
834    
835    =head2 get_doc
836    
837    Return single document
838    
839      my $doc = $res->get_doc( 42 );
840    
841    Returns undef if document doesn't exist.
842    
843    =cut
844    
845    sub get_doc {
846            my $self = shift;
847            my $num = shift;
848            croak "expect number as argument, not '$num'" unless ($num =~ m/^\d+$/);
849            return undef if ($num < 0 || $num > $self->{docs});
850            return $self->{docs}->[$num];
851  }  }
852    
853    
854    =head2 hint
855    
856    Return specific hint from results.
857    
858      print $res->hint( 'VERSION' );
859    
860    Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
861    C<TIME>, C<LINK#n>, C<VIEW>.
862    
863    =cut
864    
865    sub hint {
866            my $self = shift;
867            my $key = shift || return;
868            return $self->{hints}->{$key};
869    }
870    
871    =head2 hints
872    
873    More perlish version of C<hint>. This one returns hash.
874    
875      my %hints = $res->hints;
876    
877    =cut
878    
879    sub hints {
880            my $self = shift;
881            return $self->{hints};
882    }
883    
884    =head2 hits
885    
886    Syntaxtic sugar for total number of hits for this query
887    
888      print $res->hits;
889    
890    It's same as
891    
892      print $res->hint('HIT');
893    
894    but shorter.
895    
896    =cut
897    
898    sub hits {
899            my $self = shift;
900            return $self->{hints}->{'HIT'} || 0;
901    }
902    
903    package Search::Estraier::Node;
904    
905    use Carp qw/carp croak confess/;
906    use URI;
907    use MIME::Base64;
908    use IO::Socket::INET;
909    use URI::Escape qw/uri_escape/;
910    
911    =head1 Search::Estraier::Node
912    
913  =head2 new  =head2 new
914    
915  Create new connection to node master.    my $node = new Search::HyperEstraier::Node;
916    
917    or optionally with C<url> as parametar
918    
919      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
920    
921    or in more verbose form
922    
923    my $master = new Search::Estraier::Master(    my $node = new Search::HyperEstraier::Node(
924          url => 'http://localhost:1978',          url => 'http://localhost:1978/node/test',
925          user => 'admin',          user => 'admin',
926          passwd => 'admin',          passwd => 'admin'
927            create => 1,
928            label => 'optional node label',
929            debug => 1,
930            croak_on_error => 1
931    );    );
932    
933    with following arguments:
934    
935    =over 4
936    
937    =item url
938    
939    URL to node
940    
941    =item user
942    
943    specify username for node server authentication
944    
945    =item passwd
946    
947    password for authentication
948    
949    =item create
950    
951    create node if it doesn't exists
952    
953    =item label
954    
955    optional label for new node if C<create> is used
956    
957    =item debug
958    
959    dumps a B<lot> of debugging output
960    
961    =item croak_on_error
962    
963    very helpful during development. It will croak on all errors instead of
964    silently returning C<-1> (which is convention of Hyper Estraier API in other
965    languages).
966    
967    =back
968    
969  =cut  =cut
970    
971  sub new {  sub new {
972          my $class = shift;          my $class = shift;
973          my $self = {@_};          my $self = {
974                    pxport => -1,
975                    timeout => 0,   # this used to be -1
976                    wwidth => 480,
977                    hwidth => 96,
978                    awidth => 96,
979                    status => -1,
980            };
981    
982          bless($self, $class);          bless($self, $class);
983    
984          foreach my $p (qw/url user passwd/) {          if ($#_ == 0) {
985                  croak "need $p" unless ($self->{$p});                  $self->{url} = shift;
986            } else {
987                    %$self = ( %$self, @_ );
988    
989                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
990    
991                    warn "## Node debug on\n" if ($self->{debug});
992            }
993    
994            $self->{inform} = {
995                    dnum => -1,
996                    wnum => -1,
997                    size => -1.0,
998            };
999    
1000            if ($self->{create}) {
1001                    if (! eval { $self->name } || $@) {
1002                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
1003                            croak "can't find node name in '$self->{url}'" unless ($name);
1004                            my $label = $self->{label} || $name;
1005                            $self->master(
1006                                    action => 'nodeadd',
1007                                    name => $name,
1008                                    label => $label,
1009                            ) || croak "can't create node $name ($label)";
1010                    }
1011          }          }
1012    
1013          $self ? return $self : return undef;          $self ? return $self : return undef;
1014  }  }
1015    
1016    
1017    =head2 set_url
1018    
1019    Specify URL to node server
1020    
1021      $node->set_url('http://localhost:1978');
1022    
1023    =cut
1024    
1025    sub set_url {
1026            my $self = shift;
1027            $self->{url} = shift;
1028    }
1029    
1030    
1031    =head2 set_proxy
1032    
1033    Specify proxy server to connect to node server
1034    
1035      $node->set_proxy('proxy.example.com', 8080);
1036    
1037    =cut
1038    
1039    sub set_proxy {
1040            my $self = shift;
1041            my ($host,$port) = @_;
1042            croak "proxy port must be number, not '$port'" unless ($port =~ m/^\d+$/);
1043            $self->{pxhost} = $host;
1044            $self->{pxport} = $port;
1045    }
1046    
1047    
1048    =head2 set_timeout
1049    
1050    Specify timeout of connection in seconds
1051    
1052      $node->set_timeout( 15 );
1053    
1054    =cut
1055    
1056    sub set_timeout {
1057            my $self = shift;
1058            my $sec = shift;
1059            croak "timeout must be number, not '$sec'" unless ($sec =~ m/^\d+$/);
1060            $self->{timeout} = $sec;
1061    }
1062    
1063    
1064    =head2 set_auth
1065    
1066    Specify name and password for authentication to node server.
1067    
1068      $node->set_auth('clint','eastwood');
1069    
1070    =cut
1071    
1072    sub set_auth {
1073            my $self = shift;
1074            my ($login,$passwd) = @_;
1075            my $basic_auth = encode_base64( "$login:$passwd" );
1076            chomp($basic_auth);
1077            $self->{auth} = $basic_auth;
1078    }
1079    
1080    
1081    =head2 status
1082    
1083    Return status code of last request.
1084    
1085      print $node->status;
1086    
1087    C<-1> means connection failure.
1088    
1089    =cut
1090    
1091    sub status {
1092            my $self = shift;
1093            return $self->{status};
1094    }
1095    
1096    
1097    =head2 put_doc
1098    
1099    Add a document
1100    
1101      $node->put_doc( $document_draft ) or die "can't add document";
1102    
1103    Return true on success or false on failure.
1104    
1105    =cut
1106    
1107    sub put_doc {
1108            my $self = shift;
1109            my $doc = shift || return;
1110            return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1111            if ($self->shuttle_url( $self->{url} . '/put_doc',
1112                    'text/x-estraier-draft',
1113                    $doc->dump_draft,
1114                    undef
1115            ) == 200) {
1116                    $self->_clear_info;
1117                    return 1;
1118            }
1119            return undef;
1120    }
1121    
1122    
1123    =head2 out_doc
1124    
1125    Remove a document
1126    
1127      $node->out_doc( document_id ) or "can't remove document";
1128    
1129    Return true on success or false on failture.
1130    
1131    =cut
1132    
1133    sub out_doc {
1134            my $self = shift;
1135            my $id = shift || return;
1136            return unless ($self->{url});
1137            croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1138            if ($self->shuttle_url( $self->{url} . '/out_doc',
1139                    'application/x-www-form-urlencoded',
1140                    "id=$id",
1141                    undef
1142            ) == 200) {
1143                    $self->_clear_info;
1144                    return 1;
1145            }
1146            return undef;
1147    }
1148    
1149    
1150    =head2 out_doc_by_uri
1151    
1152    Remove a registrated document using it's uri
1153    
1154      $node->out_doc_by_uri( 'file:///document/uri/42' ) or "can't remove document";
1155    
1156    Return true on success or false on failture.
1157    
1158    =cut
1159    
1160    sub out_doc_by_uri {
1161            my $self = shift;
1162            my $uri = shift || return;
1163            return unless ($self->{url});
1164            if ($self->shuttle_url( $self->{url} . '/out_doc',
1165                    'application/x-www-form-urlencoded',
1166                    "uri=" . uri_escape($uri),
1167                    undef
1168            ) == 200) {
1169                    $self->_clear_info;
1170                    return 1;
1171            }
1172            return undef;
1173    }
1174    
1175    
1176    =head2 edit_doc
1177    
1178    Edit attributes of a document
1179    
1180      $node->edit_doc( $document_draft ) or die "can't edit document";
1181    
1182    Return true on success or false on failture.
1183    
1184    =cut
1185    
1186    sub edit_doc {
1187            my $self = shift;
1188            my $doc = shift || return;
1189            return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1190            if ($self->shuttle_url( $self->{url} . '/edit_doc',
1191                    'text/x-estraier-draft',
1192                    $doc->dump_draft,
1193                    undef
1194            ) == 200) {
1195                    $self->_clear_info;
1196                    return 1;
1197            }
1198            return undef;
1199    }
1200    
1201    
1202    =head2 get_doc
1203    
1204    Retreive document
1205    
1206      my $doc = $node->get_doc( document_id ) or die "can't get document";
1207    
1208    Return true on success or false on failture.
1209    
1210    =cut
1211    
1212    sub get_doc {
1213            my $self = shift;
1214            my $id = shift || return;
1215            return $self->_fetch_doc( id => $id );
1216    }
1217    
1218    
1219    =head2 get_doc_by_uri
1220    
1221    Retreive document
1222    
1223      my $doc = $node->get_doc_by_uri( 'file:///document/uri/42' ) or die "can't get document";
1224    
1225    Return true on success or false on failture.
1226    
1227    =cut
1228    
1229    sub get_doc_by_uri {
1230            my $self = shift;
1231            my $uri = shift || return;
1232            return $self->_fetch_doc( uri => $uri );
1233    }
1234    
1235    
1236    =head2 get_doc_attr
1237    
1238    Retrieve the value of an atribute from object
1239    
1240      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1241            die "can't get document attribute";
1242    
1243    =cut
1244    
1245    sub get_doc_attr {
1246            my $self = shift;
1247            my ($id,$name) = @_;
1248            return unless ($id && $name);
1249            return $self->_fetch_doc( id => $id, attr => $name );
1250    }
1251    
1252    
1253    =head2 get_doc_attr_by_uri
1254    
1255    Retrieve the value of an atribute from object
1256    
1257      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1258            die "can't get document attribute";
1259    
1260    =cut
1261    
1262    sub get_doc_attr_by_uri {
1263            my $self = shift;
1264            my ($uri,$name) = @_;
1265            return unless ($uri && $name);
1266            return $self->_fetch_doc( uri => $uri, attr => $name );
1267    }
1268    
1269    
1270    =head2 etch_doc
1271    
1272    Exctract document keywords
1273    
1274      my $keywords = $node->etch_doc( document_id ) or die "can't etch document";
1275    
1276    =cut
1277    
1278    sub etch_doc {
1279            my $self = shift;
1280            my $id = shift || return;
1281            return $self->_fetch_doc( id => $id, etch => 1 );
1282    }
1283    
1284    =head2 etch_doc_by_uri
1285    
1286    Retreive document
1287    
1288      my $keywords = $node->etch_doc_by_uri( 'file:///document/uri/42' ) or die "can't etch document";
1289    
1290    Return true on success or false on failture.
1291    
1292    =cut
1293    
1294    sub etch_doc_by_uri {
1295            my $self = shift;
1296            my $uri = shift || return;
1297            return $self->_fetch_doc( uri => $uri, etch => 1 );
1298    }
1299    
1300    
1301    =head2 uri_to_id
1302    
1303    Get ID of document specified by URI
1304    
1305      my $id = $node->uri_to_id( 'file:///document/uri/42' );
1306    
1307    This method won't croak, even if using C<croak_on_error>.
1308    
1309    =cut
1310    
1311    sub uri_to_id {
1312            my $self = shift;
1313            my $uri = shift || return;
1314            return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1, croak_on_error => 0 );
1315    }
1316    
1317    
1318    =head2 _fetch_doc
1319    
1320    Private function used for implementing of C<get_doc>, C<get_doc_by_uri>,
1321    C<etch_doc>, C<etch_doc_by_uri>.
1322    
1323     # this will decode received draft into Search::Estraier::Document object
1324     my $doc = $node->_fetch_doc( id => 42 );
1325     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42' );
1326    
1327     # to extract keywords, add etch
1328     my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1329     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1330    
1331     # to get document attrubute add attr
1332     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1333     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1334    
1335     # more general form which allows implementation of
1336     # uri_to_id
1337     my $id = $node->_fetch_doc(
1338            uri => 'file:///document/uri/42',
1339            path => '/uri_to_id',
1340            chomp_resbody => 1
1341     );
1342    
1343    =cut
1344    
1345    sub _fetch_doc {
1346            my $self = shift;
1347            my $a = {@_};
1348            return unless ( ($a->{id} || $a->{uri}) && $self->{url} );
1349    
1350            my ($arg, $resbody);
1351    
1352            my $path = $a->{path} || '/get_doc';
1353            $path = '/etch_doc' if ($a->{etch});
1354    
1355            if ($a->{id}) {
1356                    croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
1357                    $arg = 'id=' . $a->{id};
1358            } elsif ($a->{uri}) {
1359                    $arg = 'uri=' . uri_escape($a->{uri});
1360            } else {
1361                    confess "unhandled argument. Need id or uri.";
1362            }
1363    
1364            if ($a->{attr}) {
1365                    $path = '/get_doc_attr';
1366                    $arg .= '&attr=' . uri_escape($a->{attr});
1367                    $a->{chomp_resbody} = 1;
1368            }
1369    
1370            my $rv = $self->shuttle_url( $self->{url} . $path,
1371                    'application/x-www-form-urlencoded',
1372                    $arg,
1373                    \$resbody,
1374                    $a->{croak_on_error},
1375            );
1376    
1377            return if ($rv != 200);
1378    
1379            if ($a->{etch}) {
1380                    $self->{kwords} = {};
1381                    return +{} unless ($resbody);
1382                    foreach my $l (split(/\n/, $resbody)) {
1383                            my ($k,$v) = split(/\t/, $l, 2);
1384                            $self->{kwords}->{$k} = $v if ($v);
1385                    }
1386                    return $self->{kwords};
1387            } elsif ($a->{chomp_resbody}) {
1388                    return unless (defined($resbody));
1389                    chomp($resbody);
1390                    return $resbody;
1391            } else {
1392                    return new Search::Estraier::Document($resbody);
1393            }
1394    }
1395    
1396    
1397    =head2 name
1398    
1399      my $node_name = $node->name;
1400    
1401    =cut
1402    
1403    sub name {
1404            my $self = shift;
1405            $self->_set_info unless ($self->{inform}->{name});
1406            return $self->{inform}->{name};
1407    }
1408    
1409    
1410    =head2 label
1411    
1412      my $node_label = $node->label;
1413    
1414    =cut
1415    
1416    sub label {
1417            my $self = shift;
1418            $self->_set_info unless ($self->{inform}->{label});
1419            return $self->{inform}->{label};
1420    }
1421    
1422    
1423    =head2 doc_num
1424    
1425      my $documents_in_node = $node->doc_num;
1426    
1427    =cut
1428    
1429    sub doc_num {
1430            my $self = shift;
1431            $self->_set_info if ($self->{inform}->{dnum} < 0);
1432            return $self->{inform}->{dnum};
1433    }
1434    
1435    
1436    =head2 word_num
1437    
1438      my $words_in_node = $node->word_num;
1439    
1440    =cut
1441    
1442    sub word_num {
1443            my $self = shift;
1444            $self->_set_info if ($self->{inform}->{wnum} < 0);
1445            return $self->{inform}->{wnum};
1446    }
1447    
1448    
1449    =head2 size
1450    
1451      my $node_size = $node->size;
1452    
1453    =cut
1454    
1455    sub size {
1456            my $self = shift;
1457            $self->_set_info if ($self->{inform}->{size} < 0);
1458            return $self->{inform}->{size};
1459    }
1460    
1461    
1462    =head2 search
1463    
1464    Search documents which match condition
1465    
1466      my $nres = $node->search( $cond, $depth );
1467    
1468    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1469    depth for meta search.
1470    
1471    Function results C<Search::Estraier::NodeResult> object.
1472    
1473    =cut
1474    
1475    sub search {
1476            my $self = shift;
1477            my ($cond, $depth) = @_;
1478            return unless ($cond && defined($depth) && $self->{url});
1479            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1480            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1481    
1482            my $resbody;
1483    
1484            my $rv = $self->shuttle_url( $self->{url} . '/search',
1485                    'application/x-www-form-urlencoded',
1486                    $self->cond_to_query( $cond, $depth ),
1487                    \$resbody,
1488            );
1489            return if ($rv != 200);
1490    
1491            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1492            my $hintsText   = splice @records, 0, 2; # starts with empty record
1493            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1494    
1495            # process records
1496            my $docs = [];
1497            foreach my $record (@records)
1498            {
1499                    # split into keys and snippets
1500                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1501    
1502                    # create document hash
1503                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1504                    $doc->{'@keywords'}     = $doc->{keywords};
1505                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1506                    $doc->{snippet}         = $snippet;
1507    
1508                    push @$docs, new Search::Estraier::ResultDocument(
1509                            attrs           => $doc,
1510                            uri             => $doc->{'@uri'},
1511                            snippet         => $snippet,
1512                            keywords        => $doc->{'keywords'},
1513                    );
1514            }
1515    
1516            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1517    }
1518    
1519    
1520    =head2 cond_to_query
1521    
1522    Return URI encoded string generated from Search::Estraier::Condition
1523    
1524      my $args = $node->cond_to_query( $cond, $depth );
1525    
1526    =cut
1527    
1528    sub cond_to_query {
1529            my $self = shift;
1530    
1531            my $cond = shift || return;
1532            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1533            my $depth = shift;
1534    
1535            my @args;
1536    
1537            if (my $phrase = $cond->phrase) {
1538                    push @args, 'phrase=' . uri_escape($phrase);
1539            }
1540    
1541            if (my @attrs = $cond->attrs) {
1542                    for my $i ( 0 .. $#attrs ) {
1543                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1544                    }
1545            }
1546    
1547            if (my $order = $cond->order) {
1548                    push @args, 'order=' . uri_escape($order);
1549            }
1550                    
1551            if (my $max = $cond->max) {
1552                    push @args, 'max=' . $max;
1553            } else {
1554                    push @args, 'max=' . (1 << 30);
1555            }
1556    
1557            if (my $options = $cond->options) {
1558                    push @args, 'options=' . $options;
1559            }
1560    
1561            push @args, 'depth=' . $depth if ($depth);
1562            push @args, 'wwidth=' . $self->{wwidth};
1563            push @args, 'hwidth=' . $self->{hwidth};
1564            push @args, 'awidth=' . $self->{awidth};
1565            push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
1566    
1567            return join('&', @args);
1568    }
1569    
1570    
1571    =head2 shuttle_url
1572    
1573    This is method which uses C<LWP::UserAgent> to communicate with Hyper Estraier node
1574    master.
1575    
1576      my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1577    
1578    C<$resheads> and C<$resbody> booleans controll if response headers and/or response
1579    body will be saved within object.
1580    
1581    =cut
1582    
1583    use LWP::UserAgent;
1584    
1585    sub shuttle_url {
1586            my $self = shift;
1587    
1588            my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1589    
1590            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1591    
1592            $self->{status} = -1;
1593    
1594            warn "## $url\n" if ($self->{debug});
1595    
1596            $url = new URI($url);
1597            if (
1598                            !$url || !$url->scheme || !$url->scheme eq 'http' ||
1599                            !$url->host || !$url->port || $url->port < 1
1600                    ) {
1601                    carp "can't parse $url\n";
1602                    return -1;
1603            }
1604    
1605            my $ua = LWP::UserAgent->new;
1606            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1607    
1608            my $req;
1609            if ($reqbody) {
1610                    $req = HTTP::Request->new(POST => $url);
1611            } else {
1612                    $req = HTTP::Request->new(GET => $url);
1613            }
1614    
1615            $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1616            $req->headers->header( 'Connection', 'close' );
1617            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1618            $req->content_type( $content_type );
1619    
1620            warn $req->headers->as_string,"\n" if ($self->{debug});
1621    
1622            if ($reqbody) {
1623                    warn "$reqbody\n" if ($self->{debug});
1624                    $req->content( $reqbody );
1625            }
1626    
1627            my $res = $ua->request($req) || croak "can't make request to $url: $!";
1628    
1629            warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1630    
1631            ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1632    
1633            if (! $res->is_success) {
1634                    if ($croak_on_error) {
1635                            croak("can't get $url: ",$res->status_line);
1636                    } else {
1637                            return -1;
1638                    }
1639            }
1640    
1641            $$resbody .= $res->content;
1642    
1643            warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1644    
1645            return $self->{status};
1646    }
1647    
1648    
1649    =head2 set_snippet_width
1650    
1651    Set width of snippets in results
1652    
1653      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1654    
1655    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1656    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1657    
1658    C<$hwidth> specified width of strings from beginning of string. Default
1659    value is C<96>. Negative or zero value keep previous value.
1660    
1661    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1662    If negative of zero value is provided previous value is kept unchanged.
1663    
1664    =cut
1665    
1666    sub set_snippet_width {
1667            my $self = shift;
1668    
1669            my ($wwidth, $hwidth, $awidth) = @_;
1670            $self->{wwidth} = $wwidth;
1671            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1672            $self->{awidth} = $awidth if ($awidth >= 0);
1673    }
1674    
1675    
1676    =head2 set_user
1677    
1678    Manage users of node
1679    
1680      $node->set_user( 'name', $mode );
1681    
1682    C<$mode> can be one of:
1683    
1684    =over 4
1685    
1686    =item 0
1687    
1688    delete account
1689    
1690    =item 1
1691    
1692    set administrative right for user
1693    
1694    =item 2
1695    
1696    set user account as guest
1697    
1698    =back
1699    
1700    Return true on success, otherwise false.
1701    
1702    =cut
1703    
1704    sub set_user {
1705            my $self = shift;
1706            my ($name, $mode) = @_;
1707    
1708            return unless ($self->{url});
1709            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1710    
1711            $self->shuttle_url( $self->{url} . '/_set_user',
1712                    'application/x-www-form-urlencoded',
1713                    'name=' . uri_escape($name) . '&mode=' . $mode,
1714                    undef
1715            ) == 200;
1716    }
1717    
1718    
1719    =head2 set_link
1720    
1721    Manage node links
1722    
1723      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1724    
1725    If C<$credit> is negative, link is removed.
1726    
1727    =cut
1728    
1729    sub set_link {
1730            my $self = shift;
1731            my ($url, $label, $credit) = @_;
1732    
1733            return unless ($self->{url});
1734            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1735    
1736            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1737            $reqbody .= '&credit=' . $credit if ($credit > 0);
1738    
1739            if ($self->shuttle_url( $self->{url} . '/_set_link',
1740                    'application/x-www-form-urlencoded',
1741                    $reqbody,
1742                    undef
1743            ) == 200) {
1744                    # refresh node info after adding link
1745                    $self->_clear_info;
1746                    return 1;
1747            }
1748            return undef;
1749    }
1750    
1751    =head2 admins
1752    
1753     my @admins = @{ $node->admins };
1754    
1755    Return array of users with admin rights on node
1756    
1757    =cut
1758    
1759    sub admins {
1760            my $self = shift;
1761            $self->_set_info unless ($self->{inform}->{name});
1762            return $self->{inform}->{admins};
1763    }
1764    
1765    =head2 guests
1766    
1767     my @guests = @{ $node->guests };
1768    
1769    Return array of users with guest rights on node
1770    
1771    =cut
1772    
1773    sub guests {
1774            my $self = shift;
1775            $self->_set_info unless ($self->{inform}->{name});
1776            return $self->{inform}->{guests};
1777    }
1778    
1779    =head2 links
1780    
1781     my $links = @{ $node->links };
1782    
1783    Return array of links for this node
1784    
1785    =cut
1786    
1787    sub links {
1788            my $self = shift;
1789            $self->_set_info unless ($self->{inform}->{name});
1790            return $self->{inform}->{links};
1791    }
1792    
1793    =head2 cacheusage
1794    
1795    Return cache usage for a node
1796    
1797      my $cache = $node->cacheusage;
1798    
1799    =cut
1800    
1801    sub cacheusage {
1802            my $self = shift;
1803    
1804            return unless ($self->{url});
1805    
1806            my $resbody;
1807            my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
1808                    'text/plain',
1809                    undef,
1810                    \$resbody,
1811            );
1812    
1813            return if ($rv != 200 || !$resbody);
1814    
1815            return $resbody;
1816    }
1817    
1818    =head2 master
1819    
1820    Set actions on Hyper Estraier node master (C<estmaster> process)
1821    
1822      $node->master(
1823            action => 'sync'
1824      );
1825    
1826    All available actions are documented in
1827    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1828    
1829    =cut
1830    
1831    my $estmaster_rest = {
1832            shutdown => {
1833                    status => 202,
1834            },
1835            sync => {
1836                    status => 202,
1837            },
1838            backup => {
1839                    status => 202,
1840            },
1841            userlist => {
1842                    status => 200,
1843                    returns => [ qw/name passwd flags fname misc/ ],
1844            },
1845            useradd => {
1846                    required => [ qw/name passwd flags/ ],
1847                    optional => [ qw/fname misc/ ],
1848                    status => 200,
1849            },
1850            userdel => {
1851                    required => [ qw/name/ ],
1852                    status => 200,
1853            },
1854            nodelist => {
1855                    status => 200,
1856                    returns => [ qw/name label doc_num word_num size/ ],
1857            },
1858            nodeadd => {
1859                    required => [ qw/name/ ],
1860                    optional => [ qw/label/ ],
1861                    status => 200,
1862            },
1863            nodedel => {
1864                    required => [ qw/name/ ],
1865                    status => 200,
1866            },
1867            nodeclr => {
1868                    required => [ qw/name/ ],
1869                    status => 200,
1870            },
1871            nodertt => {
1872                    status => 200,  
1873            },
1874    };
1875    
1876    sub master {
1877            my $self = shift;
1878    
1879            my $args = {@_};
1880    
1881            # have action?
1882            my $action = $args->{action} || croak "need action, available: ",
1883                    join(", ",keys %{ $estmaster_rest });
1884    
1885            # check if action is valid
1886            my $rest = $estmaster_rest->{$action};
1887            croak "action '$action' is not supported, available actions: ",
1888                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1889    
1890            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1891    
1892            my @args;
1893    
1894            if ($rest->{required} || $rest->{optional}) {
1895    
1896                    map {
1897                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1898                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1899                    } ( @{ $rest->{required} } );
1900    
1901                    map {
1902                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1903                    } ( @{ $rest->{optional} } );
1904    
1905            }
1906    
1907            my $uri = new URI( $self->{url} );
1908    
1909            my $resbody;
1910    
1911            my $status = $self->shuttle_url(
1912                    'http://' . $uri->host_port . '/master?action=' . $action ,
1913                    'application/x-www-form-urlencoded',
1914                    join('&', @args),
1915                    \$resbody,
1916                    1,
1917            ) or confess "shuttle_url failed";
1918    
1919            if ($status == $rest->{status}) {
1920    
1921                    # refresh node info after sync
1922                    $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
1923    
1924                    if ($rest->{returns} && wantarray) {
1925    
1926                            my @results;
1927                            my $fields = $#{$rest->{returns}};
1928    
1929                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1930                                    my @e = split(/\t/, $line, $fields + 1);
1931                                    my $row;
1932                                    foreach my $i ( 0 .. $fields) {
1933                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1934                                    }
1935                                    push @results, $row;
1936                            }
1937    
1938                            return @results;
1939    
1940                    } elsif ($resbody) {
1941                            chomp $resbody;
1942                            return $resbody;
1943                    } else {
1944                            return 0E0;
1945                    }
1946            }
1947    
1948            carp "expected status $rest->{status}, but got $status";
1949            return undef;
1950    }
1951    
1952    =head1 PRIVATE METHODS
1953    
1954    You could call those directly, but you don't have to. I hope.
1955    
1956    =head2 _set_info
1957    
1958    Set information for node
1959    
1960      $node->_set_info;
1961    
1962    =cut
1963    
1964    sub _set_info {
1965            my $self = shift;
1966    
1967            $self->{status} = -1;
1968            return unless ($self->{url});
1969    
1970            my $resbody;
1971            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1972                    'text/plain',
1973                    undef,
1974                    \$resbody,
1975            );
1976    
1977            return if ($rv != 200 || !$resbody);
1978    
1979            my @lines = split(/[\r\n]/,$resbody);
1980    
1981            $self->_clear_info;
1982    
1983            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1984                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1985    
1986            return $resbody unless (@lines);
1987    
1988            shift @lines;
1989    
1990            while(my $admin = shift @lines) {
1991                    push @{$self->{inform}->{admins}}, $admin;
1992            }
1993    
1994            while(my $guest = shift @lines) {
1995                    push @{$self->{inform}->{guests}}, $guest;
1996            }
1997    
1998            while(my $link = shift @lines) {
1999                    push @{$self->{inform}->{links}}, $link;
2000            }
2001    
2002            return $resbody;
2003    
2004    }
2005    
2006    =head2 _clear_info
2007    
2008    Clear information for node
2009    
2010      $node->_clear_info;
2011    
2012    On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
2013    info will be fetch again from Hyper Estraier.
2014    
2015    =cut
2016    sub _clear_info {
2017            my $self = shift;
2018            $self->{inform} = {
2019                    dnum => -1,
2020                    wnum => -1,
2021                    size => -1.0,
2022            };
2023    }
2024    
2025  ###  ###
2026    
# Line 245  L<http://hyperestraier.sourceforge.net/> Line 2034  L<http://hyperestraier.sourceforge.net/>
2034    
2035  Hyper Estraier Ruby interface on which this module is based.  Hyper Estraier Ruby interface on which this module is based.
2036    
2037    Hyper Estraier now also has pure-perl binding included in distribution. It's
2038    a faster way to access databases directly if you are not running
2039    C<estmaster> P2P server.
2040    
2041  =head1 AUTHOR  =head1 AUTHOR
2042    
2043  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
2044    
2045    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
2046    
2047  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
2048    
2049  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005-2006 by Dobrica Pavlinusic
2050    
2051  This library is free software; you can redistribute it and/or modify  This library is free software; you can redistribute it and/or modify
2052  it under the GPL v2 or later.  it under the GPL v2 or later.
Legend:
Removed from v.6  
changed lines
  Added in v.166
  ViewVC Help
Powered by ViewVC 1.1.26