/[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 48 by dpavlin, Fri Jan 6 02:07:10 2006 UTC revision 111 by dpavlin, Tue Feb 21 15:41:57 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.04_3';
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 524  sub new { Line 627  sub new {
627          my $self = {@_};          my $self = {@_};
628          bless($self, $class);          bless($self, $class);
629    
630          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});  
         }  
631    
632          $self ? return $self : return undef;          $self ? return $self : return undef;
633  }  }
# Line 641  Return number of documents Line 742  Return number of documents
742    
743    print $res->doc_num;    print $res->doc_num;
744    
745    This will return real number of documents (limited by C<max>).
746    If you want to get total number of hits, see C<hits>.
747    
748  =cut  =cut
749    
750  sub doc_num {  sub doc_num {
751          my $self = shift;          my $self = shift;
752          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
753  }  }
754    
755    
# Line 672  sub get_doc { Line 776  sub get_doc {
776    
777  Return specific hint from results.  Return specific hint from results.
778    
779    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
780    
781  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>,
782  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 789  sub hint {
789          return $self->{hints}->{$key};          return $self->{hints}->{$key};
790  }  }
791    
792    =head2 hints
793    
794    More perlish version of C<hint>. This one returns hash.
795    
796      my %hints = $res->hints;
797    
798    =cut
799    
800    sub hints {
801            my $self = shift;
802            return $self->{hints};
803    }
804    
805    =head2 hits
806    
807    Syntaxtic sugar for total number of hits for this query
808    
809      print $res->hits;
810    
811    It's same as
812    
813      print $res->hint('HIT');
814    
815    but shorter.
816    
817    =cut
818    
819    sub hits {
820            my $self = shift;
821            return $self->{hints}->{'HIT'} || 0;
822    }
823    
824  package Search::Estraier::Node;  package Search::Estraier::Node;
825    
# Line 692  use Carp qw/carp croak confess/; Line 827  use Carp qw/carp croak confess/;
827  use URI;  use URI;
828  use MIME::Base64;  use MIME::Base64;
829  use IO::Socket::INET;  use IO::Socket::INET;
830    use URI::Escape qw/uri_escape/;
831    
832  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
833    
# Line 699  use IO::Socket::INET; Line 835  use IO::Socket::INET;
835    
836    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
837    
838    or optionally with C<url> as parametar
839    
840      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
841    
842    or in more verbose form
843    
844      my $node = new Search::HyperEstraier::Node(
845            url => 'http://localhost:1978/node/test',
846            debug => 1,
847            croak_on_error => 1
848      );
849    
850    with following arguments:
851    
852    =over 4
853    
854    =item url
855    
856    URL to node
857    
858    =item debug
859    
860    dumps a B<lot> of debugging output
861    
862    =item croak_on_error
863    
864    very helpful during development. It will croak on all errors instead of
865    silently returning C<-1> (which is convention of Hyper Estraier API in other
866    languages).
867    
868    =back
869    
870  =cut  =cut
871    
872  sub new {  sub new {
# Line 706  sub new { Line 874  sub new {
874          my $self = {          my $self = {
875                  pxport => -1,                  pxport => -1,
876                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
877                  wwidth => 480,                  wwidth => 480,
878                  hwidth => 96,                  hwidth => 96,
879                  awidth => 96,                  awidth => 96,
880                  status => -1,                  status => -1,
881          };          };
882    
883          bless($self, $class);          bless($self, $class);
884    
885          if (@_) {          if ($#_ == 0) {
886                  $self->{debug} = shift;                  $self->{url} = shift;
887                  warn "## Node debug on\n";          } else {
888                    my $args = {@_};
889    
890                    %$self = ( %$self, @_ );
891    
892                    warn "## Node debug on\n" if ($self->{debug});
893          }          }
894    
895            $self->{inform} = {
896                    dnum => -1,
897                    wnum => -1,
898                    size => -1.0,
899            };
900    
901          $self ? return $self : return undef;          $self ? return $self : return undef;
902  }  }
903    
# Line 866  sub out_doc_by_uri { Line 1043  sub out_doc_by_uri {
1043          return unless ($self->{url});          return unless ($self->{url});
1044          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1045                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1046                  "uri=$uri",                  "uri=" . uri_escape($uri),
1047                  undef                  undef
1048          ) == 200;          ) == 200;
1049  }  }
# Line 928  sub get_doc_by_uri { Line 1105  sub get_doc_by_uri {
1105  }  }
1106    
1107    
1108    =head2 get_doc_attr
1109    
1110    Retrieve the value of an atribute from object
1111    
1112      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1113            die "can't get document attribute";
1114    
1115    =cut
1116    
1117    sub get_doc_attr {
1118            my $self = shift;
1119            my ($id,$name) = @_;
1120            return unless ($id && $name);
1121            return $self->_fetch_doc( id => $id, attr => $name );
1122    }
1123    
1124    
1125    =head2 get_doc_attr_by_uri
1126    
1127    Retrieve the value of an atribute from object
1128    
1129      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1130            die "can't get document attribute";
1131    
1132    =cut
1133    
1134    sub get_doc_attr_by_uri {
1135            my $self = shift;
1136            my ($uri,$name) = @_;
1137            return unless ($uri && $name);
1138            return $self->_fetch_doc( uri => $uri, attr => $name );
1139    }
1140    
1141    
1142  =head2 etch_doc  =head2 etch_doc
1143    
1144  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1147  Exctract document keywords
1147    
1148  =cut  =cut
1149    
1150  sub erch_doc {  sub etch_doc {
1151          my $self = shift;          my $self = shift;
1152          my $id = shift || return;          my $id = shift || return;
1153          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 1176  Get ID of document specified by URI
1176    
1177    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1178    
1179    This method won't croak, even if using C<croak_on_error>.
1180    
1181  =cut  =cut
1182    
1183  sub uri_to_id {  sub uri_to_id {
1184          my $self = shift;          my $self = shift;
1185          my $uri = shift || return;          my $uri = shift || return;
1186          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 );
1187  }  }
1188    
1189    
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1200  C<etch_doc>, C<etch_doc_by_uri>.
1200   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1201   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1202    
1203     # to get document attrubute add attr
1204     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1205     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1206    
1207   # more general form which allows implementation of   # more general form which allows implementation of
1208   # uri_to_id   # uri_to_id
1209   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1228  sub _fetch_doc {
1228                  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+$/);
1229                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1230          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1231                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1232          } else {          } else {
1233                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1234          }          }
1235    
1236            if ($a->{attr}) {
1237                    $path = '/get_doc_attr';
1238                    $arg .= '&attr=' . uri_escape($a->{attr});
1239                    $a->{chomp_resbody} = 1;
1240            }
1241    
1242          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1243                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1244                  $arg,                  $arg,
1245                  \$resbody,                  \$resbody,
1246                    $a->{croak_on_error},
1247          );          );
1248    
1249          return if ($rv != 200);          return if ($rv != 200);
# Line 1050  sub _fetch_doc { Line 1274  sub _fetch_doc {
1274    
1275  sub name {  sub name {
1276          my $self = shift;          my $self = shift;
1277          $self->set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1278          return $self->{name};          return $self->{inform}->{name};
1279  }  }
1280    
1281    
# Line 1063  sub name { Line 1287  sub name {
1287    
1288  sub label {  sub label {
1289          my $self = shift;          my $self = shift;
1290          $self->set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1291          return $self->{label};          return $self->{inform}->{label};
1292  }  }
1293    
1294    
# Line 1076  sub label { Line 1300  sub label {
1300    
1301  sub doc_num {  sub doc_num {
1302          my $self = shift;          my $self = shift;
1303          $self->set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1304          return $self->{dnum};          return $self->{inform}->{dnum};
1305  }  }
1306    
1307    
# Line 1089  sub doc_num { Line 1313  sub doc_num {
1313    
1314  sub word_num {  sub word_num {
1315          my $self = shift;          my $self = shift;
1316          $self->set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1317          return $self->{wnum};          return $self->{inform}->{wnum};
1318  }  }
1319    
1320    
# Line 1102  sub word_num { Line 1326  sub word_num {
1326    
1327  sub size {  sub size {
1328          my $self = shift;          my $self = shift;
1329          $self->set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1330          return $self->{size};          return $self->{inform}->{size};
1331    }
1332    
1333    
1334    =head2 search
1335    
1336    Search documents which match condition
1337    
1338      my $nres = $node->search( $cond, $depth );
1339    
1340    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1341    depth for meta search.
1342    
1343    Function results C<Search::Estraier::NodeResult> object.
1344    
1345    =cut
1346    
1347    sub search {
1348            my $self = shift;
1349            my ($cond, $depth) = @_;
1350            return unless ($cond && defined($depth) && $self->{url});
1351            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1352            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1353    
1354            my $resbody;
1355    
1356            my $rv = $self->shuttle_url( $self->{url} . '/search',
1357                    'application/x-www-form-urlencoded',
1358                    $self->cond_to_query( $cond, $depth ),
1359                    \$resbody,
1360            );
1361            return if ($rv != 200);
1362    
1363            my (@docs, $hints);
1364    
1365            my @lines = split(/\n/, $resbody);
1366            return unless (@lines);
1367    
1368            my $border = $lines[0];
1369            my $isend = 0;
1370            my $lnum = 1;
1371    
1372            while ( $lnum <= $#lines ) {
1373                    my $line = $lines[$lnum];
1374                    $lnum++;
1375    
1376                    #warn "## $line\n";
1377                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1378                            $isend = $1;
1379                            last;
1380                    }
1381    
1382                    if ($line =~ /\t/) {
1383                            my ($k,$v) = split(/\t/, $line, 2);
1384                            $hints->{$k} = $v;
1385                    }
1386            }
1387    
1388            my $snum = $lnum;
1389    
1390            while( ! $isend && $lnum <= $#lines ) {
1391                    my $line = $lines[$lnum];
1392                    #warn "# $lnum: $line\n";
1393                    $lnum++;
1394    
1395                    if ($line && $line =~ m/^\Q$border\E/) {
1396                            if ($lnum > $snum) {
1397                                    my $rdattrs;
1398                                    my $rdvector;
1399                                    my $rdsnippet;
1400                                    
1401                                    my $rlnum = $snum;
1402                                    while ($rlnum < $lnum - 1 ) {
1403                                            #my $rdline = $self->_s($lines[$rlnum]);
1404                                            my $rdline = $lines[$rlnum];
1405                                            $rlnum++;
1406                                            last unless ($rdline);
1407                                            if ($rdline =~ /^%/) {
1408                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1409                                            } elsif($rdline =~ /=/) {
1410                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1411                                            } else {
1412                                                    confess "invalid format of response";
1413                                            }
1414                                    }
1415                                    while($rlnum < $lnum - 1) {
1416                                            my $rdline = $lines[$rlnum];
1417                                            $rlnum++;
1418                                            $rdsnippet .= "$rdline\n";
1419                                    }
1420                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1421                                    if (my $rduri = $rdattrs->{'@uri'}) {
1422                                            push @docs, new Search::Estraier::ResultDocument(
1423                                                    uri => $rduri,
1424                                                    attrs => $rdattrs,
1425                                                    snippet => $rdsnippet,
1426                                                    keywords => $rdvector,
1427                                            );
1428                                    }
1429                            }
1430                            $snum = $lnum;
1431                            #warn "### $line\n";
1432                            $isend = 1 if ($line =~ /:END$/);
1433                    }
1434    
1435            }
1436    
1437            if (! $isend) {
1438                    warn "received result doesn't have :END\n$resbody";
1439                    return;
1440            }
1441    
1442            #warn Dumper(\@docs, $hints);
1443    
1444            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1445  }  }
1446    
1447    
1448    =head2 cond_to_query
1449    
1450    Return URI encoded string generated from Search::Estraier::Condition
1451    
1452      my $args = $node->cond_to_query( $cond, $depth );
1453    
1454    =cut
1455    
1456    sub cond_to_query {
1457            my $self = shift;
1458    
1459            my $cond = shift || return;
1460            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1461            my $depth = shift;
1462    
1463            my @args;
1464    
1465            if (my $phrase = $cond->phrase) {
1466                    push @args, 'phrase=' . uri_escape($phrase);
1467            }
1468    
1469            if (my @attrs = $cond->attrs) {
1470                    for my $i ( 0 .. $#attrs ) {
1471                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1472                    }
1473            }
1474    
1475            if (my $order = $cond->order) {
1476                    push @args, 'order=' . uri_escape($order);
1477            }
1478                    
1479            if (my $max = $cond->max) {
1480                    push @args, 'max=' . $max;
1481            } else {
1482                    push @args, 'max=' . (1 << 30);
1483            }
1484    
1485            if (my $options = $cond->options) {
1486                    push @args, 'options=' . $options;
1487            }
1488    
1489            push @args, 'depth=' . $depth if ($depth);
1490            push @args, 'wwidth=' . $self->{wwidth};
1491            push @args, 'hwidth=' . $self->{hwidth};
1492            push @args, 'awidth=' . $self->{awidth};
1493    
1494            return join('&', @args);
1495    }
1496    
1497    
1498  =head2 shuttle_url  =head2 shuttle_url
1499    
1500  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
1501  master.  master.
1502    
1503    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1504    
1505  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
1506  body will be saved within object.  body will be saved within object.
1507    
1508  =cut  =cut
1509    
1510    use LWP::UserAgent;
1511    
1512  sub shuttle_url {  sub shuttle_url {
1513          my $self = shift;          my $self = shift;
1514    
1515          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1516    
1517            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1518    
1519          $self->{status} = -1;          $self->{status} = -1;
1520    
# Line 1138  sub shuttle_url { Line 1529  sub shuttle_url {
1529                  return -1;                  return -1;
1530          }          }
1531    
1532          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1533            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1534    
1535          if ($self->{pxhost}) {          my $req;
1536                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1537                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1538            } else {
1539                    $req = HTTP::Request->new(GET => $url);
1540          }          }
1541    
1542          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1543            $req->headers->header( 'Connection', 'close' );
1544            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1545            $req->content_type( $content_type );
1546    
1547          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1548    
1549          if ($reqbody) {          if ($reqbody) {
1550                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1551          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1552          }          }
1553    
1554          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
         $headers .= "Connection: close\r\n";  
         $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";  
         $headers .= "Content-Type: $content_type\r\n";  
         $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";  
   
         my $sock = IO::Socket::INET->new(  
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1555    
1556          if (! $sock) {          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1557                  carp "can't open socket to $host:$port";  
1558                  return -1;          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1559    
1560            if (! $res->is_success) {
1561                    if ($croak_on_error) {
1562                            croak("can't get $url: ",$res->status_line);
1563                    } else {
1564                            return -1;
1565                    }
1566          }          }
1567    
1568          warn $headers if ($self->{debug});          $$resbody .= $res->content;
1569    
1570          print $sock $headers or          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1571    
1572          if ($reqbody) {          return $self->{status};
1573                  warn "$reqbody\n" if ($self->{debug});  }
1574                  print $sock $reqbody or  
1575                          carp "can't send request body to network:\n$$reqbody\n" and return -1;  
1576    =head2 set_snippet_width
1577    
1578    Set width of snippets in results
1579    
1580      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1581    
1582    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1583    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1584    
1585    C<$hwidth> specified width of strings from beginning of string. Default
1586    value is C<96>. Negative or zero value keep previous value.
1587    
1588    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1589    If negative of zero value is provided previous value is kept unchanged.
1590    
1591    =cut
1592    
1593    sub set_snippet_width {
1594            my $self = shift;
1595    
1596            my ($wwidth, $hwidth, $awidth) = @_;
1597            $self->{wwidth} = $wwidth;
1598            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1599            $self->{awidth} = $awidth if ($awidth >= 0);
1600    }
1601    
1602    
1603    =head2 set_user
1604    
1605    Manage users of node
1606    
1607      $node->set_user( 'name', $mode );
1608    
1609    C<$mode> can be one of:
1610    
1611    =over 4
1612    
1613    =item 0
1614    
1615    delete account
1616    
1617    =item 1
1618    
1619    set administrative right for user
1620    
1621    =item 2
1622    
1623    set user account as guest
1624    
1625    =back
1626    
1627    Return true on success, otherwise false.
1628    
1629    =cut
1630    
1631    sub set_user {
1632            my $self = shift;
1633            my ($name, $mode) = @_;
1634    
1635            return unless ($self->{url});
1636            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1637    
1638            $self->shuttle_url( $self->{url} . '/_set_user',
1639                    'text/plain',
1640                    'name=' . uri_escape($name) . '&mode=' . $mode,
1641                    undef
1642            ) == 200;
1643    }
1644    
1645    
1646    =head2 set_link
1647    
1648    Manage node links
1649    
1650      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1651    
1652    If C<$credit> is negative, link is removed.
1653    
1654    =cut
1655    
1656    sub set_link {
1657            my $self = shift;
1658            my ($url, $label, $credit) = @_;
1659    
1660            return unless ($self->{url});
1661            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1662    
1663            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1664            $reqbody .= '&credit=' . $credit if ($credit > 0);
1665    
1666            if ($self->shuttle_url( $self->{url} . '/_set_link',
1667                    'application/x-www-form-urlencoded',
1668                    $reqbody,
1669                    undef
1670            ) == 200) {
1671                    # refresh node info after adding link
1672                    $self->_set_info;
1673                    return 1;
1674          }          }
1675    }
1676    
1677          my $line = <$sock>;  =head2 admins
         chomp($line);  
         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});  
         };  
1678    
1679          # read body   my @admins = @{ $node->admins };
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1680    
1681          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});  Return array of users with admin rights on node
1682    
1683          return $self->{status};  =cut
1684    
1685    sub admins {
1686            my $self = shift;
1687            $self->_set_info unless ($self->{inform}->{name});
1688            return $self->{inform}->{admins};
1689    }
1690    
1691    =head2 guests
1692    
1693     my @guests = @{ $node->guests };
1694    
1695    Return array of users with guest rights on node
1696    
1697    =cut
1698    
1699    sub guests {
1700            my $self = shift;
1701            $self->_set_info unless ($self->{inform}->{name});
1702            return $self->{inform}->{guests};
1703  }  }
1704    
1705    =head2 links
1706    
1707     my $links = @{ $node->links };
1708    
1709  =head2 set_info  Return array of links for this node
1710    
1711    =cut
1712    
1713    sub links {
1714            my $self = shift;
1715            $self->_set_info unless ($self->{inform}->{name});
1716            return $self->{inform}->{links};
1717    }
1718    
1719    
1720    =head1 PRIVATE METHODS
1721    
1722    You could call those directly, but you don't have to. I hope.
1723    
1724    =head2 _set_info
1725    
1726  Set information for node  Set information for node
1727    
1728    $node->set_info;    $node->_set_info;
1729    
1730  =cut  =cut
1731    
1732  sub set_info {  sub _set_info {
1733          my $self = shift;          my $self = shift;
1734    
1735          $self->{status} = -1;          $self->{status} = -1;
# Line 1243  sub set_info { Line 1744  sub set_info {
1744    
1745          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1746    
1747          chomp($resbody);          my @lines = split(/[\r\n]/,$resbody);
1748    
1749            $self->{inform} = {};
1750    
1751            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1752                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1753    
1754            return $resbody unless (@lines);
1755    
1756            shift @lines;
1757    
1758            while(my $admin = shift @lines) {
1759                    push @{$self->{inform}->{admins}}, $admin;
1760            }
1761    
1762            while(my $guest = shift @lines) {
1763                    push @{$self->{inform}->{guests}}, $guest;
1764            }
1765    
1766            while(my $link = shift @lines) {
1767                    push @{$self->{inform}->{links}}, $link;
1768            }
1769    
1770          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          return $resbody;
                 split(/\t/, $resbody, 5);  
1771    
1772  }  }
1773    
Legend:
Removed from v.48  
changed lines
  Added in v.111
  ViewVC Help
Powered by ViewVC 1.1.26