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