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