/[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 142 by dpavlin, Wed May 10 14:57:50 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.06';
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->{debug} = $args->{debug};          $self->{inform} = {
948          warn "## Node debug on\n" if ($self->{debug});                  dnum => -1,
949                    wnum => -1,
950                    size => -1.0,
951            };
952    
953            if ($self->{create}) {
954                    if (! eval { $self->name } || $@) {
955                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
956                            croak "can't find node name in '$self->{url}'" unless ($name);
957                            my $label = $self->{label} || $name;
958                            $self->master(
959                                    action => 'nodeadd',
960                                    name => $name,
961                                    label => $label,
962                            ) || croak "can't create node $name ($label)";
963                    }
964            }
965    
966          $self ? return $self : return undef;          $self ? return $self : return undef;
967  }  }
# Line 1000  Get ID of document specified by URI Line 1241  Get ID of document specified by URI
1241    
1242    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1243    
1244    This method won't croak, even if using C<croak_on_error>.
1245    
1246  =cut  =cut
1247    
1248  sub uri_to_id {  sub uri_to_id {
1249          my $self = shift;          my $self = shift;
1250          my $uri = shift || return;          my $uri = shift || return;
1251          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 );
1252  }  }
1253    
1254    
# Line 1065  sub _fetch_doc { Line 1308  sub _fetch_doc {
1308                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1309                  $arg,                  $arg,
1310                  \$resbody,                  \$resbody,
1311                    $a->{croak_on_error},
1312          );          );
1313    
1314          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1339  sub _fetch_doc {
1339    
1340  sub name {  sub name {
1341          my $self = shift;          my $self = shift;
1342          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1343          return $self->{name};          return $self->{inform}->{name};
1344  }  }
1345    
1346    
# Line 1108  sub name { Line 1352  sub name {
1352    
1353  sub label {  sub label {
1354          my $self = shift;          my $self = shift;
1355          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1356          return $self->{label};          return $self->{inform}->{label};
1357  }  }
1358    
1359    
# Line 1121  sub label { Line 1365  sub label {
1365    
1366  sub doc_num {  sub doc_num {
1367          my $self = shift;          my $self = shift;
1368          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1369          return $self->{dnum};          return $self->{inform}->{dnum};
1370  }  }
1371    
1372    
# Line 1134  sub doc_num { Line 1378  sub doc_num {
1378    
1379  sub word_num {  sub word_num {
1380          my $self = shift;          my $self = shift;
1381          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1382          return $self->{wnum};          return $self->{inform}->{wnum};
1383  }  }
1384    
1385    
# Line 1147  sub word_num { Line 1391  sub word_num {
1391    
1392  sub size {  sub size {
1393          my $self = shift;          my $self = shift;
1394          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1395          return $self->{size};          return $self->{inform}->{size};
1396  }  }
1397    
1398    
# Line 1176  sub search { Line 1420  sub search {
1420    
1421          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1422                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1423                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1424                  \$resbody,                  \$resbody,
1425          );          );
1426          return if ($rv != 200);          return if ($rv != 200);
1427    
1428          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1429            my $hintsText   = splice @records, 0, 2; # starts with empty record
1430          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1431          return unless (@lines);  
1432            # process records
1433          my $border = $lines[0];          my $docs = [];
1434          my $isend = 0;          foreach my $record (@records)
1435          my $lnum = 1;          {
1436                    # split into keys and snippets
1437          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$/);  
                 }  
   
         }  
1438    
1439          if (! $isend) {                  # create document hash
1440                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1441                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1442                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1443                    $doc->{snippet}         = $snippet;
1444    
1445                    push @$docs, new Search::Estraier::ResultDocument(
1446                            attrs           => $doc,
1447                            uri             => $doc->{'@uri'},
1448                            snippet         => $snippet,
1449                            keywords        => $doc->{'keywords'},
1450                    );
1451          }          }
1452    
1453          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1454  }  }
1455    
1456    
# Line 1270  sub search { Line 1458  sub search {
1458    
1459  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1460    
1461    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1462    
1463  =cut  =cut
1464    
# Line 1279  sub cond_to_query { Line 1467  sub cond_to_query {
1467    
1468          my $cond = shift || return;          my $cond = shift || return;
1469          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'));
1470            my $depth = shift;
1471    
1472          my @args;          my @args;
1473    
# Line 1288  sub cond_to_query { Line 1477  sub cond_to_query {
1477    
1478          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1479                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1480                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1481                  }                  }
1482          }          }
1483    
# Line 1306  sub cond_to_query { Line 1495  sub cond_to_query {
1495                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1496          }          }
1497    
1498          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1499          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1500          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1501          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1502            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1503    
1504          return join('&', @args);          return join('&', @args);
1505  }  }
# Line 1317  sub cond_to_query { Line 1507  sub cond_to_query {
1507    
1508  =head2 shuttle_url  =head2 shuttle_url
1509    
1510  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
1511  master.  master.
1512    
1513    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 1517  body will be saved within object.
1517    
1518  =cut  =cut
1519    
1520    use LWP::UserAgent;
1521    
1522  sub shuttle_url {  sub shuttle_url {
1523          my $self = shift;          my $self = shift;
1524    
1525          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1526    
1527            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1528    
1529          $self->{status} = -1;          $self->{status} = -1;
1530    
# Line 1345  sub shuttle_url { Line 1539  sub shuttle_url {
1539                  return -1;                  return -1;
1540          }          }
1541    
1542          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1543            $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;  
1544    
1545            my $req;
1546          if ($reqbody) {          if ($reqbody) {
1547                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1548          } else {          } else {
1549                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1550          }          }
1551    
1552          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1553          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1554          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1555          $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";  
1556    
1557          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,  
         );  
1558    
1559          if (! $sock) {          if ($reqbody) {
1560                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1561                  return -1;                  $req->content( $reqbody );
1562          }          }
1563    
1564          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1565    
1566          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;  
1567    
1568          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;  
         }  
1569    
1570          my $line = <$sock>;          if (! $res->is_success) {
1571          chomp($line);                  if ($croak_on_error) {
1572          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1573          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1574                            return -1;
1575          $self->{status} = $res_status;                  }
1576          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});  
         };  
1577    
1578          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1579    
1580          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1581    
# Line 1517  sub set_link { Line 1673  sub set_link {
1673          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1674          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1675    
1676          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1677                  'text/plain',                  'application/x-www-form-urlencoded',
1678                  $reqbody,                  $reqbody,
1679                  undef                  undef
1680          ) == 200;          ) == 200) {
1681                    # refresh node info after adding link
1682                    $self->_set_info;
1683                    return 1;
1684            }
1685  }  }
1686    
1687    =head2 admins
1688    
1689     my @admins = @{ $node->admins };
1690    
1691    Return array of users with admin rights on node
1692    
1693    =cut
1694    
1695    sub admins {
1696            my $self = shift;
1697            $self->_set_info unless ($self->{inform}->{name});
1698            return $self->{inform}->{admins};
1699    }
1700    
1701    =head2 guests
1702    
1703     my @guests = @{ $node->guests };
1704    
1705    Return array of users with guest rights on node
1706    
1707    =cut
1708    
1709    sub guests {
1710            my $self = shift;
1711            $self->_set_info unless ($self->{inform}->{name});
1712            return $self->{inform}->{guests};
1713    }
1714    
1715    =head2 links
1716    
1717     my $links = @{ $node->links };
1718    
1719    Return array of links for this node
1720    
1721    =cut
1722    
1723    sub links {
1724            my $self = shift;
1725            $self->_set_info unless ($self->{inform}->{name});
1726            return $self->{inform}->{links};
1727    }
1728    
1729    =head2 master
1730    
1731    Set actions on Hyper Estraier node master (C<estmaster> process)
1732    
1733      $node->master(
1734            action => 'sync'
1735      );
1736    
1737    All available actions are documented in
1738    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1739    
1740    =cut
1741    
1742    my $estmaster_rest = {
1743            shutdown => {
1744                    status => 202,
1745            },
1746            sync => {
1747                    status => 202,
1748            },
1749            backup => {
1750                    status => 202,
1751            },
1752            userlist => {
1753                    status => 200,
1754                    returns => [ qw/name passwd flags fname misc/ ],
1755            },
1756            useradd => {
1757                    required => [ qw/name passwd flags/ ],
1758                    optional => [ qw/fname misc/ ],
1759                    status => 200,
1760            },
1761            userdel => {
1762                    required => [ qw/name/ ],
1763                    status => 200,
1764            },
1765            nodelist => {
1766                    status => 200,
1767                    returns => [ qw/name label doc_num word_num size/ ],
1768            },
1769            nodeadd => {
1770                    required => [ qw/name/ ],
1771                    optional => [ qw/label/ ],
1772                    status => 200,
1773            },
1774            nodedel => {
1775                    required => [ qw/name/ ],
1776                    status => 200,
1777            },
1778            nodeclr => {
1779                    required => [ qw/name/ ],
1780                    status => 200,
1781            },
1782            nodertt => {
1783                    status => 200,  
1784            },
1785    };
1786    
1787    sub master {
1788            my $self = shift;
1789    
1790            my $args = {@_};
1791    
1792            # have action?
1793            my $action = $args->{action} || croak "need action, available: ",
1794                    join(", ",keys %{ $estmaster_rest });
1795    
1796            # check if action is valid
1797            my $rest = $estmaster_rest->{$action};
1798            croak "action '$action' is not supported, available actions: ",
1799                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1800    
1801            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1802    
1803            my @args;
1804    
1805            if ($rest->{required} || $rest->{optional}) {
1806    
1807                    map {
1808                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1809                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1810                    } ( @{ $rest->{required} } );
1811    
1812                    map {
1813                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1814                    } ( @{ $rest->{optional} } );
1815    
1816            }
1817    
1818            my $uri = new URI( $self->{url} );
1819    
1820            my $resbody;
1821    
1822            my $status = $self->shuttle_url(
1823                    'http://' . $uri->host_port . '/master?action=' . $action ,
1824                    'application/x-www-form-urlencoded',
1825                    join('&', @args),
1826                    \$resbody,
1827                    1,
1828            ) or confess "shuttle_url failed";
1829    
1830            if ($status == $rest->{status}) {
1831                    if ($rest->{returns} && wantarray) {
1832    
1833                            my @results;
1834                            my $fields = $#{$rest->{returns}};
1835    
1836                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1837                                    my @e = split(/\t/, $line, $fields + 1);
1838                                    my $row;
1839                                    foreach my $i ( 0 .. $fields) {
1840                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1841                                    }
1842                                    push @results, $row;
1843                            }
1844    
1845                            return @results;
1846    
1847                    } elsif ($resbody) {
1848                            chomp $resbody;
1849                            return $resbody;
1850                    } else {
1851                            return 0E0;
1852                    }
1853            }
1854    
1855            carp "expected status $rest->{status}, but got $status";
1856            return undef;
1857    }
1858    
1859  =head1 PRIVATE METHODS  =head1 PRIVATE METHODS
1860    
# Line 1552  sub _set_info { Line 1883  sub _set_info {
1883    
1884          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1885    
1886          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1887          $resbody =~ s/[\r\n]+$//;  
1888            $self->{inform} = {};
1889    
1890            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1891                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1892    
1893            return $resbody unless (@lines);
1894    
1895            shift @lines;
1896    
1897            while(my $admin = shift @lines) {
1898                    push @{$self->{inform}->{admins}}, $admin;
1899            }
1900    
1901            while(my $guest = shift @lines) {
1902                    push @{$self->{inform}->{guests}}, $guest;
1903            }
1904    
1905            while(my $link = shift @lines) {
1906                    push @{$self->{inform}->{links}}, $link;
1907            }
1908    
1909          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          return $resbody;
                 split(/\t/, $resbody, 5);  
1910    
1911  }  }
1912    
# Line 1576  Hyper Estraier Ruby interface on which t Line 1926  Hyper Estraier Ruby interface on which t
1926    
1927  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1928    
1929    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1930    
1931  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1932    
Legend:
Removed from v.58  
changed lines
  Added in v.142
  ViewVC Help
Powered by ViewVC 1.1.26