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