/[Search-Estraier]/trunk/lib/Search/Estraier.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/Search/Estraier.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 30 by dpavlin, Thu Jan 5 15:33:48 2006 UTC revision 168 by dpavlin, Sun Aug 6 16:42:06 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.07_3';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node(
21                    url => 'http://localhost:1978/node/test',
22                    user => 'admin',
23                    passwd => 'admin',
24                    create => 1,
25                    label => 'Label for node',
26                    croak_on_error => 1,
27            );
28    
29            # create document
30            my $doc = new Search::Estraier::Document;
31    
32            # add attributes
33            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
34            $doc->add_attr('@title', "Over the Rainbow");
35    
36            # add body text to document
37            $doc->add_text("Somewhere over the rainbow.  Way up high.");
38            $doc->add_text("There's a land that I heard of once in a lullaby.");
39    
40            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
41    
42    =head2 Simple searcher
43    
44            use Search::Estraier;
45    
46            # create and configure node
47            my $node = new Search::Estraier::Node(
48                    url => 'http://localhost:1978/node/test',
49                    user => 'admin',
50                    passwd => 'admin',
51                    croak_on_error => 1,
52            );
53    
54            # create condition
55            my $cond = new Search::Estraier::Condition;
56    
57            # set search phrase
58            $cond->set_phrase("rainbow AND lullaby");
59    
60            my $nres = $node->search($cond, 0);
61    
62            if (defined($nres)) {
63                    print "Got ", $nres->hits, " results\n";
64    
65                    # for each document in results
66                    for my $i ( 0 ... $nres->doc_num - 1 ) {
67                            # get result document
68                            my $rdoc = $nres->get_doc($i);
69                            # display attribte
70                            print "URI: ", $rdoc->attr('@uri'),"\n";
71                            print "Title: ", $rdoc->attr('@title'),"\n";
72                            print $rdoc->snippet,"\n";
73                    }
74            } else {
75                    die "error: ", $node->status,"\n";
76            }
77    
78  =head1 DESCRIPTION  =head1 DESCRIPTION
79    
# Line 25  or Hyper Estraier development files on t Line 85  or Hyper Estraier development files on t
85  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
86  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
87    
88    There are few examples in C<scripts> directory of this distribution.
89    
90  =cut  =cut
91    
92    =head1 Inheritable common methods
93    
94    This methods should really move somewhere else.
95    
96  =head2 _s  =head2 _s
97    
98  Remove multiple whitespaces from string, as well as whitespaces at beginning or end  Remove multiple whitespaces from string, as well as whitespaces at beginning or end
# Line 37  Remove multiple whitespaces from string, Line 103  Remove multiple whitespaces from string,
103  =cut  =cut
104    
105  sub _s {  sub _s {
106          my $text = $_[1] || return;          my $text = $_[1];
107            return unless defined($text);
108          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
109          $text =~ s/^\s+//;          $text =~ s/^\s+//;
110          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 53  our @ISA = qw/Search::Estraier/; Line 120  our @ISA = qw/Search::Estraier/;
120    
121  =head1 Search::Estraier::Document  =head1 Search::Estraier::Document
122    
123  This class implements Document which is collection of attributes  This class implements Document which is single item in Hyper Estraier.
124  (key=value), vectors (also key value) display text and hidden text.  
125    It's is collection of:
126    
127    =over 4
128    
129    =item attributes
130    
131    C<< 'key' => 'value' >> pairs which can later be used for filtering of results
132    
133    You can add common filters to C<attrindex> in estmaster's C<_conf>
134    file for better performance. See C<attrindex> in
135    L<Hyper Estraier P2P Guide|http://hyperestraier.sourceforge.net/nguide-en.html>.
136    
137    =item vectors
138    
139    also C<< 'key' => 'value' >> pairs
140    
141    =item display text
142    
143    Text which will be used to create searchable corpus of your index and
144    included in snippet output.
145    
146    =item hidden text
147    
148    Text which will be searchable, but will not be included in snippet.
149    
150    =back
151    
152  =head2 new  =head2 new
153    
# Line 89  sub new { Line 182  sub new {
182    
183                          if ($line =~ m/^%VECTOR\t(.+)$/) {                          if ($line =~ m/^%VECTOR\t(.+)$/) {
184                                  my @fields = split(/\t/, $1);                                  my @fields = split(/\t/, $1);
185                                  for my $i ( 0 .. ($#fields - 1) ) {                                  if ($#fields % 2 == 1) {
186                                          $self->{kwords}->{ $fields[ $i ] } = $fields[ $i + 1 ];                                          $self->{kwords} = { @fields };
187                                          $i++;                                  } else {
188                                            warn "can't decode $line\n";
189                                  }                                  }
190                                  next;                                  next;
191                          } elsif ($line =~ m/^%/) {                          } elsif ($line =~ m/^%/) {
# Line 101  sub new { Line 195  sub new {
195                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
196                                  $in_text = 1;                                  $in_text = 1;
197                                  next;                                  next;
198                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
199                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
200                                  next;                                  next;
201                          }                          }
202    
203                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
204                  }                  }
205          }          }
206    
# Line 175  sub add_hidden_text { Line 269  sub add_hidden_text {
269          push @{ $self->{htexts} }, $self->_s($text);          push @{ $self->{htexts} }, $self->_s($text);
270  }  }
271    
272    =head2 add_vectors
273    
274    Add a vectors
275    
276      $doc->add_vector(
277            'vector_name' => 42,
278            'another' => 12345,
279      );
280    
281    =cut
282    
283    sub add_vectors {
284            my $self = shift;
285            return unless (@_);
286    
287            # this is ugly, but works
288            die "add_vector needs HASH as argument" unless ($#_ % 2 == 1);
289    
290            $self->{kwords} = {@_};
291    }
292    
293    
294  =head2 id  =head2 id
295    
296  Get the ID number of document. If the object has never been registred, C<-1> is returned.  Get the ID number of document. If the object has never been registred, C<-1> is returned.
# Line 188  sub id { Line 304  sub id {
304          return $self->{id};          return $self->{id};
305  }  }
306    
307    
308  =head2 attr_names  =head2 attr_names
309    
310  Returns array with attribute names from document object.  Returns array with attribute names from document object.
# Line 198  Returns array with attribute names from Line 315  Returns array with attribute names from
315    
316  sub attr_names {  sub attr_names {
317          my $self = shift;          my $self = shift;
318          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
319            #croak "attr_names return array, not scalar" if (! wantarray);
320          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
321  }  }
322    
# Line 214  Returns value of an attribute. Line 332  Returns value of an attribute.
332  sub attr {  sub attr {
333          my $self = shift;          my $self = shift;
334          my $name = shift;          my $name = shift;
335            return unless (defined($name) && $self->{attrs});
336          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
337  }  }
338    
339    
# Line 229  Returns array with text sentences. Line 347  Returns array with text sentences.
347    
348  sub texts {  sub texts {
349          my $self = shift;          my $self = shift;
350          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
351          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
352  }  }
353    
354    
355  =head2 cat_texts  =head2 cat_texts
356    
357  Return whole text as single scalar.  Return whole text as single scalar.
# Line 243  Return whole text as single scalar. Line 362  Return whole text as single scalar.
362    
363  sub cat_texts {  sub cat_texts {
364          my $self = shift;          my $self = shift;
365          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
366  }  }
367    
368    
369  =head2 dump_draft  =head2 dump_draft
370    
371  Dump draft data from document object.  Dump draft data from document object.
# Line 259  sub dump_draft { Line 379  sub dump_draft {
379          my $draft;          my $draft;
380    
381          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
382                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
383                    $draft .= $attr_name . '=' . $v . "\n";
384          }          }
385    
386          if ($self->{kwords}) {          if ($self->{kwords}) {
387                  $draft .= '%%VECTOR';                  $draft .= '%VECTOR';
388                  while (my ($key, $value) = each %{ $self->{kwords} }) {                  while (my ($key, $value) = each %{ $self->{kwords} }) {
389                          $draft .= "\t$key\t$value";                          $draft .= "\t$key\t$value";
390                  }                  }
# Line 272  sub dump_draft { Line 393  sub dump_draft {
393    
394          $draft .= "\n";          $draft .= "\n";
395    
396          $draft .= join("\n", @{ $self->{dtexts} }) . "\n";          $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
397          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
398    
399          return $draft;          return $draft;
400  }  }
401    
402    
403  =head2 delete  =head2 delete
404    
405  Empty document object  Empty document object
# Line 306  sub delete { Line 428  sub delete {
428    
429  package Search::Estraier::Condition;  package Search::Estraier::Condition;
430    
431  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
432    
433  use Search::Estraier;  use Search::Estraier;
434  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 330  sub new { Line 452  sub new {
452          $self ? return $self : return undef;          $self ? return $self : return undef;
453  }  }
454    
455    
456  =head2 set_phrase  =head2 set_phrase
457    
458    $cond->set_phrase('search phrase');    $cond->set_phrase('search phrase');
# Line 341  sub set_phrase { Line 464  sub set_phrase {
464          $self->{phrase} = $self->_s( shift );          $self->{phrase} = $self->_s( shift );
465  }  }
466    
467    
468  =head2 add_attr  =head2 add_attr
469    
470    $cond->add_attr('@URI STRINC /~dpavlin/');    $cond->add_attr('@URI STRINC /~dpavlin/');
# Line 353  sub add_attr { Line 477  sub add_attr {
477          push @{ $self->{attrs} }, $self->_s( $attr );          push @{ $self->{attrs} }, $self->_s( $attr );
478  }  }
479    
480    
481  =head2 set_order  =head2 set_order
482    
483    $cond->set_order('@mdate NUMD');    $cond->set_order('@mdate NUMD');
# Line 364  sub set_order { Line 489  sub set_order {
489          $self->{order} = shift;          $self->{order} = shift;
490  }  }
491    
492    
493  =head2 set_max  =head2 set_max
494    
495    $cond->set_max(42);    $cond->set_max(42);
# Line 373  sub set_order { Line 499  sub set_order {
499  sub set_max {  sub set_max {
500          my $self = shift;          my $self = shift;
501          my $max = shift;          my $max = shift;
502          croak "set_max needs number" unless ($max =~ m/^\d+$/);          croak "set_max needs number, not '$max'" unless ($max =~ m/^\d+$/);
503          $self->{max} = $max;          $self->{max} = $max;
504  }  }
505    
506    
507  =head2 set_options  =head2 set_options
508    
509    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
510    
511      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
512    
513    Possible options are:
514    
515    =over 8
516    
517    =item SURE
518    
519    check every N-gram
520    
521    =item USUAL
522    
523    check every second N-gram
524    
525    =item FAST
526    
527    check every third N-gram
528    
529    =item AGITO
530    
531    check every fourth N-gram
532    
533    =item NOIDF
534    
535    don't perform TF-IDF tuning
536    
537    =item SIMPLE
538    
539    use simplified query phrase
540    
541    =back
542    
543    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
544    options;
545    
546    This option changed in version C<0.04> of this module. It's backwards compatibile.
547    
548  =cut  =cut
549    
550  my $options = {  my $options = {
         # check N-gram keys skipping by three  
551          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
552          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
553          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
554          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
555          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
556          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
557  };  };
558    
559  sub set_options {  sub set_options {
560          my $self = shift;          my $self = shift;
561          my $option = shift;          my $opt = 0;
562          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
563          $self->{options} ||= $options->{$option};                  my $mask;
564                    unless ($mask = $options->{$option}) {
565                            if ($option eq '1') {
566                                    next;
567                            } else {
568                                    croak "unknown option $option";
569                            }
570                    }
571                    $opt += $mask;
572            }
573            $self->{options} = $opt;
574  }  }
575    
576    
577  =head2 phrase  =head2 phrase
578    
579  Return search phrase.  Return search phrase.
# Line 418  sub phrase { Line 587  sub phrase {
587          return $self->{phrase};          return $self->{phrase};
588  }  }
589    
590    
591  =head2 order  =head2 order
592    
593  Return search result order.  Return search result order.
# Line 431  sub order { Line 601  sub order {
601          return $self->{order};          return $self->{order};
602  }  }
603    
604    
605  =head2 attrs  =head2 attrs
606    
607  Return search result attrs.  Return search result attrs.
# Line 442  Return search result attrs. Line 613  Return search result attrs.
613  sub attrs {  sub attrs {
614          my $self = shift;          my $self = shift;
615          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
616          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
617  }  }
618    
619    
620  =head2 max  =head2 max
621    
622  Return maximum number of results.  Return maximum number of results.
# Line 460  sub max { Line 632  sub max {
632          return $self->{max};          return $self->{max};
633  }  }
634    
635    
636  =head2 options  =head2 options
637    
638  Return options for this condition.  Return options for this condition.
# Line 476  sub options { Line 649  sub options {
649  }  }
650    
651    
652    =head2 set_skip
653    
654    Set number of skipped documents from beginning of results
655    
656      $cond->set_skip(42);
657    
658    Similar to C<offset> in RDBMS.
659    
660    =cut
661    
662    sub set_skip {
663            my $self = shift;
664            $self->{skip} = shift;
665    }
666    
667    =head2 skip
668    
669    Return skip for this condition.
670    
671      print $cond->skip;
672    
673    =cut
674    
675    sub skip {
676            my $self = shift;
677            return $self->{skip};
678    }
679    
680    
681  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
682    
683  use Carp qw/croak/;  use Carp qw/croak/;
# Line 504  sub new { Line 706  sub new {
706          my $self = {@_};          my $self = {@_};
707          bless($self, $class);          bless($self, $class);
708    
709          foreach my $f (qw/uri attrs snippet keywords/) {          croak "missing uri for ResultDocument" unless defined($self->{uri});
                 croak "missing $f for ResultDocument" unless defined($self->{$f});  
         }  
710    
711          $self ? return $self : return undef;          $self ? return $self : return undef;
712  }  }
713    
714    
715  =head2 uri  =head2 uri
716    
717  Return URI of result document  Return URI of result document
# Line 539  sub attr_names { Line 740  sub attr_names {
740          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
741  }  }
742    
743    
744  =head2 attr  =head2 attr
745    
746  Returns value of an attribute.  Returns value of an attribute.
# Line 553  sub attr { Line 755  sub attr {
755          return $self->{attrs}->{ $name };          return $self->{attrs}->{ $name };
756  }  }
757    
758    
759  =head2 snippet  =head2 snippet
760    
761  Return snippet from result document  Return snippet from result document
# Line 566  sub snippet { Line 769  sub snippet {
769          return $self->{snippet};          return $self->{snippet};
770  }  }
771    
772    
773  =head2 keywords  =head2 keywords
774    
775  Return keywords from result document  Return keywords from result document
# Line 610  sub new { Line 814  sub new {
814          $self ? return $self : return undef;          $self ? return $self : return undef;
815  }  }
816    
817    
818  =head2 doc_num  =head2 doc_num
819    
820  Return number of documents  Return number of documents
821    
822    print $res->doc_num;    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  =cut
828    
829  sub doc_num {  sub doc_num {
830          my $self = shift;          my $self = shift;
831          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
832  }  }
833    
834    
835  =head2 get_doc  =head2 get_doc
836    
837  Return single document  Return single document
# Line 636  Returns undef if document doesn't exist. Line 845  Returns undef if document doesn't exist.
845  sub get_doc {  sub get_doc {
846          my $self = shift;          my $self = shift;
847          my $num = shift;          my $num = shift;
848          croak "expect number as argument" unless ($num =~ m/^\d+$/);          croak "expect number as argument, not '$num'" unless ($num =~ m/^\d+$/);
849          return undef if ($num < 0 || $num > $self->{docs});          return undef if ($num < 0 || $num > $self->{docs});
850          return $self->{docs}->[$num];          return $self->{docs}->[$num];
851  }  }
852    
853    
854  =head2 hint  =head2 hint
855    
856  Return specific hint from results.  Return specific hint from results.
857    
858    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
859    
860  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
861  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 658  sub hint { Line 868  sub hint {
868          return $self->{hints}->{$key};          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;  package Search::Estraier::Node;
904    
905  use Carp qw/croak/;  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  =head1 Search::Estraier::Node
912    
# Line 669  use Carp qw/croak/; Line 914  use Carp qw/croak/;
914    
915    my $node = new Search::HyperEstraier::Node;    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 $node = new Search::HyperEstraier::Node(
924            url => 'http://localhost:1978/node/test',
925            user => 'admin',
926            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,                  pxport => -1,
975                  timeout => -1,                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
976                  wwidth => 480,                  wwidth => 480,
977                  hwidth => 96,                  hwidth => 96,
978                  awidth => 96,                  awidth => 96,
979                  status => -1,                  status => -1,
980          };          };
981    
982          bless($self, $class);          bless($self, $class);
983    
984            if ($#_ == 0) {
985                    $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  =head2 set_url
1018    
1019  Specify URL to node server  Specify URL to node server
# Line 702  sub set_url { Line 1027  sub set_url {
1027          $self->{url} = shift;          $self->{url} = shift;
1028  }  }
1029    
1030    
1031  =head2 set_proxy  =head2 set_proxy
1032    
1033  Specify proxy server to connect to node server  Specify proxy server to connect to node server
# Line 713  Specify proxy server to connect to node Line 1039  Specify proxy server to connect to node
1039  sub set_proxy {  sub set_proxy {
1040          my $self = shift;          my $self = shift;
1041          my ($host,$port) = @_;          my ($host,$port) = @_;
1042          croak "proxy port must be number" unless ($port =~ m/^\d+$/);          croak "proxy port must be number, not '$port'" unless ($port =~ m/^\d+$/);
1043          $self->{pxhost} = $host;          $self->{pxhost} = $host;
1044          $self->{pxport} = $port;          $self->{pxport} = $port;
1045  }  }
1046    
1047    
1048  =head2 set_timeout  =head2 set_timeout
1049    
1050  Specify timeout of connection in seconds  Specify timeout of connection in seconds
# Line 729  Specify timeout of connection in seconds Line 1056  Specify timeout of connection in seconds
1056  sub set_timeout {  sub set_timeout {
1057          my $self = shift;          my $self = shift;
1058          my $sec = shift;          my $sec = shift;
1059          croak "timeout must be number" unless ($sec =~ m/^\d+$/);          croak "timeout must be number, not '$sec'" unless ($sec =~ m/^\d+$/);
1060          $self->{timeout} = $sec;          $self->{timeout} = $sec;
1061  }  }
1062    
 package Search::Estraier::Master;  
1063    
1064  use Carp;  =head2 set_auth
1065    
1066  =head1 Search::Estraier::Master  Specify name and password for authentication to node server.
1067    
1068  Controll node master. This requires user with administration priviledges.    $node->set_auth('clint','eastwood');
1069    
1070  =cut  =cut
1071    
1072  {  sub set_auth {
1073          package RequestAgent;          my $self = shift;
1074          our @ISA = qw(LWP::UserAgent);          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          sub new {  Return status code of last request.
1084                  my $self = LWP::UserAgent::new(@_);  
1085                  $self->agent("Search-Estraier/$Search::Estraer::VERSION");    print $node->status;
1086                  $self;  
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          sub get_basic_credentials {  =head2 out_doc
1124                  my($self, $realm, $uri) = @_;  
1125  #               return ($user, $password);  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  =head2 new  Remove a registrated document using it's uri
1153    
1154  Create new connection to node master.    $node->out_doc_by_uri( 'file:///document/uri/42' ) or "can't remove document";
1155    
1156    my $master = new Search::Estraier::Master(  Return true on success or false on failture.
1157          url => 'http://localhost:1978',  
1158          user => 'admin',  =cut
1159          passwd => 'admin',  
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 number 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  =cut
1830    
1831  sub new {  my $estmaster_rest = {
1832          my $class = shift;          shutdown => {
1833          my $self = {@_};                  status => 202,
1834          bless($self, $class);          },
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    
         foreach my $p (qw/url user passwd/) {  
                 croak "need $p" unless ($self->{$p});  
1905          }          }
1906    
1907          $self ? return $self : return undef;          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 799  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    
Legend:
Removed from v.30  
changed lines
  Added in v.168
  ViewVC Help
Powered by ViewVC 1.1.26