/[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 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  our $VERSION = '0.00';  our $VERSION = '0.07_2';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node(
21                    url => 'http://localhost:1978/node/test',
22                    user => 'admin',
23                    passwd => 'admin',
24                    create => 1,
25                    label => 'Label for node',
26                    croak_on_error => 1,
27            );
28    
29            # create document
30            my $doc = new Search::Estraier::Document;
31    
32            # add attributes
33            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
34            $doc->add_attr('@title', "Over the Rainbow");
35    
36            # add body text to document
37            $doc->add_text("Somewhere over the rainbow.  Way up high.");
38            $doc->add_text("There's a land that I heard of once in a lullaby.");
39    
40            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
41    
42    =head2 Simple searcher
43    
44            use Search::Estraier;
45    
46            # create and configure node
47            my $node = new Search::Estraier::Node(
48                    url => 'http://localhost:1978/node/test',
49                    user => 'admin',
50                    passwd => 'admin',
51                    croak_on_error => 1,
52            );
53    
54            # create condition
55            my $cond = new Search::Estraier::Condition;
56    
57            # set search phrase
58            $cond->set_phrase("rainbow AND lullaby");
59    
60            my $nres = $node->search($cond, 0);
61    
62            if (defined($nres)) {
63                    print "Got ", $nres->hits, " results\n";
64    
65                    # for each document in results
66                    for my $i ( 0 ... $nres->doc_num - 1 ) {
67                            # get result document
68                            my $rdoc = $nres->get_doc($i);
69                            # display attribte
70                            print "URI: ", $rdoc->attr('@uri'),"\n";
71                            print "Title: ", $rdoc->attr('@title'),"\n";
72                            print $rdoc->snippet,"\n";
73                    }
74            } else {
75                    die "error: ", $node->status,"\n";
76            }
77    
78  =head1 DESCRIPTION  =head1 DESCRIPTION
79    
# Line 25  or Hyper Estraier development files on t Line 85  or Hyper Estraier development files on t
85  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
86  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
87    
88    There are few examples in C<scripts> directory of this distribution.
89    
90  =cut  =cut
91    
92    =head1 Inheritable common methods
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 101  sub new { Line 194  sub new {
194                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
195                                  $in_text = 1;                                  $in_text = 1;
196                                  next;                                  next;
197                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
198                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
199                                  next;                                  next;
200                          }                          }
201    
202                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
203                  }                  }
204          }          }
205    
# Line 175  sub add_hidden_text { Line 268  sub add_hidden_text {
268          push @{ $self->{htexts} }, $self->_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 188  sub id { Line 282  sub id {
282          return $self->{id};          return $self->{id};
283  }  }
284    
285    
286  =head2 attr_names  =head2 attr_names
287    
288  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 293  Returns array with attribute names from
293    
294  sub attr_names {  sub attr_names {
295          my $self = shift;          my $self = shift;
296          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
297            #croak "attr_names return array, not scalar" if (! wantarray);
298          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
299  }  }
300    
# Line 214  Returns value of an attribute. Line 310  Returns value of an attribute.
310  sub attr {  sub attr {
311          my $self = shift;          my $self = shift;
312          my $name = shift;          my $name = shift;
313            return unless (defined($name) && $self->{attrs});
314          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
315  }  }
316    
317    
# Line 229  Returns array with text sentences. Line 325  Returns array with text sentences.
325    
326  sub texts {  sub texts {
327          my $self = shift;          my $self = shift;
328          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
329          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
330  }  }
331    
332    
333  =head2 cat_texts  =head2 cat_texts
334    
335  Return whole text as single scalar.  Return whole text as single scalar.
# Line 243  Return whole text as single scalar. Line 340  Return whole text as single scalar.
340    
341  sub cat_texts {  sub cat_texts {
342          my $self = shift;          my $self = shift;
343          return join(' ',@{ $self->{dtexts} });          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.  Dump draft data from document object.
# Line 259  sub dump_draft { Line 357  sub dump_draft {
357          my $draft;          my $draft;
358    
359          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
360                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
361                    $draft .= $attr_name . '=' . $v . "\n";
362          }          }
363    
364          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 272  sub dump_draft { Line 371  sub dump_draft {
371    
372          $draft .= "\n";          $draft .= "\n";
373    
374          $draft .= join("\n", @{ $self->{dtexts} }) . "\n";          $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
375          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
376    
377          return $draft;          return $draft;
378  }  }
379    
380    
381  =head2 delete  =head2 delete
382    
383  Empty document object  Empty document object
# Line 306  sub delete { Line 406  sub delete {
406    
407  package Search::Estraier::Condition;  package Search::Estraier::Condition;
408    
409  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
410    
411  use Search::Estraier;  use Search::Estraier;
412  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 330  sub new { Line 430  sub new {
430          $self ? return $self : return undef;          $self ? return $self : return undef;
431  }  }
432    
433    
434  =head2 set_phrase  =head2 set_phrase
435    
436    $cond->set_phrase('search phrase');    $cond->set_phrase('search phrase');
# Line 341  sub set_phrase { Line 442  sub set_phrase {
442          $self->{phrase} = $self->_s( shift );          $self->{phrase} = $self->_s( shift );
443  }  }
444    
445    
446  =head2 add_attr  =head2 add_attr
447    
448    $cond->add_attr('@URI STRINC /~dpavlin/');    $cond->add_attr('@URI STRINC /~dpavlin/');
# Line 353  sub add_attr { Line 455  sub add_attr {
455          push @{ $self->{attrs} }, $self->_s( $attr );          push @{ $self->{attrs} }, $self->_s( $attr );
456  }  }
457    
458    
459  =head2 set_order  =head2 set_order
460    
461    $cond->set_order('@mdate NUMD');    $cond->set_order('@mdate NUMD');
# Line 364  sub set_order { Line 467  sub set_order {
467          $self->{order} = shift;          $self->{order} = shift;
468  }  }
469    
470    
471  =head2 set_max  =head2 set_max
472    
473    $cond->set_max(42);    $cond->set_max(42);
# Line 373  sub set_order { Line 477  sub set_order {
477  sub set_max {  sub set_max {
478          my $self = shift;          my $self = shift;
479          my $max = shift;          my $max = shift;
480          croak "set_max needs number" unless ($max =~ m/^\d+$/);          croak "set_max needs number, not '$max'" unless ($max =~ m/^\d+$/);
481          $self->{max} = $max;          $self->{max} = $max;
482  }  }
483    
484    
485  =head2 set_options  =head2 set_options
486    
487    $cond->set_options( SURE => 1 );    $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    =item NOIDF
512    
513    don't perform TF-IDF tuning
514    
515    =item SIMPLE
516    
517    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 = {  my $options = {
         # check N-gram keys skipping by three  
529          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
530          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
531          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
532          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
533          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
534          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
535  };  };
536    
537  sub set_options {  sub set_options {
538          my $self = shift;          my $self = shift;
539          my $option = shift;          my $opt = 0;
540          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
541          $self->{options} ||= $options->{$option};                  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  =head2 phrase
556    
557  Return search phrase.  Return search phrase.
# Line 418  sub phrase { Line 565  sub phrase {
565          return $self->{phrase};          return $self->{phrase};
566  }  }
567    
568    
569  =head2 order  =head2 order
570    
571  Return search result order.  Return search result order.
# Line 431  sub order { Line 579  sub order {
579          return $self->{order};          return $self->{order};
580  }  }
581    
582    
583  =head2 attrs  =head2 attrs
584    
585  Return search result attrs.  Return search result attrs.
# Line 442  Return search result attrs. Line 591  Return search result attrs.
591  sub attrs {  sub attrs {
592          my $self = shift;          my $self = shift;
593          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
594          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
595  }  }
596    
597    
598  =head2 max  =head2 max
599    
600  Return maximum number of results.  Return maximum number of results.
# Line 460  sub max { Line 610  sub max {
610          return $self->{max};          return $self->{max};
611  }  }
612    
613    
614  =head2 options  =head2 options
615    
616  Return options for this condition.  Return options for this condition.
# Line 476  sub options { Line 627  sub 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;  package Search::Estraier::ResultDocument;
660    
661  use Carp qw/croak/;  use Carp qw/croak/;
# Line 504  sub new { Line 684  sub new {
684          my $self = {@_};          my $self = {@_};
685          bless($self, $class);          bless($self, $class);
686    
687          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});  
         }  
688    
689          $self ? return $self : return undef;          $self ? return $self : return undef;
690  }  }
691    
692    
693  =head2 uri  =head2 uri
694    
695  Return URI of result document  Return URI of result document
# Line 539  sub attr_names { Line 718  sub attr_names {
718          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
719  }  }
720    
721    
722  =head2 attr  =head2 attr
723    
724  Returns value of an attribute.  Returns value of an attribute.
# Line 553  sub attr { Line 733  sub attr {
733          return $self->{attrs}->{ $name };          return $self->{attrs}->{ $name };
734  }  }
735    
736    
737  =head2 snippet  =head2 snippet
738    
739  Return snippet from result document  Return snippet from result document
# Line 566  sub snippet { Line 747  sub snippet {
747          return $self->{snippet};          return $self->{snippet};
748  }  }
749    
750    
751  =head2 keywords  =head2 keywords
752    
753  Return keywords from result document  Return keywords from result document
# Line 610  sub new { Line 792  sub new {
792          $self ? return $self : return undef;          $self ? return $self : return undef;
793  }  }
794    
795    
796  =head2 doc_num  =head2 doc_num
797    
798  Return number of documents  Return number of documents
799    
800    print $res->doc_num;    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  =cut
806    
807  sub doc_num {  sub doc_num {
808          my $self = shift;          my $self = shift;
809          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
810  }  }
811    
812    
813  =head2 get_doc  =head2 get_doc
814    
815  Return single document  Return single document
# Line 636  Returns undef if document doesn't exist. Line 823  Returns undef if document doesn't exist.
823  sub get_doc {  sub get_doc {
824          my $self = shift;          my $self = shift;
825          my $num = shift;          my $num = shift;
826          croak "expect number as argument" unless ($num =~ m/^\d+$/);          croak "expect number as argument, not '$num'" unless ($num =~ m/^\d+$/);
827          return undef if ($num < 0 || $num > $self->{docs});          return undef if ($num < 0 || $num > $self->{docs});
828          return $self->{docs}->[$num];          return $self->{docs}->[$num];
829  }  }
830    
831    
832  =head2 hint  =head2 hint
833    
834  Return specific hint from results.  Return specific hint from results.
835    
836    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
837    
838  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>,
839  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 658  sub hint { Line 846  sub hint {
846          return $self->{hints}->{$key};          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;  package Search::Estraier::Node;
882    
883  use Carp qw/croak/;  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  =head1 Search::Estraier::Node
890    
# Line 669  use Carp qw/croak/; Line 892  use Carp qw/croak/;
892    
893    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
894    
895    or optionally with C<url> as parametar
896    
897      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
898    
899    or in more verbose form
900    
901      my $node = new Search::HyperEstraier::Node(
902            url => 'http://localhost:1978/node/test',
903            user => 'admin',
904            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,                  pxport => -1,
953                  timeout => -1,                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
954                  wwidth => 480,                  wwidth => 480,
955                  hwidth => 96,                  hwidth => 96,
956                  awidth => 96,                  awidth => 96,
957                  status => -1,                  status => -1,
958          };          };
959    
960          bless($self, $class);          bless($self, $class);
961    
962            if ($#_ == 0) {
963                    $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  =head2 set_url
996    
997  Specify URL to node server  Specify URL to node server
# Line 702  sub set_url { Line 1005  sub set_url {
1005          $self->{url} = shift;          $self->{url} = shift;
1006  }  }
1007    
1008    
1009  =head2 set_proxy  =head2 set_proxy
1010    
1011  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 1017  Specify proxy server to connect to node
1017  sub set_proxy {  sub set_proxy {
1018          my $self = shift;          my $self = shift;
1019          my ($host,$port) = @_;          my ($host,$port) = @_;
1020          croak "proxy port must be number" unless ($port =~ m/^\d+$/);          croak "proxy port must be number, not '$port'" unless ($port =~ m/^\d+$/);
1021          $self->{pxhost} = $host;          $self->{pxhost} = $host;
1022          $self->{pxport} = $port;          $self->{pxport} = $port;
1023  }  }
1024    
1025    
1026  =head2 set_timeout  =head2 set_timeout
1027    
1028  Specify timeout of connection in seconds  Specify timeout of connection in seconds
# Line 729  Specify timeout of connection in seconds Line 1034  Specify timeout of connection in seconds
1034  sub set_timeout {  sub set_timeout {
1035          my $self = shift;          my $self = shift;
1036          my $sec = shift;          my $sec = shift;
1037          croak "timeout must be number" unless ($sec =~ m/^\d+$/);          croak "timeout must be number, not '$sec'" unless ($sec =~ m/^\d+$/);
1038          $self->{timeout} = $sec;          $self->{timeout} = $sec;
1039  }  }
1040    
 package Search::Estraier::Master;  
1041    
1042  use Carp;  =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  =head1 Search::Estraier::Master    print $node->status;
1064    
1065  Controll node master. This requires user with administration priviledges.  C<-1> means connection failure.
1066    
1067  =cut  =cut
1068    
1069  {  sub status {
1070          package RequestAgent;          my $self = shift;
1071          our @ISA = qw(LWP::UserAgent);          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          sub new {  =cut
1084                  my $self = LWP::UserAgent::new(@_);  
1085                  $self->agent("Search-Estraier/$Search::Estraer::VERSION");  sub put_doc {
1086                  $self;          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          sub get_basic_credentials {  
1101                  my($self, $realm, $uri) = @_;  =head2 out_doc
1102  #               return ($user, $password);  
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  =head2 new  Remove a registrated document using it's uri
1131    
1132  Create new connection to node master.    $node->out_doc_by_uri( 'file:///document/uri/42' ) or "can't remove document";
1133    
1134    my $master = new Search::Estraier::Master(  Return true on success or false on failture.
1135          url => 'http://localhost:1978',  
1136          user => 'admin',  =cut
1137          passwd => 'admin',  
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  =cut
1808    
1809  sub new {  my $estmaster_rest = {
1810          my $class = shift;          shutdown => {
1811          my $self = {@_};                  status => 202,
1812          bless($self, $class);          },
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    
         foreach my $p (qw/url user passwd/) {  
                 croak "need $p" unless ($self->{$p});  
1883          }          }
1884    
1885          $self ? return $self : return undef;          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 799  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    
Legend:
Removed from v.30  
changed lines
  Added in v.164
  ViewVC Help
Powered by ViewVC 1.1.26