/[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 134 by dpavlin, Tue May 9 12:21:26 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            );
25    
26            # create document
27            my $doc = new Search::Estraier::Document;
28    
29            # add attributes
30            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
31            $doc->add_attr('@title', "Over the Rainbow");
32    
33            # add body text to document
34            $doc->add_text("Somewhere over the rainbow.  Way up high.");
35            $doc->add_text("There's a land that I heard of once in a lullaby.");
36    
37            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
38    
39    =head2 Simple searcher
40    
41            use Search::Estraier;
42    
43            # create and configure node
44            my $node = new Search::Estraier::Node(
45                    url => 'http://localhost:1978/node/test',
46                    user => 'admin',
47                    passwd => 'admin',
48                    croak_on_error => 1,
49            );
50    
51            # create condition
52            my $cond = new Search::Estraier::Condition;
53    
54            # set search phrase
55            $cond->set_phrase("rainbow AND lullaby");
56    
57            my $nres = $node->search($cond, 0);
58    
59            if (defined($nres)) {
60                    print "Got ", $nres->hits, " results\n";
61    
62                    # for each document in results
63                    for my $i ( 0 ... $nres->doc_num - 1 ) {
64                            # get result document
65                            my $rdoc = $nres->get_doc($i);
66                            # display attribte
67                            print "URI: ", $rdoc->attr('@uri'),"\n";
68                            print "Title: ", $rdoc->attr('@title'),"\n";
69                            print $rdoc->snippet,"\n";
70                    }
71            } else {
72                    die "error: ", $node->status,"\n";
73            }
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 25  or Hyper Estraier development files on t Line 82  or Hyper Estraier development files on t
82  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
83  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
84    
85    There are few examples in C<scripts> directory of this distribution.
86    
87  =cut  =cut
88    
89  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 100  Remove multiple whitespaces from string,
100  =cut  =cut
101    
102  sub _s {  sub _s {
103          my $text = $_[1] || return;          my $text = $_[1];
104            return unless defined($text);
105          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
106          $text =~ s/^\s+//;          $text =~ s/^\s+//;
107          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 166  sub new {
166                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
167                                  $in_text = 1;                                  $in_text = 1;
168                                  next;                                  next;
169                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
170                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
171                                  next;                                  next;
172                          }                          }
173    
174                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
175                  }                  }
176          }          }
177    
# Line 205  Returns array with attribute names from Line 265  Returns array with attribute names from
265    
266  sub attr_names {  sub attr_names {
267          my $self = shift;          my $self = shift;
268          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
269            #croak "attr_names return array, not scalar" if (! wantarray);
270          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
271  }  }
272    
# Line 221  Returns value of an attribute. Line 282  Returns value of an attribute.
282  sub attr {  sub attr {
283          my $self = shift;          my $self = shift;
284          my $name = shift;          my $name = shift;
285            return unless (defined($name) && $self->{attrs});
286          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
287  }  }
288    
289    
# Line 236  Returns array with text sentences. Line 297  Returns array with text sentences.
297    
298  sub texts {  sub texts {
299          my $self = shift;          my $self = shift;
300          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
301          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
302  }  }
303    
304    
# Line 251  Return whole text as single scalar. Line 312  Return whole text as single scalar.
312    
313  sub cat_texts {  sub cat_texts {
314          my $self = shift;          my $self = shift;
315          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
316  }  }
317    
318    
# Line 268  sub dump_draft { Line 329  sub dump_draft {
329          my $draft;          my $draft;
330    
331          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
332                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
333                    $draft .= $attr_name . '=' . $v . "\n";
334          }          }
335    
336          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 378  sub delete {
378    
379  package Search::Estraier::Condition;  package Search::Estraier::Condition;
380    
381  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
382    
383  use Search::Estraier;  use Search::Estraier;
384  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 456  sub set_max {
456    
457  =head2 set_options  =head2 set_options
458    
459    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
460    
461      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
462    
463    Possible options are:
464    
465    =over 8
466    
467    =item SURE
468    
469    check every N-gram
470    
471    =item USUAL
472    
473    check every second N-gram
474    
475    =item FAST
476    
477    check every third N-gram
478    
479    =item AGITO
480    
481    check every fourth N-gram
482    
483    =item NOIDF
484    
485    don't perform TF-IDF tuning
486    
487    =item SIMPLE
488    
489    use simplified query phrase
490    
491    =back
492    
493    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
494    options;
495    
496    This option changed in version C<0.04> of this module. It's backwards compatibile.
497    
498  =cut  =cut
499    
500  my $options = {  my $options = {
         # check N-gram keys skipping by three  
501          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
502          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
503          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
504          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
505          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
506          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
507  };  };
508    
509  sub set_options {  sub set_options {
510          my $self = shift;          my $self = shift;
511          my $option = shift;          my $opt = 0;
512          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
513          $self->{options} ||= $options->{$option};                  my $mask;
514                    unless ($mask = $options->{$option}) {
515                            if ($option eq '1') {
516                                    next;
517                            } else {
518                                    croak "unknown option $option";
519                            }
520                    }
521                    $opt += $mask;
522            }
523            $self->{options} = $opt;
524  }  }
525    
526    
# Line 460  Return search result attrs. Line 563  Return search result attrs.
563  sub attrs {  sub attrs {
564          my $self = shift;          my $self = shift;
565          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
566          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
567  }  }
568    
569    
# Line 496  sub options { Line 599  sub options {
599  }  }
600    
601    
602    =head2 set_skip
603    
604    Set number of skipped documents from beginning of results
605    
606      $cond->set_skip(42);
607    
608    Similar to C<offset> in RDBMS.
609    
610    =cut
611    
612    sub set_skip {
613            my $self = shift;
614            $self->{skip} = shift;
615    }
616    
617    =head2 skip
618    
619    Return skip for this condition.
620    
621      print $cond->skip;
622    
623    =cut
624    
625    sub skip {
626            my $self = shift;
627            return $self->{skip};
628    }
629    
630    
631  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
632    
633  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 656  sub new {
656          my $self = {@_};          my $self = {@_};
657          bless($self, $class);          bless($self, $class);
658    
659          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});  
         }  
660    
661          $self ? return $self : return undef;          $self ? return $self : return undef;
662  }  }
# Line 641  Return number of documents Line 771  Return number of documents
771    
772    print $res->doc_num;    print $res->doc_num;
773    
774    This will return real number of documents (limited by C<max>).
775    If you want to get total number of hits, see C<hits>.
776    
777  =cut  =cut
778    
779  sub doc_num {  sub doc_num {
# Line 672  sub get_doc { Line 805  sub get_doc {
805    
806  Return specific hint from results.  Return specific hint from results.
807    
808    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
809    
810  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>,
811  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 818  sub hint {
818          return $self->{hints}->{$key};          return $self->{hints}->{$key};
819  }  }
820    
821    =head2 hints
822    
823    More perlish version of C<hint>. This one returns hash.
824    
825      my %hints = $res->hints;
826    
827    =cut
828    
829    sub hints {
830            my $self = shift;
831            return $self->{hints};
832    }
833    
834    =head2 hits
835    
836    Syntaxtic sugar for total number of hits for this query
837    
838      print $res->hits;
839    
840    It's same as
841    
842      print $res->hint('HIT');
843    
844    but shorter.
845    
846    =cut
847    
848    sub hits {
849            my $self = shift;
850            return $self->{hints}->{'HIT'} || 0;
851    }
852    
853  package Search::Estraier::Node;  package Search::Estraier::Node;
854    
# Line 700  use URI::Escape qw/uri_escape/; Line 864  use URI::Escape qw/uri_escape/;
864    
865    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
866    
867    or optionally with C<url> as parametar
868    
869      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
870    
871    or in more verbose form
872    
873      my $node = new Search::HyperEstraier::Node(
874            url => 'http://localhost:1978/node/test',
875            user => 'admin',
876            passwd => 'admin'
877            debug => 1,
878            croak_on_error => 1
879      );
880    
881    with following arguments:
882    
883    =over 4
884    
885    =item url
886    
887    URL to node
888    
889    =item user
890    
891    specify username for node server authentication
892    
893    =item passwd
894    
895    password for authentication
896    
897    =item debug
898    
899    dumps a B<lot> of debugging output
900    
901    =item croak_on_error
902    
903    very helpful during development. It will croak on all errors instead of
904    silently returning C<-1> (which is convention of Hyper Estraier API in other
905    languages).
906    
907    =back
908    
909  =cut  =cut
910    
911  sub new {  sub new {
# Line 707  sub new { Line 913  sub new {
913          my $self = {          my $self = {
914                  pxport => -1,                  pxport => -1,
915                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
916                  wwidth => 480,                  wwidth => 480,
917                  hwidth => 96,                  hwidth => 96,
918                  awidth => 96,                  awidth => 96,
919                  status => -1,                  status => -1,
920          };          };
921    
922          bless($self, $class);          bless($self, $class);
923    
924          my $args = {@_};          if ($#_ == 0) {
925                    $self->{url} = shift;
926            } else {
927                    %$self = ( %$self, @_ );
928    
929                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
930    
931          $self->{debug} = $args->{debug};                  warn "## Node debug on\n" if ($self->{debug});
932          warn "## Node debug on\n" if ($self->{debug});          }
933    
934            $self->{inform} = {
935                    dnum => -1,
936                    wnum => -1,
937                    size => -1.0,
938            };
939    
940          $self ? return $self : return undef;          $self ? return $self : return undef;
941  }  }
# Line 1000  Get ID of document specified by URI Line 1215  Get ID of document specified by URI
1215    
1216    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1217    
1218    This method won't croak, even if using C<croak_on_error>.
1219    
1220  =cut  =cut
1221    
1222  sub uri_to_id {  sub uri_to_id {
1223          my $self = shift;          my $self = shift;
1224          my $uri = shift || return;          my $uri = shift || return;
1225          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 );
1226  }  }
1227    
1228    
# Line 1065  sub _fetch_doc { Line 1282  sub _fetch_doc {
1282                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1283                  $arg,                  $arg,
1284                  \$resbody,                  \$resbody,
1285                    $a->{croak_on_error},
1286          );          );
1287    
1288          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1313  sub _fetch_doc {
1313    
1314  sub name {  sub name {
1315          my $self = shift;          my $self = shift;
1316          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1317          return $self->{name};          return $self->{inform}->{name};
1318  }  }
1319    
1320    
# Line 1108  sub name { Line 1326  sub name {
1326    
1327  sub label {  sub label {
1328          my $self = shift;          my $self = shift;
1329          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1330          return $self->{label};          return $self->{inform}->{label};
1331  }  }
1332    
1333    
# Line 1121  sub label { Line 1339  sub label {
1339    
1340  sub doc_num {  sub doc_num {
1341          my $self = shift;          my $self = shift;
1342          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1343          return $self->{dnum};          return $self->{inform}->{dnum};
1344  }  }
1345    
1346    
# Line 1134  sub doc_num { Line 1352  sub doc_num {
1352    
1353  sub word_num {  sub word_num {
1354          my $self = shift;          my $self = shift;
1355          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1356          return $self->{wnum};          return $self->{inform}->{wnum};
1357  }  }
1358    
1359    
# Line 1147  sub word_num { Line 1365  sub word_num {
1365    
1366  sub size {  sub size {
1367          my $self = shift;          my $self = shift;
1368          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1369          return $self->{size};          return $self->{inform}->{size};
1370  }  }
1371    
1372    
# Line 1176  sub search { Line 1394  sub search {
1394    
1395          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1396                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1397                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1398                  \$resbody,                  \$resbody,
1399          );          );
1400          return if ($rv != 200);          return if ($rv != 200);
1401    
1402          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1403            my $hintsText   = splice @records, 0, 2; # starts with empty record
1404          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1405          return unless (@lines);  
1406            # process records
1407          my $border = $lines[0];          my $docs = [];
1408          my $isend = 0;          foreach my $record (@records)
1409          my $lnum = 1;          {
1410                    # split into keys and snippets
1411          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$/);  
                 }  
   
         }  
1412    
1413          if (! $isend) {                  # create document hash
1414                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1415                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1416                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1417                    $doc->{snippet}         = $snippet;
1418    
1419                    push @$docs, new Search::Estraier::ResultDocument(
1420                            attrs           => $doc,
1421                            uri             => $doc->{'@uri'},
1422                            snippet         => $snippet,
1423                            keywords        => $doc->{'keywords'},
1424                    );
1425          }          }
1426    
1427          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1428  }  }
1429    
1430    
# Line 1270  sub search { Line 1432  sub search {
1432    
1433  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1434    
1435    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1436    
1437  =cut  =cut
1438    
# Line 1279  sub cond_to_query { Line 1441  sub cond_to_query {
1441    
1442          my $cond = shift || return;          my $cond = shift || return;
1443          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'));
1444            my $depth = shift;
1445    
1446          my @args;          my @args;
1447    
# Line 1288  sub cond_to_query { Line 1451  sub cond_to_query {
1451    
1452          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1453                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1454                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1455                  }                  }
1456          }          }
1457    
# Line 1306  sub cond_to_query { Line 1469  sub cond_to_query {
1469                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1470          }          }
1471    
1472          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1473          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1474          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1475          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1476            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1477    
1478          return join('&', @args);          return join('&', @args);
1479  }  }
# Line 1317  sub cond_to_query { Line 1481  sub cond_to_query {
1481    
1482  =head2 shuttle_url  =head2 shuttle_url
1483    
1484  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
1485  master.  master.
1486    
1487    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 1491  body will be saved within object.
1491    
1492  =cut  =cut
1493    
1494    use LWP::UserAgent;
1495    
1496  sub shuttle_url {  sub shuttle_url {
1497          my $self = shift;          my $self = shift;
1498    
1499          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1500    
1501            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1502    
1503          $self->{status} = -1;          $self->{status} = -1;
1504    
# Line 1345  sub shuttle_url { Line 1513  sub shuttle_url {
1513                  return -1;                  return -1;
1514          }          }
1515    
1516          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1517            $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;  
1518    
1519            my $req;
1520          if ($reqbody) {          if ($reqbody) {
1521                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1522          } else {          } else {
1523                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1524          }          }
1525    
1526          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1527          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1528          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1529          $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";  
1530    
1531          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,  
         );  
1532    
1533          if (! $sock) {          if ($reqbody) {
1534                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1535                  return -1;                  $req->content( $reqbody );
1536          }          }
1537    
1538          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1539    
1540          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;  
1541    
1542          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;  
         }  
1543    
1544          my $line = <$sock>;          if (! $res->is_success) {
1545          chomp($line);                  if ($croak_on_error) {
1546          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1547          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1548                            return -1;
1549          $self->{status} = $res_status;                  }
1550          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});  
         };  
1551    
1552          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1553    
1554          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1555    
# Line 1517  sub set_link { Line 1647  sub set_link {
1647          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1648          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1649    
1650          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1651                  'text/plain',                  'application/x-www-form-urlencoded',
1652                  $reqbody,                  $reqbody,
1653                  undef                  undef
1654          ) == 200;          ) == 200) {
1655                    # refresh node info after adding link
1656                    $self->_set_info;
1657                    return 1;
1658            }
1659    }
1660    
1661    =head2 admins
1662    
1663     my @admins = @{ $node->admins };
1664    
1665    Return array of users with admin rights on node
1666    
1667    =cut
1668    
1669    sub admins {
1670            my $self = shift;
1671            $self->_set_info unless ($self->{inform}->{name});
1672            return $self->{inform}->{admins};
1673  }  }
1674    
1675    =head2 guests
1676    
1677     my @guests = @{ $node->guests };
1678    
1679    Return array of users with guest rights on node
1680    
1681    =cut
1682    
1683    sub guests {
1684            my $self = shift;
1685            $self->_set_info unless ($self->{inform}->{name});
1686            return $self->{inform}->{guests};
1687    }
1688    
1689    =head2 links
1690    
1691     my $links = @{ $node->links };
1692    
1693    Return array of links for this node
1694    
1695    =cut
1696    
1697    sub links {
1698            my $self = shift;
1699            $self->_set_info unless ($self->{inform}->{name});
1700            return $self->{inform}->{links};
1701    }
1702    
1703    =head2 master
1704    
1705    Set actions on Hyper Estraier node master (C<estmaster> process)
1706    
1707      $node->master(
1708            action => 'sync'
1709      );
1710    
1711    All available actions are documented in
1712    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1713    
1714    =cut
1715    
1716    my $estmaster_rest = {
1717            shutdown => {
1718                    status => 202,
1719            },
1720            sync => {
1721                    status => 202,
1722            },
1723            backup => {
1724                    status => 202,
1725            },
1726            userlist => {
1727                    status => 200,
1728                    returns => qw/name passwd flags fname misc/,
1729            },
1730            useradd => {
1731                    required => qw/name passwd flags/,
1732                    optional => qw/fname misc/,
1733                    status => 200,
1734            },
1735            userdel => {
1736                    required => qw/name/,
1737                    status => 200,
1738            },
1739            nodelist => {
1740                    status => 200,
1741                    returns => qw/name label doc_num word_num size/,
1742            },
1743            nodeadd => {
1744                    required => qw/name/,
1745                    optional => qw/label/,
1746                    status => 200,
1747            },
1748            nodedel => {
1749                    required => qw/name/,
1750                    status => 200,
1751            },
1752            nodeclr => {
1753                    required => qw/name/,
1754                    status => 200,
1755            },
1756            nodertt => {
1757                    status => 200,  
1758            },
1759    };
1760    
1761    sub master {
1762            my $self = shift;
1763    
1764            my $args = {@_};
1765    
1766            # have action?
1767            my $action = $args->{action} || croak "need action, available: ",
1768                    join(", ",keys %{ $estmaster_rest });
1769    
1770            # check if action is valid
1771            my $rest = $estmaster_rest->{$action};
1772            croak "action '$action' is not supported, available actions: ",
1773                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1774    
1775            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1776    
1777            my @args;
1778    
1779            if ($rest->{required} || $rest->{optional}) {
1780    
1781                    map {
1782                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1783                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1784                    } ( keys %{ $rest->{required} } );
1785    
1786                    map {
1787                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1788                    } ( keys %{ $rest->{optional} } );
1789    
1790            }
1791    
1792            my $uri = new URI( $self->{url} );
1793    
1794            my $resbody;
1795    
1796            if ($self->shuttle_url(
1797                    'http://' . $uri->host_port . '/master?action=' . $action ,
1798                    'application/x-www-form-urlencoded',
1799                    join('&', @args),
1800                    \$resbody,
1801                    1,
1802            ) == $rest->{status}) {
1803                    return 0E0 unless ($rest->{returns});
1804    
1805                    if (wantarray) {
1806    
1807                            my @results;
1808    
1809                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1810                                    my @e = split(/\t/, $line);
1811                                    my $row;
1812                                    map { $row->{$_} = shift @e; } @{ $rest->{returns} };
1813                                    push @results, $row;
1814                            }
1815    
1816                            return @results;
1817                    } else {
1818    
1819                            carp "calling master action '$action', but not expecting array back, returning whole body";
1820                            return $resbody;
1821                    }
1822            }
1823    }
1824    
1825  =head1 PRIVATE METHODS  =head1 PRIVATE METHODS
1826    
# Line 1552  sub _set_info { Line 1849  sub _set_info {
1849    
1850          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1851    
1852          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1853          $resbody =~ s/[\r\n]+$//;  
1854            $self->{inform} = {};
1855    
1856            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1857                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1858    
1859            return $resbody unless (@lines);
1860    
1861            shift @lines;
1862    
1863            while(my $admin = shift @lines) {
1864                    push @{$self->{inform}->{admins}}, $admin;
1865            }
1866    
1867            while(my $guest = shift @lines) {
1868                    push @{$self->{inform}->{guests}}, $guest;
1869            }
1870    
1871            while(my $link = shift @lines) {
1872                    push @{$self->{inform}->{links}}, $link;
1873            }
1874    
1875          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          return $resbody;
                 split(/\t/, $resbody, 5);  
1876    
1877  }  }
1878    
# Line 1576  Hyper Estraier Ruby interface on which t Line 1892  Hyper Estraier Ruby interface on which t
1892    
1893  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1894    
1895    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1896    
1897  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1898    
Legend:
Removed from v.58  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.26