/[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 23 by dpavlin, Thu Jan 5 14:30:42 2006 UTC revision 98 by dpavlin, Sat Jan 28 19:18:13 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.04_1';
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            $node->set_url("http://localhost:1978/node/test");
22            $node->set_auth("admin","admin");
23    
24            # create document
25            my $doc = new Search::Estraier::Document;
26    
27            # add attributes
28            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
29            $doc->add_attr('@title', "Over the Rainbow");
30    
31            # add body text to document
32            $doc->add_text("Somewhere over the rainbow.  Way up high.");
33            $doc->add_text("There's a land that I heard of once in a lullaby.");
34    
35            die "error: ", $node->status,"\n" unless ($node->put_doc($doc));
36    
37    =head2 Simple searcher
38    
39            use Search::Estraier;
40    
41            # create and configure node
42            my $node = new Search::Estraier::Node;
43            $node->set_url("http://localhost:1978/node/test");
44            $node->set_auth("admin","admin");
45    
46            # create condition
47            my $cond = new Search::Estraier::Condition;
48    
49            # set search phrase
50            $cond->set_phrase("rainbow AND lullaby");
51    
52            my $nres = $node->search($cond, 0);
53            if (defined($nres)) {
54                    # for each document in results
55                    for my $i ( 0 ... $nres->doc_num - 1 ) {
56                            # get result document
57                            my $rdoc = $nres->get_doc($i);
58                            # display attribte
59                            print "URI: ", $rdoc->attr('@uri'),"\n";
60                            print "Title: ", $rdoc->attr('@title'),"\n";
61                            print $rdoc->snippet,"\n";
62                    }
63            } else {
64                    die "error: ", $node->status,"\n";
65            }
66    
67  =head1 DESCRIPTION  =head1 DESCRIPTION
68    
# Line 25  or Hyper Estraier development files on t Line 74  or Hyper Estraier development files on t
74  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
75  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
76    
77    There are few examples in C<scripts> directory of this distribution.
78    
79  =cut  =cut
80    
81    =head1 Inheritable common methods
82    
83    This methods should really move somewhere else.
84    
85  =head2 _s  =head2 _s
86    
87  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 92  Remove multiple whitespaces from string,
92  =cut  =cut
93    
94  sub _s {  sub _s {
95          my $text = $_[1] || return;          my $text = $_[1];
96            return unless defined($text);
97          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
98          $text =~ s/^\s+//;          $text =~ s/^\s+//;
99          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 56  our @ISA = qw/Search::Estraier/; Line 112  our @ISA = qw/Search::Estraier/;
112  This class implements Document which is collection of attributes  This class implements Document which is collection of attributes
113  (key=value), vectors (also key value) display text and hidden text.  (key=value), vectors (also key value) display text and hidden text.
114    
115    
116  =head2 new  =head2 new
117    
118  Create new document, empty or from draft.  Create new document, empty or from draft.
# Line 101  sub new { Line 158  sub new {
158                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
159                                  $in_text = 1;                                  $in_text = 1;
160                                  next;                                  next;
161                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
162                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
163                                  next;                                  next;
164                          }                          }
165    
166                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
167                  }                  }
168          }          }
169    
# Line 175  sub add_hidden_text { Line 232  sub add_hidden_text {
232          push @{ $self->{htexts} }, $self->_s($text);          push @{ $self->{htexts} }, $self->_s($text);
233  }  }
234    
235    
236  =head2 id  =head2 id
237    
238  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 246  sub id {
246          return $self->{id};          return $self->{id};
247  }  }
248    
249    
250  =head2 attr_names  =head2 attr_names
251    
252  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 257  Returns array with attribute names from
257    
258  sub attr_names {  sub attr_names {
259          my $self = shift;          my $self = shift;
260          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
261            #croak "attr_names return array, not scalar" if (! wantarray);
262          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
263  }  }
264    
# Line 214  Returns value of an attribute. Line 274  Returns value of an attribute.
274  sub attr {  sub attr {
275          my $self = shift;          my $self = shift;
276          my $name = shift;          my $name = shift;
277            return unless (defined($name) && $self->{attrs});
278          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
279  }  }
280    
281    
# Line 229  Returns array with text sentences. Line 289  Returns array with text sentences.
289    
290  sub texts {  sub texts {
291          my $self = shift;          my $self = shift;
292          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
293          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
294  }  }
295    
296    
297  =head2 cat_texts  =head2 cat_texts
298    
299  Return whole text as single scalar.  Return whole text as single scalar.
# Line 243  Return whole text as single scalar. Line 304  Return whole text as single scalar.
304    
305  sub cat_texts {  sub cat_texts {
306          my $self = shift;          my $self = shift;
307          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
308  }  }
309    
310    
311  =head2 dump_draft  =head2 dump_draft
312    
313  Dump draft data from document object.  Dump draft data from document object.
# Line 259  sub dump_draft { Line 321  sub dump_draft {
321          my $draft;          my $draft;
322    
323          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
324                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
325                    $draft .= $attr_name . '=' . $v . "\n";
326          }          }
327    
328          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 272  sub dump_draft { Line 335  sub dump_draft {
335    
336          $draft .= "\n";          $draft .= "\n";
337    
338          $draft .= join("\n", @{ $self->{dtexts} }) . "\n";          $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
339          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
340    
341          return $draft;          return $draft;
342  }  }
343    
344    
345  =head2 delete  =head2 delete
346    
347  Empty document object  Empty document object
# Line 306  sub delete { Line 370  sub delete {
370    
371  package Search::Estraier::Condition;  package Search::Estraier::Condition;
372    
373  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
374    
375  use Search::Estraier;  use Search::Estraier;
376  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 330  sub new { Line 394  sub new {
394          $self ? return $self : return undef;          $self ? return $self : return undef;
395  }  }
396    
397    
398  =head2 set_phrase  =head2 set_phrase
399    
400    $cond->set_phrase('search phrase');    $cond->set_phrase('search phrase');
# Line 341  sub set_phrase { Line 406  sub set_phrase {
406          $self->{phrase} = $self->_s( shift );          $self->{phrase} = $self->_s( shift );
407  }  }
408    
409    
410  =head2 add_attr  =head2 add_attr
411    
412    $cond->add_attr('@URI STRINC /~dpavlin/');    $cond->add_attr('@URI STRINC /~dpavlin/');
# Line 353  sub add_attr { Line 419  sub add_attr {
419          push @{ $self->{attrs} }, $self->_s( $attr );          push @{ $self->{attrs} }, $self->_s( $attr );
420  }  }
421    
422    
423  =head2 set_order  =head2 set_order
424    
425    $cond->set_order('@mdate NUMD');    $cond->set_order('@mdate NUMD');
# Line 364  sub set_order { Line 431  sub set_order {
431          $self->{order} = shift;          $self->{order} = shift;
432  }  }
433    
434    
435  =head2 set_max  =head2 set_max
436    
437    $cond->set_max(42);    $cond->set_max(42);
# Line 373  sub set_order { Line 441  sub set_order {
441  sub set_max {  sub set_max {
442          my $self = shift;          my $self = shift;
443          my $max = shift;          my $max = shift;
444          croak "set_max needs number" unless ($max =~ m/^\d+$/);          croak "set_max needs number, not '$max'" unless ($max =~ m/^\d+$/);
445          $self->{max} = $max;          $self->{max} = $max;
446  }  }
447    
448    
449  =head2 set_options  =head2 set_options
450    
451    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
452    
453      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
454    
455    Possible options are:
456    
457    =over 8
458    
459    =item SURE
460    
461    check every N-gram
462    
463    =item USUAL
464    
465    check every second N-gram
466    
467    =item FAST
468    
469    check every third N-gram
470    
471    =item AGITO
472    
473    check every fourth N-gram
474    
475    =item NOIDF
476    
477    don't perform TF-IDF tuning
478    
479    =item SIMPLE
480    
481    use simplified query phrase
482    
483    =back
484    
485    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
486    options;
487    
488    This option changed in version C<0.04> of this module. It's backwards compatibile.
489    
490  =cut  =cut
491    
492  my $options = {  my $options = {
         # check N-gram keys skipping by three  
493          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
494          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
495          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
496          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
497          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
498          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
499  };  };
500    
501  sub set_options {  sub set_options {
502          my $self = shift;          my $self = shift;
503          my $option = shift;          my $opt = 0;
504          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
505          $self->{options} ||= $options->{$option};                  my $mask;
506                    unless ($mask = $options->{$option}) {
507                            if ($option eq '1') {
508                                    next;
509                            } else {
510                                    croak "unknown option $option";
511                            }
512                    }
513                    $opt += $mask;
514            }
515            $self->{options} = $opt;
516  }  }
517    
518    
519  =head2 phrase  =head2 phrase
520    
521  Return search phrase.  Return search phrase.
# Line 418  sub phrase { Line 529  sub phrase {
529          return $self->{phrase};          return $self->{phrase};
530  }  }
531    
532    
533  =head2 order  =head2 order
534    
535  Return search result order.  Return search result order.
# Line 431  sub order { Line 543  sub order {
543          return $self->{order};          return $self->{order};
544  }  }
545    
546    
547  =head2 attrs  =head2 attrs
548    
549  Return search result attrs.  Return search result attrs.
# Line 442  Return search result attrs. Line 555  Return search result attrs.
555  sub attrs {  sub attrs {
556          my $self = shift;          my $self = shift;
557          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
558          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
559  }  }
560    
561    
562  =head2 max  =head2 max
563    
564  Return maximum number of results.  Return maximum number of results.
# Line 460  sub max { Line 574  sub max {
574          return $self->{max};          return $self->{max};
575  }  }
576    
577    
578  =head2 options  =head2 options
579    
580  Return options for this condition.  Return options for this condition.
# Line 478  sub options { Line 593  sub options {
593    
594  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
595    
596  use Carp qw/confess croak/;  use Carp qw/croak/;
597    
598  use Search::Estraier;  #use Search::Estraier;
599  our @ISA = qw/Search::Estraier/;  #our @ISA = qw/Search::Estraier/;
600    
601  =head1 Search::Estraier::ResultDocument  =head1 Search::Estraier::ResultDocument
602    
# Line 504  sub new { Line 619  sub new {
619          my $self = {@_};          my $self = {@_};
620          bless($self, $class);          bless($self, $class);
621    
622          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});  
         }  
623    
624          $self ? return $self : return undef;          $self ? return $self : return undef;
625  }  }
626    
627    
628  =head2 uri  =head2 uri
629    
630  Return URI of result document  Return URI of result document
# Line 539  sub attr_names { Line 653  sub attr_names {
653          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
654  }  }
655    
656    
657  =head2 attr  =head2 attr
658    
659  Returns value of an attribute.  Returns value of an attribute.
# Line 553  sub attr { Line 668  sub attr {
668          return $self->{attrs}->{ $name };          return $self->{attrs}->{ $name };
669  }  }
670    
671    
672  =head2 snippet  =head2 snippet
673    
674  Return snippet from result document  Return snippet from result document
# Line 566  sub snippet { Line 682  sub snippet {
682          return $self->{snippet};          return $self->{snippet};
683  }  }
684    
685    
686  =head2 keywords  =head2 keywords
687    
688  Return keywords from result document  Return keywords from result document
# Line 580  sub keywords { Line 697  sub keywords {
697  }  }
698    
699    
700  package Search::Estraier::Master;  package Search::Estraier::NodeResult;
701    
702    use Carp qw/croak/;
703    
704  use Carp;  #use Search::Estraier;
705    #our @ISA = qw/Search::Estraier/;
706    
707  =head1 Search::Estraier::Master  =head1 Search::Estraier::NodeResult
708    
709    =head2 new
710    
711  Controll node master. This requires user with administration priviledges.    my $res = new Search::HyperEstraier::NodeResult(
712            docs => @array_of_rdocs,
713            hits => %hash_with_hints,
714      );
715    
716  =cut  =cut
717    
718  {  sub new {
719          package RequestAgent;          my $class = shift;
720          our @ISA = qw(LWP::UserAgent);          my $self = {@_};
721            bless($self, $class);
722    
723          sub new {          foreach my $f (qw/docs hints/) {
724                  my $self = LWP::UserAgent::new(@_);                  croak "missing $f for ResultDocument" unless defined($self->{$f});
                 $self->agent("Search-Estraier/$Search::Estraer::VERSION");  
                 $self;  
725          }          }
726    
727          sub get_basic_credentials {          $self ? return $self : return undef;
728                  my($self, $realm, $uri) = @_;  }
729  #               return ($user, $password);  
730          }  
731    =head2 doc_num
732    
733    Return number of documents
734    
735      print $res->doc_num;
736    
737    =cut
738    
739    sub doc_num {
740            my $self = shift;
741            return $#{$self->{docs}} + 1;
742    }
743    
744    
745    =head2 get_doc
746    
747    Return single document
748    
749      my $doc = $res->get_doc( 42 );
750    
751    Returns undef if document doesn't exist.
752    
753    =cut
754    
755    sub get_doc {
756            my $self = shift;
757            my $num = shift;
758            croak "expect number as argument, not '$num'" unless ($num =~ m/^\d+$/);
759            return undef if ($num < 0 || $num > $self->{docs});
760            return $self->{docs}->[$num];
761    }
762    
763    
764    =head2 hint
765    
766    Return specific hint from results.
767    
768      print $rec->hint( 'VERSION' );
769    
770    Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
771    C<TIME>, C<LINK#n>, C<VIEW>.
772    
773    =cut
774    
775    sub hint {
776            my $self = shift;
777            my $key = shift || return;
778            return $self->{hints}->{$key};
779  }  }
780    
781    =head2 hints
782    
783    More perlish version of C<hint>. This one returns hash.
784    
785      my %hints = $rec->hints;
786    
787    =cut
788    
789    sub hints {
790            my $self = shift;
791            return $self->{hints};
792    }
793    
794    package Search::Estraier::Node;
795    
796    use Carp qw/carp croak confess/;
797    use URI;
798    use MIME::Base64;
799    use IO::Socket::INET;
800    use URI::Escape qw/uri_escape/;
801    
802    =head1 Search::Estraier::Node
803    
804  =head2 new  =head2 new
805    
806  Create new connection to node master.    my $node = new Search::HyperEstraier::Node;
807    
808    or optionally with C<url> as parametar
809    
810    my $master = new Search::Estraier::Master(    my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
811          url => 'http://localhost:1978',  
812          user => 'admin',  or in more verbose form
813          passwd => 'admin',  
814      my $node = new Search::HyperEstraier::Node(
815            url => 'http://localhost:1978/node/test',
816            debug => 1,
817            croak_on_error => 1
818    );    );
819    
820    with following arguments:
821    
822    =over 4
823    
824    =item url
825    
826    URL to node
827    
828    =item debug
829    
830    dumps a B<lot> of debugging output
831    
832    =item croak_on_error
833    
834    very helpful during development. It will croak on all errors instead of
835    silently returning C<-1> (which is convention of Hyper Estraier API in other
836    languages).
837    
838    =back
839    
840  =cut  =cut
841    
842  sub new {  sub new {
843          my $class = shift;          my $class = shift;
844          my $self = {@_};          my $self = {
845                    pxport => -1,
846                    timeout => 0,   # this used to be -1
847                    dnum => -1,
848                    wnum => -1,
849                    size => -1.0,
850                    wwidth => 480,
851                    hwidth => 96,
852                    awidth => 96,
853                    status => -1,
854            };
855          bless($self, $class);          bless($self, $class);
856    
857          foreach my $p (qw/url user passwd/) {          if ($#_ == 0) {
858                  croak "need $p" unless ($self->{$p});                  $self->{url} = shift;
859            } else {
860                    my $args = {@_};
861    
862                    %$self = ( %$self, @_ );
863    
864                    warn "## Node debug on\n" if ($self->{debug});
865          }          }
866    
867          $self ? return $self : return undef;          $self ? return $self : return undef;
868  }  }
869    
870    
871    =head2 set_url
872    
873    Specify URL to node server
874    
875      $node->set_url('http://localhost:1978');
876    
877    =cut
878    
879    sub set_url {
880            my $self = shift;
881            $self->{url} = shift;
882    }
883    
884    
885    =head2 set_proxy
886    
887    Specify proxy server to connect to node server
888    
889      $node->set_proxy('proxy.example.com', 8080);
890    
891    =cut
892    
893    sub set_proxy {
894            my $self = shift;
895            my ($host,$port) = @_;
896            croak "proxy port must be number, not '$port'" unless ($port =~ m/^\d+$/);
897            $self->{pxhost} = $host;
898            $self->{pxport} = $port;
899    }
900    
901    
902    =head2 set_timeout
903    
904    Specify timeout of connection in seconds
905    
906      $node->set_timeout( 15 );
907    
908    =cut
909    
910    sub set_timeout {
911            my $self = shift;
912            my $sec = shift;
913            croak "timeout must be number, not '$sec'" unless ($sec =~ m/^\d+$/);
914            $self->{timeout} = $sec;
915    }
916    
917    
918    =head2 set_auth
919    
920    Specify name and password for authentication to node server.
921    
922      $node->set_auth('clint','eastwood');
923    
924    =cut
925    
926    sub set_auth {
927            my $self = shift;
928            my ($login,$passwd) = @_;
929            my $basic_auth = encode_base64( "$login:$passwd" );
930            chomp($basic_auth);
931            $self->{auth} = $basic_auth;
932    }
933    
934    
935    =head2 status
936    
937    Return status code of last request.
938    
939      print $node->status;
940    
941    C<-1> means connection failure.
942    
943    =cut
944    
945    sub status {
946            my $self = shift;
947            return $self->{status};
948    }
949    
950    
951    =head2 put_doc
952    
953    Add a document
954    
955      $node->put_doc( $document_draft ) or die "can't add document";
956    
957    Return true on success or false on failture.
958    
959    =cut
960    
961    sub put_doc {
962            my $self = shift;
963            my $doc = shift || return;
964            return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
965            $self->shuttle_url( $self->{url} . '/put_doc',
966                    'text/x-estraier-draft',
967                    $doc->dump_draft,
968                    undef
969            ) == 200;
970    }
971    
972    
973    =head2 out_doc
974    
975    Remove a document
976    
977      $node->out_doc( document_id ) or "can't remove document";
978    
979    Return true on success or false on failture.
980    
981    =cut
982    
983    sub out_doc {
984            my $self = shift;
985            my $id = shift || return;
986            return unless ($self->{url});
987            croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
988            $self->shuttle_url( $self->{url} . '/out_doc',
989                    'application/x-www-form-urlencoded',
990                    "id=$id",
991                    undef
992            ) == 200;
993    }
994    
995    
996    =head2 out_doc_by_uri
997    
998    Remove a registrated document using it's uri
999    
1000      $node->out_doc_by_uri( 'file:///document/uri/42' ) or "can't remove document";
1001    
1002    Return true on success or false on failture.
1003    
1004    =cut
1005    
1006    sub out_doc_by_uri {
1007            my $self = shift;
1008            my $uri = shift || return;
1009            return unless ($self->{url});
1010            $self->shuttle_url( $self->{url} . '/out_doc',
1011                    'application/x-www-form-urlencoded',
1012                    "uri=" . uri_escape($uri),
1013                    undef
1014            ) == 200;
1015    }
1016    
1017    
1018    =head2 edit_doc
1019    
1020    Edit attributes of a document
1021    
1022      $node->edit_doc( $document_draft ) or die "can't edit document";
1023    
1024    Return true on success or false on failture.
1025    
1026    =cut
1027    
1028    sub edit_doc {
1029            my $self = shift;
1030            my $doc = shift || return;
1031            return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1032            $self->shuttle_url( $self->{url} . '/edit_doc',
1033                    'text/x-estraier-draft',
1034                    $doc->dump_draft,
1035                    undef
1036            ) == 200;
1037    }
1038    
1039    
1040    =head2 get_doc
1041    
1042    Retreive document
1043    
1044      my $doc = $node->get_doc( document_id ) or die "can't get document";
1045    
1046    Return true on success or false on failture.
1047    
1048    =cut
1049    
1050    sub get_doc {
1051            my $self = shift;
1052            my $id = shift || return;
1053            return $self->_fetch_doc( id => $id );
1054    }
1055    
1056    
1057    =head2 get_doc_by_uri
1058    
1059    Retreive document
1060    
1061      my $doc = $node->get_doc_by_uri( 'file:///document/uri/42' ) or die "can't get document";
1062    
1063    Return true on success or false on failture.
1064    
1065    =cut
1066    
1067    sub get_doc_by_uri {
1068            my $self = shift;
1069            my $uri = shift || return;
1070            return $self->_fetch_doc( uri => $uri );
1071    }
1072    
1073    
1074    =head2 get_doc_attr
1075    
1076    Retrieve the value of an atribute from object
1077    
1078      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1079            die "can't get document attribute";
1080    
1081    =cut
1082    
1083    sub get_doc_attr {
1084            my $self = shift;
1085            my ($id,$name) = @_;
1086            return unless ($id && $name);
1087            return $self->_fetch_doc( id => $id, attr => $name );
1088    }
1089    
1090    
1091    =head2 get_doc_attr_by_uri
1092    
1093    Retrieve the value of an atribute from object
1094    
1095      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1096            die "can't get document attribute";
1097    
1098    =cut
1099    
1100    sub get_doc_attr_by_uri {
1101            my $self = shift;
1102            my ($uri,$name) = @_;
1103            return unless ($uri && $name);
1104            return $self->_fetch_doc( uri => $uri, attr => $name );
1105    }
1106    
1107    
1108    =head2 etch_doc
1109    
1110    Exctract document keywords
1111    
1112      my $keywords = $node->etch_doc( document_id ) or die "can't etch document";
1113    
1114    =cut
1115    
1116    sub etch_doc {
1117            my $self = shift;
1118            my $id = shift || return;
1119            return $self->_fetch_doc( id => $id, etch => 1 );
1120    }
1121    
1122    =head2 etch_doc_by_uri
1123    
1124    Retreive document
1125    
1126      my $keywords = $node->etch_doc_by_uri( 'file:///document/uri/42' ) or die "can't etch document";
1127    
1128    Return true on success or false on failture.
1129    
1130    =cut
1131    
1132    sub etch_doc_by_uri {
1133            my $self = shift;
1134            my $uri = shift || return;
1135            return $self->_fetch_doc( uri => $uri, etch => 1 );
1136    }
1137    
1138    
1139    =head2 uri_to_id
1140    
1141    Get ID of document specified by URI
1142    
1143      my $id = $node->uri_to_id( 'file:///document/uri/42' );
1144    
1145    =cut
1146    
1147    sub uri_to_id {
1148            my $self = shift;
1149            my $uri = shift || return;
1150            return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1 );
1151    }
1152    
1153    
1154    =head2 _fetch_doc
1155    
1156    Private function used for implementing of C<get_doc>, C<get_doc_by_uri>,
1157    C<etch_doc>, C<etch_doc_by_uri>.
1158    
1159     # this will decode received draft into Search::Estraier::Document object
1160     my $doc = $node->_fetch_doc( id => 42 );
1161     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42' );
1162    
1163     # to extract keywords, add etch
1164     my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1165     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1166    
1167     # to get document attrubute add attr
1168     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1169     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1170    
1171     # more general form which allows implementation of
1172     # uri_to_id
1173     my $id = $node->_fetch_doc(
1174            uri => 'file:///document/uri/42',
1175            path => '/uri_to_id',
1176            chomp_resbody => 1
1177     );
1178    
1179    =cut
1180    
1181    sub _fetch_doc {
1182            my $self = shift;
1183            my $a = {@_};
1184            return unless ( ($a->{id} || $a->{uri}) && $self->{url} );
1185    
1186            my ($arg, $resbody);
1187    
1188            my $path = $a->{path} || '/get_doc';
1189            $path = '/etch_doc' if ($a->{etch});
1190    
1191            if ($a->{id}) {
1192                    croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
1193                    $arg = 'id=' . $a->{id};
1194            } elsif ($a->{uri}) {
1195                    $arg = 'uri=' . uri_escape($a->{uri});
1196            } else {
1197                    confess "unhandled argument. Need id or uri.";
1198            }
1199    
1200            if ($a->{attr}) {
1201                    $path = '/get_doc_attr';
1202                    $arg .= '&attr=' . uri_escape($a->{attr});
1203                    $a->{chomp_resbody} = 1;
1204            }
1205    
1206            my $rv = $self->shuttle_url( $self->{url} . $path,
1207                    'application/x-www-form-urlencoded',
1208                    $arg,
1209                    \$resbody,
1210            );
1211    
1212            return if ($rv != 200);
1213    
1214            if ($a->{etch}) {
1215                    $self->{kwords} = {};
1216                    return +{} unless ($resbody);
1217                    foreach my $l (split(/\n/, $resbody)) {
1218                            my ($k,$v) = split(/\t/, $l, 2);
1219                            $self->{kwords}->{$k} = $v if ($v);
1220                    }
1221                    return $self->{kwords};
1222            } elsif ($a->{chomp_resbody}) {
1223                    return unless (defined($resbody));
1224                    chomp($resbody);
1225                    return $resbody;
1226            } else {
1227                    return new Search::Estraier::Document($resbody);
1228            }
1229    }
1230    
1231    
1232    =head2 name
1233    
1234      my $node_name = $node->name;
1235    
1236    =cut
1237    
1238    sub name {
1239            my $self = shift;
1240            $self->_set_info unless ($self->{name});
1241            return $self->{name};
1242    }
1243    
1244    
1245    =head2 label
1246    
1247      my $node_label = $node->label;
1248    
1249    =cut
1250    
1251    sub label {
1252            my $self = shift;
1253            $self->_set_info unless ($self->{label});
1254            return $self->{label};
1255    }
1256    
1257    
1258    =head2 doc_num
1259    
1260      my $documents_in_node = $node->doc_num;
1261    
1262    =cut
1263    
1264    sub doc_num {
1265            my $self = shift;
1266            $self->_set_info if ($self->{dnum} < 0);
1267            return $self->{dnum};
1268    }
1269    
1270    
1271    =head2 word_num
1272    
1273      my $words_in_node = $node->word_num;
1274    
1275    =cut
1276    
1277    sub word_num {
1278            my $self = shift;
1279            $self->_set_info if ($self->{wnum} < 0);
1280            return $self->{wnum};
1281    }
1282    
1283    
1284    =head2 size
1285    
1286      my $node_size = $node->size;
1287    
1288    =cut
1289    
1290    sub size {
1291            my $self = shift;
1292            $self->_set_info if ($self->{size} < 0);
1293            return $self->{size};
1294    }
1295    
1296    
1297    =head2 search
1298    
1299    Search documents which match condition
1300    
1301      my $nres = $node->search( $cond, $depth );
1302    
1303    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1304    depth for meta search.
1305    
1306    Function results C<Search::Estraier::NodeResult> object.
1307    
1308    =cut
1309    
1310    sub search {
1311            my $self = shift;
1312            my ($cond, $depth) = @_;
1313            return unless ($cond && defined($depth) && $self->{url});
1314            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1315            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1316    
1317            my $resbody;
1318    
1319            my $rv = $self->shuttle_url( $self->{url} . '/search',
1320                    'application/x-www-form-urlencoded',
1321                    $self->cond_to_query( $cond, $depth ),
1322                    \$resbody,
1323            );
1324            return if ($rv != 200);
1325    
1326            my (@docs, $hints);
1327    
1328            my @lines = split(/\n/, $resbody);
1329            return unless (@lines);
1330    
1331            my $border = $lines[0];
1332            my $isend = 0;
1333            my $lnum = 1;
1334    
1335            while ( $lnum <= $#lines ) {
1336                    my $line = $lines[$lnum];
1337                    $lnum++;
1338    
1339                    #warn "## $line\n";
1340                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1341                            $isend = $1;
1342                            last;
1343                    }
1344    
1345                    if ($line =~ /\t/) {
1346                            my ($k,$v) = split(/\t/, $line, 2);
1347                            $hints->{$k} = $v;
1348                    }
1349            }
1350    
1351            my $snum = $lnum;
1352    
1353            while( ! $isend && $lnum <= $#lines ) {
1354                    my $line = $lines[$lnum];
1355                    #warn "# $lnum: $line\n";
1356                    $lnum++;
1357    
1358                    if ($line && $line =~ m/^\Q$border\E/) {
1359                            if ($lnum > $snum) {
1360                                    my $rdattrs;
1361                                    my $rdvector;
1362                                    my $rdsnippet;
1363                                    
1364                                    my $rlnum = $snum;
1365                                    while ($rlnum < $lnum - 1 ) {
1366                                            #my $rdline = $self->_s($lines[$rlnum]);
1367                                            my $rdline = $lines[$rlnum];
1368                                            $rlnum++;
1369                                            last unless ($rdline);
1370                                            if ($rdline =~ /^%/) {
1371                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1372                                            } elsif($rdline =~ /=/) {
1373                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1374                                            } else {
1375                                                    confess "invalid format of response";
1376                                            }
1377                                    }
1378                                    while($rlnum < $lnum - 1) {
1379                                            my $rdline = $lines[$rlnum];
1380                                            $rlnum++;
1381                                            $rdsnippet .= "$rdline\n";
1382                                    }
1383                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1384                                    if (my $rduri = $rdattrs->{'@uri'}) {
1385                                            push @docs, new Search::Estraier::ResultDocument(
1386                                                    uri => $rduri,
1387                                                    attrs => $rdattrs,
1388                                                    snippet => $rdsnippet,
1389                                                    keywords => $rdvector,
1390                                            );
1391                                    }
1392                            }
1393                            $snum = $lnum;
1394                            #warn "### $line\n";
1395                            $isend = 1 if ($line =~ /:END$/);
1396                    }
1397    
1398            }
1399    
1400            if (! $isend) {
1401                    warn "received result doesn't have :END\n$resbody";
1402                    return;
1403            }
1404    
1405            #warn Dumper(\@docs, $hints);
1406    
1407            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1408    }
1409    
1410    
1411    =head2 cond_to_query
1412    
1413    Return URI encoded string generated from Search::Estraier::Condition
1414    
1415      my $args = $node->cond_to_query( $cond, $depth );
1416    
1417    =cut
1418    
1419    sub cond_to_query {
1420            my $self = shift;
1421    
1422            my $cond = shift || return;
1423            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1424            my $depth = shift;
1425    
1426            my @args;
1427    
1428            if (my $phrase = $cond->phrase) {
1429                    push @args, 'phrase=' . uri_escape($phrase);
1430            }
1431    
1432            if (my @attrs = $cond->attrs) {
1433                    for my $i ( 0 .. $#attrs ) {
1434                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1435                    }
1436            }
1437    
1438            if (my $order = $cond->order) {
1439                    push @args, 'order=' . uri_escape($order);
1440            }
1441                    
1442            if (my $max = $cond->max) {
1443                    push @args, 'max=' . $max;
1444            } else {
1445                    push @args, 'max=' . (1 << 30);
1446            }
1447    
1448            if (my $options = $cond->options) {
1449                    push @args, 'options=' . $options;
1450            }
1451    
1452            push @args, 'depth=' . $depth if ($depth);
1453            push @args, 'wwidth=' . $self->{wwidth};
1454            push @args, 'hwidth=' . $self->{hwidth};
1455            push @args, 'awidth=' . $self->{awidth};
1456    
1457            return join('&', @args);
1458    }
1459    
1460    
1461    =head2 shuttle_url
1462    
1463    This is method which uses C<LWP::UserAgent> to communicate with Hyper Estraier node
1464    master.
1465    
1466      my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1467    
1468    C<$resheads> and C<$resbody> booleans controll if response headers and/or response
1469    body will be saved within object.
1470    
1471    =cut
1472    
1473    use LWP::UserAgent;
1474    
1475    sub shuttle_url {
1476            my $self = shift;
1477    
1478            my ($url, $content_type, $reqbody, $resbody) = @_;
1479    
1480            $self->{status} = -1;
1481    
1482            warn "## $url\n" if ($self->{debug});
1483    
1484            $url = new URI($url);
1485            if (
1486                            !$url || !$url->scheme || !$url->scheme eq 'http' ||
1487                            !$url->host || !$url->port || $url->port < 1
1488                    ) {
1489                    carp "can't parse $url\n";
1490                    return -1;
1491            }
1492    
1493            my $ua = LWP::UserAgent->new;
1494            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1495    
1496            my $req;
1497            if ($reqbody) {
1498                    $req = HTTP::Request->new(POST => $url);
1499            } else {
1500                    $req = HTTP::Request->new(GET => $url);
1501            }
1502    
1503            $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1504            $req->headers->header( 'Connection', 'close' );
1505            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1506            $req->content_type( $content_type );
1507    
1508            warn $req->headers->as_string,"\n" if ($self->{debug});
1509    
1510            if ($reqbody) {
1511                    warn "$reqbody\n" if ($self->{debug});
1512                    $req->content( $reqbody );
1513            }
1514    
1515            my $res = $ua->request($req) || croak "can't make request to $url: $!";
1516    
1517            warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1518    
1519            ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1520    
1521            if (! $res->is_success) {
1522                    if ($self->{croak_on_error}) {
1523                            croak("can't get $url: ",$res->status_line);
1524                    } else {
1525                            return -1;
1526                    }
1527            }
1528    
1529            $$resbody .= $res->content;
1530    
1531            warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1532    
1533            return $self->{status};
1534    }
1535    
1536    
1537    =head2 set_snippet_width
1538    
1539    Set width of snippets in results
1540    
1541      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1542    
1543    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1544    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1545    
1546    C<$hwidth> specified width of strings from beginning of string. Default
1547    value is C<96>. Negative or zero value keep previous value.
1548    
1549    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1550    If negative of zero value is provided previous value is kept unchanged.
1551    
1552    =cut
1553    
1554    sub set_snippet_width {
1555            my $self = shift;
1556    
1557            my ($wwidth, $hwidth, $awidth) = @_;
1558            $self->{wwidth} = $wwidth;
1559            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1560            $self->{awidth} = $awidth if ($awidth >= 0);
1561    }
1562    
1563    
1564    =head2 set_user
1565    
1566    Manage users of node
1567    
1568      $node->set_user( 'name', $mode );
1569    
1570    C<$mode> can be one of:
1571    
1572    =over 4
1573    
1574    =item 0
1575    
1576    delete account
1577    
1578    =item 1
1579    
1580    set administrative right for user
1581    
1582    =item 2
1583    
1584    set user account as guest
1585    
1586    =back
1587    
1588    Return true on success, otherwise false.
1589    
1590    =cut
1591    
1592    sub set_user {
1593            my $self = shift;
1594            my ($name, $mode) = @_;
1595    
1596            return unless ($self->{url});
1597            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1598    
1599            $self->shuttle_url( $self->{url} . '/_set_user',
1600                    'text/plain',
1601                    'name=' . uri_escape($name) . '&mode=' . $mode,
1602                    undef
1603            ) == 200;
1604    }
1605    
1606    
1607    =head2 set_link
1608    
1609    Manage node links
1610    
1611      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1612    
1613    If C<$credit> is negative, link is removed.
1614    
1615    =cut
1616    
1617    sub set_link {
1618            my $self = shift;
1619            my ($url, $label, $credit) = @_;
1620    
1621            return unless ($self->{url});
1622            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1623    
1624            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1625            $reqbody .= '&credit=' . $credit if ($credit > 0);
1626    
1627            $self->shuttle_url( $self->{url} . '/_set_link',
1628                    'application/x-www-form-urlencoded',
1629                    $reqbody,
1630                    undef
1631            ) == 200;
1632    }
1633    
1634    
1635    =head1 PRIVATE METHODS
1636    
1637    You could call those directly, but you don't have to. I hope.
1638    
1639    =head2 _set_info
1640    
1641    Set information for node
1642    
1643      $node->_set_info;
1644    
1645    =cut
1646    
1647    sub _set_info {
1648            my $self = shift;
1649    
1650            $self->{status} = -1;
1651            return unless ($self->{url});
1652    
1653            my $resbody;
1654            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1655                    'text/plain',
1656                    undef,
1657                    \$resbody,
1658            );
1659    
1660            return if ($rv != 200 || !$resbody);
1661    
1662            # it seems that response can have multiple line endings
1663            $resbody =~ s/[\r\n]+$//;
1664    
1665            ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1666                    split(/\t/, $resbody, 5);
1667    
1668    }
1669    
1670  ###  ###
1671    
Legend:
Removed from v.23  
changed lines
  Added in v.98
  ViewVC Help
Powered by ViewVC 1.1.26