/[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 47 by dpavlin, Fri Jan 6 01:51:28 2006 UTC revision 164 by dpavlin, Sun Aug 6 12:19:19 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.07_2';
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 57  our @ISA = qw/Search::Estraier/; Line 120  our @ISA = qw/Search::Estraier/;
120    
121  =head1 Search::Estraier::Document  =head1 Search::Estraier::Document
122    
123  This class implements Document which is collection of attributes  This class implements Document which is single item in Hyper Estraier.
124  (key=value), vectors (also key value) display text and hidden text.  
125    It's is collection of:
126    
127    =over 4
128    
129    =item attributes
130    
131    C<< 'key' => 'value' >> pairs which can later be used for filtering of results
132    
133    You can add common filters to C<attrindex> in estmaster's C<_conf>
134    file for better performance. See C<attrindex> in
135    L<Hyper Estraier P2P Guide|http://hyperestraier.sourceforge.net/nguide-en.html>.
136    
137    =item vectors
138    
139    also C<< 'key' => 'value' >> pairs
140    
141    =item display text
142    
143    Text which will be used to create searchable corpus of your index and
144    included in snippet output.
145    
146    =item hidden text
147    
148    Text which will be searchable, but will not be included in snippet.
149    
150    =back
151    
152  =head2 new  =head2 new
153    
# Line 106  sub new { Line 194  sub new {
194                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
195                                  $in_text = 1;                                  $in_text = 1;
196                                  next;                                  next;
197                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
198                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
199                                  next;                                  next;
200                          }                          }
201    
202                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
203                  }                  }
204          }          }
205    
# Line 205  Returns array with attribute names from Line 293  Returns array with attribute names from
293    
294  sub attr_names {  sub attr_names {
295          my $self = shift;          my $self = shift;
296          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
297            #croak "attr_names return array, not scalar" if (! wantarray);
298          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
299  }  }
300    
# Line 221  Returns value of an attribute. Line 310  Returns value of an attribute.
310  sub attr {  sub attr {
311          my $self = shift;          my $self = shift;
312          my $name = shift;          my $name = shift;
313            return unless (defined($name) && $self->{attrs});
314          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
315  }  }
316    
317    
# Line 236  Returns array with text sentences. Line 325  Returns array with text sentences.
325    
326  sub texts {  sub texts {
327          my $self = shift;          my $self = shift;
328          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
329          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
330  }  }
331    
332    
# Line 251  Return whole text as single scalar. Line 340  Return whole text as single scalar.
340    
341  sub cat_texts {  sub cat_texts {
342          my $self = shift;          my $self = shift;
343          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
344  }  }
345    
346    
# Line 268  sub dump_draft { Line 357  sub dump_draft {
357          my $draft;          my $draft;
358    
359          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
360                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
361                    $draft .= $attr_name . '=' . $v . "\n";
362          }          }
363    
364          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 406  sub delete {
406    
407  package Search::Estraier::Condition;  package Search::Estraier::Condition;
408    
409  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
410    
411  use Search::Estraier;  use Search::Estraier;
412  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 484  sub set_max {
484    
485  =head2 set_options  =head2 set_options
486    
487    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
488    
489      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
490    
491    Possible options are:
492    
493    =over 8
494    
495    =item SURE
496    
497    check every N-gram
498    
499    =item USUAL
500    
501    check every second N-gram
502    
503    =item FAST
504    
505    check every third N-gram
506    
507    =item AGITO
508    
509    check every fourth N-gram
510    
511    =item NOIDF
512    
513    don't perform TF-IDF tuning
514    
515    =item SIMPLE
516    
517    use simplified query phrase
518    
519    =back
520    
521    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
522    options;
523    
524    This option changed in version C<0.04> of this module. It's backwards compatibile.
525    
526  =cut  =cut
527    
528  my $options = {  my $options = {
         # check N-gram keys skipping by three  
529          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
530          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
531          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
532          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
533          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
534          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
535  };  };
536    
537  sub set_options {  sub set_options {
538          my $self = shift;          my $self = shift;
539          my $option = shift;          my $opt = 0;
540          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
541          $self->{options} ||= $options->{$option};                  my $mask;
542                    unless ($mask = $options->{$option}) {
543                            if ($option eq '1') {
544                                    next;
545                            } else {
546                                    croak "unknown option $option";
547                            }
548                    }
549                    $opt += $mask;
550            }
551            $self->{options} = $opt;
552  }  }
553    
554    
# Line 460  Return search result attrs. Line 591  Return search result attrs.
591  sub attrs {  sub attrs {
592          my $self = shift;          my $self = shift;
593          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
594          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
595  }  }
596    
597    
# Line 496  sub options { Line 627  sub options {
627  }  }
628    
629    
630    =head2 set_skip
631    
632    Set number of skipped documents from beginning of results
633    
634      $cond->set_skip(42);
635    
636    Similar to C<offset> in RDBMS.
637    
638    =cut
639    
640    sub set_skip {
641            my $self = shift;
642            $self->{skip} = shift;
643    }
644    
645    =head2 skip
646    
647    Return skip for this condition.
648    
649      print $cond->skip;
650    
651    =cut
652    
653    sub skip {
654            my $self = shift;
655            return $self->{skip};
656    }
657    
658    
659  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
660    
661  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 684  sub new {
684          my $self = {@_};          my $self = {@_};
685          bless($self, $class);          bless($self, $class);
686    
687          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});  
         }  
688    
689          $self ? return $self : return undef;          $self ? return $self : return undef;
690  }  }
# Line 641  Return number of documents Line 799  Return number of documents
799    
800    print $res->doc_num;    print $res->doc_num;
801    
802    This will return real number of documents (limited by C<max>).
803    If you want to get total number of hits, see C<hits>.
804    
805  =cut  =cut
806    
807  sub doc_num {  sub doc_num {
808          my $self = shift;          my $self = shift;
809          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
810  }  }
811    
812    
# Line 672  sub get_doc { Line 833  sub get_doc {
833    
834  Return specific hint from results.  Return specific hint from results.
835    
836    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
837    
838  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>,
839  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 846  sub hint {
846          return $self->{hints}->{$key};          return $self->{hints}->{$key};
847  }  }
848    
849    =head2 hints
850    
851    More perlish version of C<hint>. This one returns hash.
852    
853      my %hints = $res->hints;
854    
855    =cut
856    
857    sub hints {
858            my $self = shift;
859            return $self->{hints};
860    }
861    
862    =head2 hits
863    
864    Syntaxtic sugar for total number of hits for this query
865    
866      print $res->hits;
867    
868    It's same as
869    
870      print $res->hint('HIT');
871    
872    but shorter.
873    
874    =cut
875    
876    sub hits {
877            my $self = shift;
878            return $self->{hints}->{'HIT'} || 0;
879    }
880    
881  package Search::Estraier::Node;  package Search::Estraier::Node;
882    
# Line 692  use Carp qw/carp croak confess/; Line 884  use Carp qw/carp croak confess/;
884  use URI;  use URI;
885  use MIME::Base64;  use MIME::Base64;
886  use IO::Socket::INET;  use IO::Socket::INET;
887    use URI::Escape qw/uri_escape/;
888    
889  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
890    
# Line 699  use IO::Socket::INET; Line 892  use IO::Socket::INET;
892    
893    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
894    
895    or optionally with C<url> as parametar
896    
897      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
898    
899    or in more verbose form
900    
901      my $node = new Search::HyperEstraier::Node(
902            url => 'http://localhost:1978/node/test',
903            user => 'admin',
904            passwd => 'admin'
905            create => 1,
906            label => 'optional node label',
907            debug => 1,
908            croak_on_error => 1
909      );
910    
911    with following arguments:
912    
913    =over 4
914    
915    =item url
916    
917    URL to node
918    
919    =item user
920    
921    specify username for node server authentication
922    
923    =item passwd
924    
925    password for authentication
926    
927    =item create
928    
929    create node if it doesn't exists
930    
931    =item label
932    
933    optional label for new node if C<create> is used
934    
935    =item debug
936    
937    dumps a B<lot> of debugging output
938    
939    =item croak_on_error
940    
941    very helpful during development. It will croak on all errors instead of
942    silently returning C<-1> (which is convention of Hyper Estraier API in other
943    languages).
944    
945    =back
946    
947  =cut  =cut
948    
949  sub new {  sub new {
# Line 706  sub new { Line 951  sub new {
951          my $self = {          my $self = {
952                  pxport => -1,                  pxport => -1,
953                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
954                  wwidth => 480,                  wwidth => 480,
955                  hwidth => 96,                  hwidth => 96,
956                  awidth => 96,                  awidth => 96,
957                  status => -1,                  status => -1,
958          };          };
959    
960          bless($self, $class);          bless($self, $class);
961    
962          if (@_) {          if ($#_ == 0) {
963                  $self->{debug} = shift;                  $self->{url} = shift;
964                  warn "## Node debug on\n";          } else {
965                    %$self = ( %$self, @_ );
966    
967                    $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
968    
969                    warn "## Node debug on\n" if ($self->{debug});
970            }
971    
972            $self->{inform} = {
973                    dnum => -1,
974                    wnum => -1,
975                    size => -1.0,
976            };
977    
978            if ($self->{create}) {
979                    if (! eval { $self->name } || $@) {
980                            my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
981                            croak "can't find node name in '$self->{url}'" unless ($name);
982                            my $label = $self->{label} || $name;
983                            $self->master(
984                                    action => 'nodeadd',
985                                    name => $name,
986                                    label => $label,
987                            ) || croak "can't create node $name ($label)";
988                    }
989          }          }
990    
991          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 811  Add a document Line 1078  Add a document
1078    
1079    $node->put_doc( $document_draft ) or die "can't add document";    $node->put_doc( $document_draft ) or die "can't add document";
1080    
1081  Return true on success or false on failture.  Return true on success or false on failure.
1082    
1083  =cut  =cut
1084    
# Line 819  sub put_doc { Line 1086  sub put_doc {
1086          my $self = shift;          my $self = shift;
1087          my $doc = shift || return;          my $doc = shift || return;
1088          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1089          $self->shuttle_url( $self->{url} . '/put_doc',          if ($self->shuttle_url( $self->{url} . '/put_doc',
1090                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1091                  $doc->dump_draft,                  $doc->dump_draft,
1092                  undef                  undef
1093          ) == 200;          ) == 200) {
1094                    $self->_clear_info;
1095                    return 1;
1096            }
1097            return undef;
1098  }  }
1099    
1100    
# Line 842  sub out_doc { Line 1113  sub out_doc {
1113          my $id = shift || return;          my $id = shift || return;
1114          return unless ($self->{url});          return unless ($self->{url});
1115          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
1116          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1117                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1118                  "id=$id",                  "id=$id",
1119                  undef                  undef
1120          ) == 200;          ) == 200) {
1121                    $self->_clear_info;
1122                    return 1;
1123            }
1124            return undef;
1125  }  }
1126    
1127    
# Line 864  sub out_doc_by_uri { Line 1139  sub out_doc_by_uri {
1139          my $self = shift;          my $self = shift;
1140          my $uri = shift || return;          my $uri = shift || return;
1141          return unless ($self->{url});          return unless ($self->{url});
1142          $self->shuttle_url( $self->{url} . '/out_doc',          if ($self->shuttle_url( $self->{url} . '/out_doc',
1143                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1144                  "uri=$uri",                  "uri=" . uri_escape($uri),
1145                  undef                  undef
1146          ) == 200;          ) == 200) {
1147                    $self->_clear_info;
1148                    return 1;
1149            }
1150            return undef;
1151  }  }
1152    
1153    
# Line 886  sub edit_doc { Line 1165  sub edit_doc {
1165          my $self = shift;          my $self = shift;
1166          my $doc = shift || return;          my $doc = shift || return;
1167          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));          return unless ($self->{url} && $doc->isa('Search::Estraier::Document'));
1168          $self->shuttle_url( $self->{url} . '/edit_doc',          if ($self->shuttle_url( $self->{url} . '/edit_doc',
1169                  'text/x-estraier-draft',                  'text/x-estraier-draft',
1170                  $doc->dump_draft,                  $doc->dump_draft,
1171                  undef                  undef
1172          ) == 200;          ) == 200) {
1173                    $self->_clear_info;
1174                    return 1;
1175            }
1176            return undef;
1177  }  }
1178    
1179    
# Line 928  sub get_doc_by_uri { Line 1211  sub get_doc_by_uri {
1211  }  }
1212    
1213    
1214    =head2 get_doc_attr
1215    
1216    Retrieve the value of an atribute from object
1217    
1218      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1219            die "can't get document attribute";
1220    
1221    =cut
1222    
1223    sub get_doc_attr {
1224            my $self = shift;
1225            my ($id,$name) = @_;
1226            return unless ($id && $name);
1227            return $self->_fetch_doc( id => $id, attr => $name );
1228    }
1229    
1230    
1231    =head2 get_doc_attr_by_uri
1232    
1233    Retrieve the value of an atribute from object
1234    
1235      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1236            die "can't get document attribute";
1237    
1238    =cut
1239    
1240    sub get_doc_attr_by_uri {
1241            my $self = shift;
1242            my ($uri,$name) = @_;
1243            return unless ($uri && $name);
1244            return $self->_fetch_doc( uri => $uri, attr => $name );
1245    }
1246    
1247    
1248  =head2 etch_doc  =head2 etch_doc
1249    
1250  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1253  Exctract document keywords
1253    
1254  =cut  =cut
1255    
1256  sub erch_doc {  sub etch_doc {
1257          my $self = shift;          my $self = shift;
1258          my $id = shift || return;          my $id = shift || return;
1259          return $self->_fetch_doc( id => $id, etch => 1 );          return $self->_fetch_doc( id => $id, etch => 1 );
# Line 965  Get ID of document specified by URI Line 1282  Get ID of document specified by URI
1282    
1283    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1284    
1285    This method won't croak, even if using C<croak_on_error>.
1286    
1287  =cut  =cut
1288    
1289  sub uri_to_id {  sub uri_to_id {
1290          my $self = shift;          my $self = shift;
1291          my $uri = shift || return;          my $uri = shift || return;
1292          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 );
1293  }  }
1294    
1295    
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1306  C<etch_doc>, C<etch_doc_by_uri>.
1306   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1307   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1308    
1309     # to get document attrubute add attr
1310     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1311     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1312    
1313   # more general form which allows implementation of   # more general form which allows implementation of
1314   # uri_to_id   # uri_to_id
1315   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1334  sub _fetch_doc {
1334                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
1335                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1336          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1337                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1338          } else {          } else {
1339                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1340          }          }
1341    
1342            if ($a->{attr}) {
1343                    $path = '/get_doc_attr';
1344                    $arg .= '&attr=' . uri_escape($a->{attr});
1345                    $a->{chomp_resbody} = 1;
1346            }
1347    
1348          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1349                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1350                  $arg,                  $arg,
1351                  \$resbody,                  \$resbody,
1352                    $a->{croak_on_error},
1353          );          );
1354    
1355          return if ($rv != 200);          return if ($rv != 200);
# Line 1042  sub _fetch_doc { Line 1372  sub _fetch_doc {
1372  }  }
1373    
1374    
1375    =head2 name
1376    
1377      my $node_name = $node->name;
1378    
1379    =cut
1380    
1381    sub name {
1382            my $self = shift;
1383            $self->_set_info unless ($self->{inform}->{name});
1384            return $self->{inform}->{name};
1385    }
1386    
1387    
1388    =head2 label
1389    
1390      my $node_label = $node->label;
1391    
1392    =cut
1393    
1394    sub label {
1395            my $self = shift;
1396            $self->_set_info unless ($self->{inform}->{label});
1397            return $self->{inform}->{label};
1398    }
1399    
1400    
1401    =head2 doc_num
1402    
1403      my $documents_in_node = $node->doc_num;
1404    
1405    =cut
1406    
1407    sub doc_num {
1408            my $self = shift;
1409            $self->_set_info if ($self->{inform}->{dnum} < 0);
1410            return $self->{inform}->{dnum};
1411    }
1412    
1413    
1414    =head2 word_num
1415    
1416      my $words_in_node = $node->word_num;
1417    
1418    =cut
1419    
1420    sub word_num {
1421            my $self = shift;
1422            $self->_set_info if ($self->{inform}->{wnum} < 0);
1423            return $self->{inform}->{wnum};
1424    }
1425    
1426    
1427    =head2 size
1428    
1429      my $node_size = $node->size;
1430    
1431    =cut
1432    
1433    sub size {
1434            my $self = shift;
1435            $self->_set_info if ($self->{inform}->{size} < 0);
1436            return $self->{inform}->{size};
1437    }
1438    
1439    
1440    =head2 search
1441    
1442    Search documents which match condition
1443    
1444      my $nres = $node->search( $cond, $depth );
1445    
1446    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1447    depth for meta search.
1448    
1449    Function results C<Search::Estraier::NodeResult> object.
1450    
1451    =cut
1452    
1453    sub search {
1454            my $self = shift;
1455            my ($cond, $depth) = @_;
1456            return unless ($cond && defined($depth) && $self->{url});
1457            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1458            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1459    
1460            my $resbody;
1461    
1462            my $rv = $self->shuttle_url( $self->{url} . '/search',
1463                    'application/x-www-form-urlencoded',
1464                    $self->cond_to_query( $cond, $depth ),
1465                    \$resbody,
1466            );
1467            return if ($rv != 200);
1468    
1469            my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1470            my $hintsText   = splice @records, 0, 2; # starts with empty record
1471            my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1472    
1473            # process records
1474            my $docs = [];
1475            foreach my $record (@records)
1476            {
1477                    # split into keys and snippets
1478                    my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
1479    
1480                    # create document hash
1481                    my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1482                    $doc->{'@keywords'}     = $doc->{keywords};
1483                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1484                    $doc->{snippet}         = $snippet;
1485    
1486                    push @$docs, new Search::Estraier::ResultDocument(
1487                            attrs           => $doc,
1488                            uri             => $doc->{'@uri'},
1489                            snippet         => $snippet,
1490                            keywords        => $doc->{'keywords'},
1491                    );
1492            }
1493    
1494            return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
1495    }
1496    
1497    
1498    =head2 cond_to_query
1499    
1500    Return URI encoded string generated from Search::Estraier::Condition
1501    
1502      my $args = $node->cond_to_query( $cond, $depth );
1503    
1504    =cut
1505    
1506    sub cond_to_query {
1507            my $self = shift;
1508    
1509            my $cond = shift || return;
1510            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1511            my $depth = shift;
1512    
1513            my @args;
1514    
1515            if (my $phrase = $cond->phrase) {
1516                    push @args, 'phrase=' . uri_escape($phrase);
1517            }
1518    
1519            if (my @attrs = $cond->attrs) {
1520                    for my $i ( 0 .. $#attrs ) {
1521                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1522                    }
1523            }
1524    
1525            if (my $order = $cond->order) {
1526                    push @args, 'order=' . uri_escape($order);
1527            }
1528                    
1529            if (my $max = $cond->max) {
1530                    push @args, 'max=' . $max;
1531            } else {
1532                    push @args, 'max=' . (1 << 30);
1533            }
1534    
1535            if (my $options = $cond->options) {
1536                    push @args, 'options=' . $options;
1537            }
1538    
1539            push @args, 'depth=' . $depth if ($depth);
1540            push @args, 'wwidth=' . $self->{wwidth};
1541            push @args, 'hwidth=' . $self->{hwidth};
1542            push @args, 'awidth=' . $self->{awidth};
1543            push @args, 'skip=' . $cond->{skip} if ($cond->{skip});
1544    
1545            return join('&', @args);
1546    }
1547    
1548    
1549  =head2 shuttle_url  =head2 shuttle_url
1550    
1551  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
1552  master.  master.
1553    
1554    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1555    
1556  C<$resheads> and C<$resbody> booleans controll if response headers and/or response  C<$resheads> and C<$resbody> booleans controll if response headers and/or response
1557  body will be saved within object.  body will be saved within object.
1558    
1559  =cut  =cut
1560    
1561    use LWP::UserAgent;
1562    
1563  sub shuttle_url {  sub shuttle_url {
1564          my $self = shift;          my $self = shift;
1565    
1566          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1567    
1568            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1569    
1570          $self->{status} = -1;          $self->{status} = -1;
1571    
# Line 1074  sub shuttle_url { Line 1580  sub shuttle_url {
1580                  return -1;                  return -1;
1581          }          }
1582    
1583          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1584            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1585    
1586          if ($self->{pxhost}) {          my $req;
1587                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1588                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1589            } else {
1590                    $req = HTTP::Request->new(GET => $url);
1591          }          }
1592    
1593          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1594            $req->headers->header( 'Connection', 'close' );
1595            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1596            $req->content_type( $content_type );
1597    
1598          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1599    
1600          if ($reqbody) {          if ($reqbody) {
1601                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1602          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1603          }          }
1604    
1605          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1606          $headers .= "Connection: close\r\n";  
1607          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1608          $headers .= "Content-Type: $content_type\r\n";  
1609          $headers .= "Authorization: Basic $self->{auth}\r\n";          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1610          my $len = 0;  
1611          {          if (! $res->is_success) {
1612                  use bytes;                  if ($croak_on_error) {
1613                  $len = length($reqbody) if ($reqbody);                          croak("can't get $url: ",$res->status_line);
1614                    } else {
1615                            return -1;
1616                    }
1617            }
1618    
1619            $$resbody .= $res->content;
1620    
1621            warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1622    
1623            return $self->{status};
1624    }
1625    
1626    
1627    =head2 set_snippet_width
1628    
1629    Set width of snippets in results
1630    
1631      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1632    
1633    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1634    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1635    
1636    C<$hwidth> specified width of strings from beginning of string. Default
1637    value is C<96>. Negative or zero value keep previous value.
1638    
1639    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1640    If negative of zero value is provided previous value is kept unchanged.
1641    
1642    =cut
1643    
1644    sub set_snippet_width {
1645            my $self = shift;
1646    
1647            my ($wwidth, $hwidth, $awidth) = @_;
1648            $self->{wwidth} = $wwidth;
1649            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1650            $self->{awidth} = $awidth if ($awidth >= 0);
1651    }
1652    
1653    
1654    =head2 set_user
1655    
1656    Manage users of node
1657    
1658      $node->set_user( 'name', $mode );
1659    
1660    C<$mode> can be one of:
1661    
1662    =over 4
1663    
1664    =item 0
1665    
1666    delete account
1667    
1668    =item 1
1669    
1670    set administrative right for user
1671    
1672    =item 2
1673    
1674    set user account as guest
1675    
1676    =back
1677    
1678    Return true on success, otherwise false.
1679    
1680    =cut
1681    
1682    sub set_user {
1683            my $self = shift;
1684            my ($name, $mode) = @_;
1685    
1686            return unless ($self->{url});
1687            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1688    
1689            $self->shuttle_url( $self->{url} . '/_set_user',
1690                    'application/x-www-form-urlencoded',
1691                    'name=' . uri_escape($name) . '&mode=' . $mode,
1692                    undef
1693            ) == 200;
1694    }
1695    
1696    
1697    =head2 set_link
1698    
1699    Manage node links
1700    
1701      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1702    
1703    If C<$credit> is negative, link is removed.
1704    
1705    =cut
1706    
1707    sub set_link {
1708            my $self = shift;
1709            my ($url, $label, $credit) = @_;
1710    
1711            return unless ($self->{url});
1712            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1713    
1714            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1715            $reqbody .= '&credit=' . $credit if ($credit > 0);
1716    
1717            if ($self->shuttle_url( $self->{url} . '/_set_link',
1718                    'application/x-www-form-urlencoded',
1719                    $reqbody,
1720                    undef
1721            ) == 200) {
1722                    # refresh node info after adding link
1723                    $self->_clear_info;
1724                    return 1;
1725          }          }
1726          $headers .= "Content-Length: $len\r\n";          return undef;
1727          $headers .= "\r\n";  }
1728    
1729    =head2 admins
1730    
1731     my @admins = @{ $node->admins };
1732    
1733    Return array of users with admin rights on node
1734    
1735    =cut
1736    
1737    sub admins {
1738            my $self = shift;
1739            $self->_set_info unless ($self->{inform}->{name});
1740            return $self->{inform}->{admins};
1741    }
1742    
1743    =head2 guests
1744    
1745     my @guests = @{ $node->guests };
1746    
1747    Return array of users with guest rights on node
1748    
1749    =cut
1750    
1751    sub guests {
1752            my $self = shift;
1753            $self->_set_info unless ($self->{inform}->{name});
1754            return $self->{inform}->{guests};
1755    }
1756    
1757    =head2 links
1758    
1759     my $links = @{ $node->links };
1760    
1761    Return array of links for this node
1762    
1763    =cut
1764    
1765    sub links {
1766            my $self = shift;
1767            $self->_set_info unless ($self->{inform}->{name});
1768            return $self->{inform}->{links};
1769    }
1770    
1771    =head2 cacheusage
1772    
1773    Return cache usage for a node
1774    
1775      my $cache = $node->cacheusage;
1776    
1777    =cut
1778    
1779    sub cacheusage {
1780            my $self = shift;
1781    
1782          my $sock = IO::Socket::INET->new(          return unless ($self->{url});
1783                  PeerAddr        => $host,  
1784                  PeerPort        => $port,          my $resbody;
1785                  Proto           => 'tcp',          my $rv = $self->shuttle_url( $self->{url} . '/cacheusage',
1786                  Timeout         => $self->{timeout} || 90,                  'text/plain',
1787                    undef,
1788                    \$resbody,
1789          );          );
1790    
1791          if (! $sock) {          return if ($rv != 200 || !$resbody);
1792                  carp "can't open socket to $host:$port";  
1793                  return -1;          return $resbody;
1794    }
1795    
1796    =head2 master
1797    
1798    Set actions on Hyper Estraier node master (C<estmaster> process)
1799    
1800      $node->master(
1801            action => 'sync'
1802      );
1803    
1804    All available actions are documented in
1805    L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
1806    
1807    =cut
1808    
1809    my $estmaster_rest = {
1810            shutdown => {
1811                    status => 202,
1812            },
1813            sync => {
1814                    status => 202,
1815            },
1816            backup => {
1817                    status => 202,
1818            },
1819            userlist => {
1820                    status => 200,
1821                    returns => [ qw/name passwd flags fname misc/ ],
1822            },
1823            useradd => {
1824                    required => [ qw/name passwd flags/ ],
1825                    optional => [ qw/fname misc/ ],
1826                    status => 200,
1827            },
1828            userdel => {
1829                    required => [ qw/name/ ],
1830                    status => 200,
1831            },
1832            nodelist => {
1833                    status => 200,
1834                    returns => [ qw/name label doc_num word_num size/ ],
1835            },
1836            nodeadd => {
1837                    required => [ qw/name/ ],
1838                    optional => [ qw/label/ ],
1839                    status => 200,
1840            },
1841            nodedel => {
1842                    required => [ qw/name/ ],
1843                    status => 200,
1844            },
1845            nodeclr => {
1846                    required => [ qw/name/ ],
1847                    status => 200,
1848            },
1849            nodertt => {
1850                    status => 200,  
1851            },
1852    };
1853    
1854    sub master {
1855            my $self = shift;
1856    
1857            my $args = {@_};
1858    
1859            # have action?
1860            my $action = $args->{action} || croak "need action, available: ",
1861                    join(", ",keys %{ $estmaster_rest });
1862    
1863            # check if action is valid
1864            my $rest = $estmaster_rest->{$action};
1865            croak "action '$action' is not supported, available actions: ",
1866                    join(", ",keys %{ $estmaster_rest }) unless ($rest);
1867    
1868            croak "BUG: action '$action' needs return status" unless ($rest->{status});
1869    
1870            my @args;
1871    
1872            if ($rest->{required} || $rest->{optional}) {
1873    
1874                    map {
1875                            croak "need parametar '$_' for action '$action'" unless ($args->{$_});
1876                            push @args, $_ . '=' . uri_escape( $args->{$_} );
1877                    } ( @{ $rest->{required} } );
1878    
1879                    map {
1880                            push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
1881                    } ( @{ $rest->{optional} } );
1882    
1883          }          }
1884    
1885          warn $headers if ($self->{debug});          my $uri = new URI( $self->{url} );
1886    
1887          print $sock $headers or          my $resbody;
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1888    
1889          if ($reqbody) {          my $status = $self->shuttle_url(
1890                  warn "$reqbody\n" if ($self->{debug});                  'http://' . $uri->host_port . '/master?action=' . $action ,
1891                  print $sock $reqbody or                  'application/x-www-form-urlencoded',
1892                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  join('&', @args),
1893                    \$resbody,
1894                    1,
1895            ) or confess "shuttle_url failed";
1896    
1897            if ($status == $rest->{status}) {
1898    
1899                    # refresh node info after sync
1900                    $self->_clear_info if ($action eq 'sync' || $action =~ m/^node(?:add|del|clr)$/);
1901    
1902                    if ($rest->{returns} && wantarray) {
1903    
1904                            my @results;
1905                            my $fields = $#{$rest->{returns}};
1906    
1907                            foreach my $line ( split(/[\r\n]/,$resbody) ) {
1908                                    my @e = split(/\t/, $line, $fields + 1);
1909                                    my $row;
1910                                    foreach my $i ( 0 .. $fields) {
1911                                            $row->{ $rest->{returns}->[$i] } = $e[ $i ];
1912                                    }
1913                                    push @results, $row;
1914                            }
1915    
1916                            return @results;
1917    
1918                    } elsif ($resbody) {
1919                            chomp $resbody;
1920                            return $resbody;
1921                    } else {
1922                            return 0E0;
1923                    }
1924          }          }
1925    
1926          my $line = <$sock>;          carp "expected status $rest->{status}, but got $status";
1927          chomp($line);          return undef;
1928          my ($schema, $res_status, undef) = split(/  */, $line, 3);  }
         return if ($schema !~ /^HTTP/ || ! $res_status);  
   
         $self->{status} = $res_status;  
         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});  
         };  
1929    
1930          # read body  =head1 PRIVATE METHODS
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1931    
1932          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});  You could call those directly, but you don't have to. I hope.
1933    
1934          return $self->{status};  =head2 _set_info
1935    
1936    Set information for node
1937    
1938      $node->_set_info;
1939    
1940    =cut
1941    
1942    sub _set_info {
1943            my $self = shift;
1944    
1945            $self->{status} = -1;
1946            return unless ($self->{url});
1947    
1948            my $resbody;
1949            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1950                    'text/plain',
1951                    undef,
1952                    \$resbody,
1953            );
1954    
1955            return if ($rv != 200 || !$resbody);
1956    
1957            my @lines = split(/[\r\n]/,$resbody);
1958    
1959            $self->_clear_info;
1960    
1961            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1962                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1963    
1964            return $resbody unless (@lines);
1965    
1966            shift @lines;
1967    
1968            while(my $admin = shift @lines) {
1969                    push @{$self->{inform}->{admins}}, $admin;
1970            }
1971    
1972            while(my $guest = shift @lines) {
1973                    push @{$self->{inform}->{guests}}, $guest;
1974            }
1975    
1976            while(my $link = shift @lines) {
1977                    push @{$self->{inform}->{links}}, $link;
1978            }
1979    
1980            return $resbody;
1981    
1982    }
1983    
1984    =head2 _clear_info
1985    
1986    Clear information for node
1987    
1988      $node->_clear_info;
1989    
1990    On next call to C<name>, C<label>, C<doc_num>, C<word_num> or C<size> node
1991    info will be fetch again from Hyper Estraier.
1992    
1993    =cut
1994    sub _clear_info {
1995            my $self = shift;
1996            $self->{inform} = {
1997                    dnum => -1,
1998                    wnum => -1,
1999                    size => -1.0,
2000            };
2001  }  }
2002    
2003  ###  ###
# Line 1167  L<http://hyperestraier.sourceforge.net/> Line 2012  L<http://hyperestraier.sourceforge.net/>
2012    
2013  Hyper Estraier Ruby interface on which this module is based.  Hyper Estraier Ruby interface on which this module is based.
2014    
2015    Hyper Estraier now also has pure-perl binding included in distribution. It's
2016    a faster way to access databases directly if you are not running
2017    C<estmaster> P2P server.
2018    
2019  =head1 AUTHOR  =head1 AUTHOR
2020    
2021  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
2022    
2023    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
2024    
2025  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
2026    
Legend:
Removed from v.47  
changed lines
  Added in v.164
  ViewVC Help
Powered by ViewVC 1.1.26