/[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 58 by dpavlin, Fri Jan 6 21:05:05 2006 UTC revision 150 by dpavlin, Mon May 15 22:26:08 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.07_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                    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  =head1 Inheritable common methods
# Line 41  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 106  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 205  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 221  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 236  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    
# Line 251  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    
# Line 268  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 316  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 394  sub set_max { Line 459  sub set_max {
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    
# Line 460  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    
# Line 496  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 524  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  }  }
# Line 641  Return number of documents Line 774  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 {
# Line 672  sub get_doc { Line 808  sub get_doc {
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 685  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    
# Line 700  use URI::Escape qw/uri_escape/; Line 867  use URI::Escape qw/uri_escape/;
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 {
# Line 707  sub new { Line 926  sub new {
926          my $self = {          my $self = {
927                  pxport => -1,                  pxport => -1,
928                  timeout => 0,   # this used to be -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          my $args = {@_};          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          $self->{debug} = $args->{debug};          if ($self->{create}) {
954          warn "## Node debug on\n" if ($self->{debug});                  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  }  }
# Line 843  sub out_doc { Line 1084  sub out_doc {
1084          my $id = shift || return;          my $id = shift || return;
1085          return unless ($self->{url});          return unless ($self->{url});
1086          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1087          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1088                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1089                  "id=$id",                  "id=$id",
1090                  undef                  undef
1091          ) == 200;          ) == 200) {
1092                    $self->_set_info;
1093                    return $id;
1094            }
1095            return undef;
1096  }  }
1097    
1098    
# Line 865  sub out_doc_by_uri { Line 1110  sub out_doc_by_uri {
1110          my $self = shift;          my $self = shift;
1111          my $uri = shift || return;          my $uri = shift || return;
1112          return unless ($self->{url});          return unless ($self->{url});
1113          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1114                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1115                  "uri=" . uri_escape($uri),                  "uri=" . uri_escape($uri),
1116                  undef                  undef
1117          ) == 200;          ) == 200) {
1118                    $self->_set_info;
1119                    return $uri;
1120            }
1121            return undef;
1122  }  }
1123    
1124    
# Line 1000  Get ID of document specified by URI Line 1249  Get ID of document specified by URI
1249    
1250    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1251    
1252    This method won't croak, even if using C<croak_on_error>.
1253    
1254  =cut  =cut
1255    
1256  sub uri_to_id {  sub uri_to_id {
1257          my $self = shift;          my $self = shift;
1258          my $uri = shift || return;          my $uri = shift || return;
1259          return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1 );          return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1, croak_on_error => 0 );
1260  }  }
1261    
1262    
# Line 1065  sub _fetch_doc { Line 1316  sub _fetch_doc {
1316                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1317                  $arg,                  $arg,
1318                  \$resbody,                  \$resbody,
1319                    $a->{croak_on_error},
1320          );          );
1321    
1322          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1347  sub _fetch_doc {
1347    
1348  sub name {  sub name {
1349          my $self = shift;          my $self = shift;
1350          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1351          return $self->{name};          return $self->{inform}->{name};
1352  }  }
1353    
1354    
# Line 1108  sub name { Line 1360  sub name {
1360    
1361  sub label {  sub label {
1362          my $self = shift;          my $self = shift;
1363          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1364          return $self->{label};          return $self->{inform}->{label};
1365  }  }
1366    
1367    
# Line 1121  sub label { Line 1373  sub label {
1373    
1374  sub doc_num {  sub doc_num {
1375          my $self = shift;          my $self = shift;
1376          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1377          return $self->{dnum};          return $self->{inform}->{dnum};
1378  }  }
1379    
1380    
# Line 1134  sub doc_num { Line 1386  sub doc_num {
1386    
1387  sub word_num {  sub word_num {
1388          my $self = shift;          my $self = shift;
1389          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1390          return $self->{wnum};          return $self->{inform}->{wnum};
1391  }  }
1392    
1393    
# Line 1147  sub word_num { Line 1399  sub word_num {
1399    
1400  sub size {  sub size {
1401          my $self = shift;          my $self = shift;
1402          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1403          return $self->{size};          return $self->{inform}->{size};
1404  }  }
1405    
1406    
# Line 1176  sub search { Line 1428  sub search {
1428    
1429          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1430                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1431                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1432                  \$resbody,                  \$resbody,
1433          );          );
1434          return if ($rv != 200);          return if ($rv != 200);
1435    
1436          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1437            my $hintsText   = splice @records, 0, 2; # starts with empty record
1438          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1439          return unless (@lines);  
1440            # process records
1441          my $border = $lines[0];          my $docs = [];
1442          my $isend = 0;          foreach my $record (@records)
1443          my $lnum = 1;          {
1444                    # split into keys and snippets
1445          while ( $lnum <= $#lines ) {                  my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
                 my $line = $lines[$lnum];  
                 $lnum++;  
   
                 #warn "## $line\n";  
                 if ($line && $line =~ m/^\Q$border\E(:END)*$/) {  
                         $isend = $1;  
                         last;  
                 }  
   
                 if ($line =~ /\t/) {  
                         my ($k,$v) = split(/\t/, $line, 2);  
                         $hints->{$k} = $v;  
                 }  
         }  
   
         my $snum = $lnum;  
   
         while( ! $isend && $lnum <= $#lines ) {  
                 my $line = $lines[$lnum];  
                 #warn "# $lnum: $line\n";  
                 $lnum++;  
   
                 if ($line && $line =~ m/^\Q$border\E/) {  
                         if ($lnum > $snum) {  
                                 my $rdattrs;  
                                 my $rdvector;  
                                 my $rdsnippet;  
                                   
                                 my $rlnum = $snum;  
                                 while ($rlnum < $lnum - 1 ) {  
                                         #my $rdline = $self->_s($lines[$rlnum]);  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         last unless ($rdline);  
                                         if ($rdline =~ /^%/) {  
                                                 $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);  
                                         } elsif($rdline =~ /=/) {  
                                                 $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);  
                                         } else {  
                                                 confess "invalid format of response";  
                                         }  
                                 }  
                                 while($rlnum < $lnum - 1) {  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         $rdsnippet .= "$rdline\n";  
                                 }  
                                 #warn Dumper($rdvector, $rdattrs, $rdsnippet);  
                                 if (my $rduri = $rdattrs->{'@uri'}) {  
                                         push @docs, new Search::Estraier::ResultDocument(  
                                                 uri => $rduri,  
                                                 attrs => $rdattrs,  
                                                 snippet => $rdsnippet,  
                                                 keywords => $rdvector,  
                                         );  
                                 }  
                         }  
                         $snum = $lnum;  
                         #warn "### $line\n";  
                         $isend = 1 if ($line =~ /:END$/);  
                 }  
   
         }  
1446    
1447          if (! $isend) {                  # create document hash
1448                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1449                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1450                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1451                    $doc->{snippet}         = $snippet;
1452    
1453                    push @$docs, new Search::Estraier::ResultDocument(
1454                            attrs           => $doc,
1455                            uri             => $doc->{'@uri'},
1456                            snippet         => $snippet,
1457                            keywords        => $doc->{'keywords'},
1458                    );
1459          }          }
1460    
1461          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1462  }  }
1463    
1464    
# Line 1270  sub search { Line 1466  sub search {
1466    
1467  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1468    
1469    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1470    
1471  =cut  =cut
1472    
# Line 1279  sub cond_to_query { Line 1475  sub cond_to_query {
1475    
1476          my $cond = shift || return;          my $cond = shift || return;
1477          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1478            my $depth = shift;
1479    
1480          my @args;          my @args;
1481    
# Line 1288  sub cond_to_query { Line 1485  sub cond_to_query {
1485    
1486          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1487                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1488                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1489                  }                  }
1490          }          }
1491    
# Line 1306  sub cond_to_query { Line 1503  sub cond_to_query {
1503                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1504          }          }
1505    
1506          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1507          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1508          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1509          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1510            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1511    
1512          return join('&', @args);          return join('&', @args);
1513  }  }
# Line 1317  sub cond_to_query { Line 1515  sub cond_to_query {
1515    
1516  =head2 shuttle_url  =head2 shuttle_url
1517    
1518  This is method which uses C<IO::Socket::INET> to communicate with Hyper Estraier node  This is method which uses C<LWP::UserAgent> to communicate with Hyper Estraier node
1519  master.  master.
1520    
1521    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
# Line 1327  body will be saved within object. Line 1525  body will be saved within object.
1525    
1526  =cut  =cut
1527    
1528    use LWP::UserAgent;
1529    
1530  sub shuttle_url {  sub shuttle_url {
1531          my $self = shift;          my $self = shift;
1532    
1533          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1534    
1535            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1536    
1537          $self->{status} = -1;          $self->{status} = -1;
1538    
# Line 1345  sub shuttle_url { Line 1547  sub shuttle_url {
1547                  return -1;                  return -1;
1548          }          }
1549    
1550          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1551            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
         if ($self->{pxhost}) {  
                 ($host,$port) = ($self->{pxhost}, $self->{pxport});  
                 $query = "http://$host:$port/$query";  
         }  
   
         $query .= '?' . $url->query if ($url->query && ! $reqbody);  
   
         my $headers;  
1552    
1553            my $req;
1554          if ($reqbody) {          if ($reqbody) {
1555                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1556          } else {          } else {
1557                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1558          }          }
1559    
1560          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1561          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1562          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1563          $headers .= "Content-Type: $content_type\r\n";          $req->content_type( $content_type );
         $headers .= "Authorization: Basic $self->{auth}\r\n";  
         my $len = 0;  
         {  
                 use bytes;  
                 $len = length($reqbody) if ($reqbody);  
         }  
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
1564    
1565          my $sock = IO::Socket::INET->new(          warn $req->headers->as_string,"\n" if ($self->{debug});
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1566    
1567          if (! $sock) {          if ($reqbody) {
1568                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1569                  return -1;                  $req->content( $reqbody );
1570          }          }
1571    
1572          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1573    
1574          print $sock $headers or          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1575    
1576          if ($reqbody) {          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
                 warn "$reqbody\n" if ($self->{debug});  
                 print $sock $reqbody or  
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
         }  
1577    
1578          my $line = <$sock>;          if (! $res->is_success) {
1579          chomp($line);                  if ($croak_on_error) {
1580          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1581          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1582                            return -1;
1583          $self->{status} = $res_status;                  }
1584          warn "## response status: $res_status\n" if ($self->{debug});          }
   
         # skip rest of headers  
         $line = <$sock>;  
         while ($line) {  
                 $line = <$sock>;  
                 $line =~ s/[\r\n]+$//;  
                 warn "## ", $line || 'NULL', " ##\n" if ($self->{debug});  
         };  
1585    
1586          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1587    
1588          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1589    
# Line 1517  sub set_link { Line 1681  sub set_link {
1681          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1682          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1683    
1684          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1685                  'text/plain',                  'application/x-www-form-urlencoded',
1686                  $reqbody,                  $reqbody,
1687                  undef                  undef
1688          ) == 200;          ) == 200) {
1689                    # refresh node info after adding link
1690                    $self->_set_info;
1691                    return 1;
1692            }
1693            return undef;
1694    }
1695    
1696    =head2 admins
1697    
1698     my @admins = @{ $node->admins };
1699    
1700    Return array of users with admin rights on node
1701    
1702    =cut
1703    
1704    sub admins {
1705            my $self = shift;
1706            $self->_set_info unless ($self->{inform}->{name});
1707            return $self->{inform}->{admins};
1708    }
1709    
1710    =head2 guests
1711    
1712     my @guests = @{ $node->guests };
1713    
1714    Return array of users with guest rights on node
1715    
1716    =cut
1717    
1718    sub guests {
1719            my $self = shift;
1720            $self->_set_info unless ($self->{inform}->{name});
1721            return $self->{inform}->{guests};
1722    }
1723    
1724    =head2 links
1725    
1726     my $links = @{ $node->links };
1727    
1728    Return array of links for this node
1729    
1730    =cut
1731    
1732    sub links {
1733            my $self = shift;
1734            $self->_set_info unless ($self->{inform}->{name});
1735            return $self->{inform}->{links};
1736  }  }
1737    
1738    =head2 master
1739    
1740    Set actions on Hyper Estraier node master (C<estmaster> process)
1741    
1742      $node->master(
1743            action => 'sync'
1744      );
1745    
1746    All available actions are documented in
1747    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1748    
1749    =cut
1750    
1751    my $estmaster_rest = {
1752            shutdown => {
1753                    status => 202,
1754            },
1755            sync => {
1756                    status => 202,
1757            },
1758            backup => {
1759                    status => 202,
1760            },
1761            userlist => {
1762                    status => 200,
1763                    returns => [ qw/name passwd flags fname misc/ ],
1764            },
1765            useradd => {
1766                    required => [ qw/name passwd flags/ ],
1767                    optional => [ qw/fname misc/ ],
1768                    status => 200,
1769            },
1770            userdel => {
1771                    required => [ qw/name/ ],
1772                    status => 200,
1773            },
1774            nodelist => {
1775                    status => 200,
1776                    returns => [ qw/name label doc_num word_num size/ ],
1777            },
1778            nodeadd => {
1779                    required => [ qw/name/ ],
1780                    optional => [ qw/label/ ],
1781                    status => 200,
1782            },
1783            nodedel => {
1784                    required => [ qw/name/ ],
1785                    status => 200,
1786            },
1787            nodeclr => {
1788                    required => [ qw/name/ ],
1789                    status => 200,
1790            },
1791            nodertt => {
1792                    status => 200,  
1793            },
1794    };
1795    
1796    sub master {
1797            my $self = shift;
1798    
1799            my $args = {@_};
1800    
1801            # have action?
1802            my $action = $args->{action} || croak "need action, available: ",
1803                    join(", ",keys %{ $estmaster_rest });
1804    
1805            # check if action is valid
1806            my $rest = $estmaster_rest->{$action};
1807            croak "action '$action' is not supported, available actions: ",
1808                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1809    
1810            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1811    
1812            my @args;
1813    
1814            if ($rest->{required} || $rest->{optional}) {
1815    
1816                    map {
1817                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1818                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1819                    } ( @{ $rest->{required} } );
1820    
1821                    map {
1822                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1823                    } ( @{ $rest->{optional} } );
1824    
1825            }
1826    
1827            my $uri = new URI( $self->{url} );
1828    
1829            my $resbody;
1830    
1831            my $status = $self->shuttle_url(
1832                    'http://' . $uri->host_port . '/master?action=' . $action ,
1833                    'application/x-www-form-urlencoded',
1834                    join('&', @args),
1835                    \$resbody,
1836                    1,
1837            ) or confess "shuttle_url failed";
1838    
1839            if ($status == $rest->{status}) {
1840    
1841                    # refresh node info after sync
1842                    $self->_set_info if ($action eq 'sync');
1843    
1844                    if ($rest->{returns} && wantarray) {
1845    
1846                            my @results;
1847                            my $fields = $#{$rest->{returns}};
1848    
1849                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1850                                    my @e = split(/\t/, $line, $fields + 1);
1851                                    my $row;
1852                                    foreach my $i ( 0 .. $fields) {
1853                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1854                                    }
1855                                    push @results, $row;
1856                            }
1857    
1858                            return @results;
1859    
1860                    } elsif ($resbody) {
1861                            chomp $resbody;
1862                            return $resbody;
1863                    } else {
1864                            return 0E0;
1865                    }
1866            }
1867    
1868            carp "expected status $rest->{status}, but got $status";
1869            return undef;
1870    }
1871    
1872  =head1 PRIVATE METHODS  =head1 PRIVATE METHODS
1873    
# Line 1552  sub _set_info { Line 1896  sub _set_info {
1896    
1897          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1898    
1899          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1900          $resbody =~ s/[\r\n]+$//;  
1901            $self->{inform} = {};
1902    
1903            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1904                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1905    
1906            return $resbody unless (@lines);
1907    
1908            shift @lines;
1909    
1910            while(my $admin = shift @lines) {
1911                    push @{$self->{inform}->{admins}}, $admin;
1912            }
1913    
1914            while(my $guest = shift @lines) {
1915                    push @{$self->{inform}->{guests}}, $guest;
1916            }
1917    
1918            while(my $link = shift @lines) {
1919                    push @{$self->{inform}->{links}}, $link;
1920            }
1921    
1922          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          return $resbody;
                 split(/\t/, $resbody, 5);  
1923    
1924  }  }
1925    
# Line 1576  Hyper Estraier Ruby interface on which t Line 1939  Hyper Estraier Ruby interface on which t
1939    
1940  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1941    
1942    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1943    
1944  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1945    
Legend:
Removed from v.58  
changed lines
  Added in v.150
  ViewVC Help
Powered by ViewVC 1.1.26