/[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 102 by dpavlin, Sat Jan 28 19:46:20 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_1';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node(
21                    url => 'http://localhost:1978/node/test',
22                    user => 'admin',
23                    passwd => 'admin'
24            );
25    
26            # create document
27            my $doc = new Search::Estraier::Document;
28    
29            # add attributes
30            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
31            $doc->add_attr('@title', "Over the Rainbow");
32    
33            # add body text to document
34            $doc->add_text("Somewhere over the rainbow.  Way up high.");
35            $doc->add_text("There's a land that I heard of once in a lullaby.");
36    
37            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
38    
39    =head2 Simple searcher
40    
41            use Search::Estraier;
42    
43            # create and configure node
44            my $node = new Search::Estraier::Node(
45                    url => 'http://localhost:1978/node/test',
46                    user => 'admin',
47                    passwd => 'admin',
48                    croak_on_error => 1,
49            );
50    
51            # create condition
52            my $cond = new Search::Estraier::Condition;
53    
54            # set search phrase
55            $cond->set_phrase("rainbow AND lullaby");
56    
57            my $nres = $node->search($cond, 0);
58    
59            if (defined($nres)) {
60                    print "Got ", $nres->hits, " results\n";
61    
62                    # for each document in results
63                    for my $i ( 0 ... $nres->doc_num - 1 ) {
64                            # get result document
65                            my $rdoc = $nres->get_doc($i);
66                            # display attribte
67                            print "URI: ", $rdoc->attr('@uri'),"\n";
68                            print "Title: ", $rdoc->attr('@title'),"\n";
69                            print $rdoc->snippet,"\n";
70                    }
71            } else {
72                    die "error: ", $node->status,"\n";
73            }
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 25  or Hyper Estraier development files on t Line 82  or Hyper Estraier development files on t
82  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
83  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
84    
85    There are few examples in C<scripts> directory of this distribution.
86    
87  =cut  =cut
88    
89  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 100  Remove multiple whitespaces from string,
100  =cut  =cut
101    
102  sub _s {  sub _s {
103          my $text = $_[1] || return;          my $text = $_[1];
104            return unless defined($text);
105          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
106          $text =~ s/^\s+//;          $text =~ s/^\s+//;
107          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 166  sub new {
166                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
167                                  $in_text = 1;                                  $in_text = 1;
168                                  next;                                  next;
169                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
170                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
171                                  next;                                  next;
172                          }                          }
173    
174                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
175                  }                  }
176          }          }
177    
# Line 205  Returns array with attribute names from Line 265  Returns array with attribute names from
265    
266  sub attr_names {  sub attr_names {
267          my $self = shift;          my $self = shift;
268          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
269            #croak "attr_names return array, not scalar" if (! wantarray);
270          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
271  }  }
272    
# Line 221  Returns value of an attribute. Line 282  Returns value of an attribute.
282  sub attr {  sub attr {
283          my $self = shift;          my $self = shift;
284          my $name = shift;          my $name = shift;
285            return unless (defined($name) && $self->{attrs});
286          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
287  }  }
288    
289    
# Line 236  Returns array with text sentences. Line 297  Returns array with text sentences.
297    
298  sub texts {  sub texts {
299          my $self = shift;          my $self = shift;
300          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
301          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
302  }  }
303    
304    
# Line 251  Return whole text as single scalar. Line 312  Return whole text as single scalar.
312    
313  sub cat_texts {  sub cat_texts {
314          my $self = shift;          my $self = shift;
315          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
316  }  }
317    
318    
# Line 268  sub dump_draft { Line 329  sub dump_draft {
329          my $draft;          my $draft;
330    
331          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
332                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
333                    $draft .= $attr_name . '=' . $v . "\n";
334          }          }
335    
336          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 378  sub delete {
378    
379  package Search::Estraier::Condition;  package Search::Estraier::Condition;
380    
381  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
382    
383  use Search::Estraier;  use Search::Estraier;
384  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 456  sub set_max {
456    
457  =head2 set_options  =head2 set_options
458    
459    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
460    
461      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
462    
463    Possible options are:
464    
465    =over 8
466    
467    =item SURE
468    
469    check every N-gram
470    
471    =item USUAL
472    
473    check every second N-gram
474    
475    =item FAST
476    
477    check every third N-gram
478    
479    =item AGITO
480    
481    check every fourth N-gram
482    
483    =item NOIDF
484    
485    don't perform TF-IDF tuning
486    
487    =item SIMPLE
488    
489    use simplified query phrase
490    
491    =back
492    
493    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
494    options;
495    
496    This option changed in version C<0.04> of this module. It's backwards compatibile.
497    
498  =cut  =cut
499    
500  my $options = {  my $options = {
         # check N-gram keys skipping by three  
501          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
502          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
503          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
504          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
505          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
506          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
507  };  };
508    
509  sub set_options {  sub set_options {
510          my $self = shift;          my $self = shift;
511          my $option = shift;          my $opt = 0;
512          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
513          $self->{options} ||= $options->{$option};                  my $mask;
514                    unless ($mask = $options->{$option}) {
515                            if ($option eq '1') {
516                                    next;
517                            } else {
518                                    croak "unknown option $option";
519                            }
520                    }
521                    $opt += $mask;
522            }
523            $self->{options} = $opt;
524  }  }
525    
526    
# Line 460  Return search result attrs. Line 563  Return search result attrs.
563  sub attrs {  sub attrs {
564          my $self = shift;          my $self = shift;
565          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
566          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
567  }  }
568    
569    
# Line 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 hits
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 716  sub new { Line 884  sub new {
884          };          };
885          bless($self, $class);          bless($self, $class);
886    
887          if (@_) {          if ($#_ == 0) {
888                  $self->{debug} = shift;                  $self->{url} = shift;
889                  warn "## Node debug on\n";          } else {
890                    my $args = {@_};
891    
892                    %$self = ( %$self, @_ );
893    
894                    warn "## Node debug on\n" if ($self->{debug});
895          }          }
896    
897          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 1039  sub out_doc_by_uri {
1039          return unless ($self->{url});          return unless ($self->{url});
1040          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1041                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1042                  "uri=$uri",                  "uri=" . uri_escape($uri),
1043                  undef                  undef
1044          ) == 200;          ) == 200;
1045  }  }
# Line 928  sub get_doc_by_uri { Line 1101  sub get_doc_by_uri {
1101  }  }
1102    
1103    
1104    =head2 get_doc_attr
1105    
1106    Retrieve the value of an atribute from object
1107    
1108      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1109            die "can't get document attribute";
1110    
1111    =cut
1112    
1113    sub get_doc_attr {
1114            my $self = shift;
1115            my ($id,$name) = @_;
1116            return unless ($id && $name);
1117            return $self->_fetch_doc( id => $id, attr => $name );
1118    }
1119    
1120    
1121    =head2 get_doc_attr_by_uri
1122    
1123    Retrieve the value of an atribute from object
1124    
1125      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1126            die "can't get document attribute";
1127    
1128    =cut
1129    
1130    sub get_doc_attr_by_uri {
1131            my $self = shift;
1132            my ($uri,$name) = @_;
1133            return unless ($uri && $name);
1134            return $self->_fetch_doc( uri => $uri, attr => $name );
1135    }
1136    
1137    
1138  =head2 etch_doc  =head2 etch_doc
1139    
1140  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1143  Exctract document keywords
1143    
1144  =cut  =cut
1145    
1146  sub erch_doc {  sub etch_doc {
1147          my $self = shift;          my $self = shift;
1148          my $id = shift || return;          my $id = shift || return;
1149          return $self->_fetch_doc( id => $id, etch => 1 );          return $self->_fetch_doc( id => $id, etch => 1 );
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1194  C<etch_doc>, C<etch_doc_by_uri>.
1194   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1195   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1196    
1197     # to get document attrubute add attr
1198     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1199     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1200    
1201   # more general form which allows implementation of   # more general form which allows implementation of
1202   # uri_to_id   # uri_to_id
1203   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1222  sub _fetch_doc {
1222                  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+$/);
1223                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1224          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1225                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1226          } else {          } else {
1227                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1228          }          }
1229    
1230            if ($a->{attr}) {
1231                    $path = '/get_doc_attr';
1232                    $arg .= '&attr=' . uri_escape($a->{attr});
1233                    $a->{chomp_resbody} = 1;
1234            }
1235    
1236          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1237                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1238                  $arg,                  $arg,
# Line 1042  sub _fetch_doc { Line 1259  sub _fetch_doc {
1259  }  }
1260    
1261    
1262    =head2 name
1263    
1264      my $node_name = $node->name;
1265    
1266    =cut
1267    
1268    sub name {
1269            my $self = shift;
1270            $self->_set_info unless ($self->{name});
1271            return $self->{name};
1272    }
1273    
1274    
1275    =head2 label
1276    
1277      my $node_label = $node->label;
1278    
1279    =cut
1280    
1281    sub label {
1282            my $self = shift;
1283            $self->_set_info unless ($self->{label});
1284            return $self->{label};
1285    }
1286    
1287    
1288    =head2 doc_num
1289    
1290      my $documents_in_node = $node->doc_num;
1291    
1292    =cut
1293    
1294    sub doc_num {
1295            my $self = shift;
1296            $self->_set_info if ($self->{dnum} < 0);
1297            return $self->{dnum};
1298    }
1299    
1300    
1301    =head2 word_num
1302    
1303      my $words_in_node = $node->word_num;
1304    
1305    =cut
1306    
1307    sub word_num {
1308            my $self = shift;
1309            $self->_set_info if ($self->{wnum} < 0);
1310            return $self->{wnum};
1311    }
1312    
1313    
1314    =head2 size
1315    
1316      my $node_size = $node->size;
1317    
1318    =cut
1319    
1320    sub size {
1321            my $self = shift;
1322            $self->_set_info if ($self->{size} < 0);
1323            return $self->{size};
1324    }
1325    
1326    
1327    =head2 search
1328    
1329    Search documents which match condition
1330    
1331      my $nres = $node->search( $cond, $depth );
1332    
1333    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1334    depth for meta search.
1335    
1336    Function results C<Search::Estraier::NodeResult> object.
1337    
1338    =cut
1339    
1340    sub search {
1341            my $self = shift;
1342            my ($cond, $depth) = @_;
1343            return unless ($cond && defined($depth) && $self->{url});
1344            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1345            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1346    
1347            my $resbody;
1348    
1349            my $rv = $self->shuttle_url( $self->{url} . '/search',
1350                    'application/x-www-form-urlencoded',
1351                    $self->cond_to_query( $cond, $depth ),
1352                    \$resbody,
1353            );
1354            return if ($rv != 200);
1355    
1356            my (@docs, $hints);
1357    
1358            my @lines = split(/\n/, $resbody);
1359            return unless (@lines);
1360    
1361            my $border = $lines[0];
1362            my $isend = 0;
1363            my $lnum = 1;
1364    
1365            while ( $lnum <= $#lines ) {
1366                    my $line = $lines[$lnum];
1367                    $lnum++;
1368    
1369                    #warn "## $line\n";
1370                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1371                            $isend = $1;
1372                            last;
1373                    }
1374    
1375                    if ($line =~ /\t/) {
1376                            my ($k,$v) = split(/\t/, $line, 2);
1377                            $hints->{$k} = $v;
1378                    }
1379            }
1380    
1381            my $snum = $lnum;
1382    
1383            while( ! $isend && $lnum <= $#lines ) {
1384                    my $line = $lines[$lnum];
1385                    #warn "# $lnum: $line\n";
1386                    $lnum++;
1387    
1388                    if ($line && $line =~ m/^\Q$border\E/) {
1389                            if ($lnum > $snum) {
1390                                    my $rdattrs;
1391                                    my $rdvector;
1392                                    my $rdsnippet;
1393                                    
1394                                    my $rlnum = $snum;
1395                                    while ($rlnum < $lnum - 1 ) {
1396                                            #my $rdline = $self->_s($lines[$rlnum]);
1397                                            my $rdline = $lines[$rlnum];
1398                                            $rlnum++;
1399                                            last unless ($rdline);
1400                                            if ($rdline =~ /^%/) {
1401                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1402                                            } elsif($rdline =~ /=/) {
1403                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1404                                            } else {
1405                                                    confess "invalid format of response";
1406                                            }
1407                                    }
1408                                    while($rlnum < $lnum - 1) {
1409                                            my $rdline = $lines[$rlnum];
1410                                            $rlnum++;
1411                                            $rdsnippet .= "$rdline\n";
1412                                    }
1413                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1414                                    if (my $rduri = $rdattrs->{'@uri'}) {
1415                                            push @docs, new Search::Estraier::ResultDocument(
1416                                                    uri => $rduri,
1417                                                    attrs => $rdattrs,
1418                                                    snippet => $rdsnippet,
1419                                                    keywords => $rdvector,
1420                                            );
1421                                    }
1422                            }
1423                            $snum = $lnum;
1424                            #warn "### $line\n";
1425                            $isend = 1 if ($line =~ /:END$/);
1426                    }
1427    
1428            }
1429    
1430            if (! $isend) {
1431                    warn "received result doesn't have :END\n$resbody";
1432                    return;
1433            }
1434    
1435            #warn Dumper(\@docs, $hints);
1436    
1437            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1438    }
1439    
1440    
1441    =head2 cond_to_query
1442    
1443    Return URI encoded string generated from Search::Estraier::Condition
1444    
1445      my $args = $node->cond_to_query( $cond, $depth );
1446    
1447    =cut
1448    
1449    sub cond_to_query {
1450            my $self = shift;
1451    
1452            my $cond = shift || return;
1453            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1454            my $depth = shift;
1455    
1456            my @args;
1457    
1458            if (my $phrase = $cond->phrase) {
1459                    push @args, 'phrase=' . uri_escape($phrase);
1460            }
1461    
1462            if (my @attrs = $cond->attrs) {
1463                    for my $i ( 0 .. $#attrs ) {
1464                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1465                    }
1466            }
1467    
1468            if (my $order = $cond->order) {
1469                    push @args, 'order=' . uri_escape($order);
1470            }
1471                    
1472            if (my $max = $cond->max) {
1473                    push @args, 'max=' . $max;
1474            } else {
1475                    push @args, 'max=' . (1 << 30);
1476            }
1477    
1478            if (my $options = $cond->options) {
1479                    push @args, 'options=' . $options;
1480            }
1481    
1482            push @args, 'depth=' . $depth if ($depth);
1483            push @args, 'wwidth=' . $self->{wwidth};
1484            push @args, 'hwidth=' . $self->{hwidth};
1485            push @args, 'awidth=' . $self->{awidth};
1486    
1487            return join('&', @args);
1488    }
1489    
1490    
1491  =head2 shuttle_url  =head2 shuttle_url
1492    
1493  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
1494  master.  master.
1495    
1496    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1497    
1498  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
1499  body will be saved within object.  body will be saved within object.
1500    
1501  =cut  =cut
1502    
1503    use LWP::UserAgent;
1504    
1505  sub shuttle_url {  sub shuttle_url {
1506          my $self = shift;          my $self = shift;
1507    
# Line 1074  sub shuttle_url { Line 1520  sub shuttle_url {
1520                  return -1;                  return -1;
1521          }          }
1522    
1523          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1524            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1525    
1526          if ($self->{pxhost}) {          my $req;
1527                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1528                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1529            } else {
1530                    $req = HTTP::Request->new(GET => $url);
1531          }          }
1532    
1533          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1534            $req->headers->header( 'Connection', 'close' );
1535            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1536            $req->content_type( $content_type );
1537    
1538          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1539    
1540          if ($reqbody) {          if ($reqbody) {
1541                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1542          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1543          }          }
1544    
1545          $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,  
         );  
   
         if (! $sock) {  
                 carp "can't open socket to $host:$port";  
                 return -1;  
         }  
1546    
1547          warn $headers if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1548    
1549          print $sock $headers or          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1550    
1551          if ($reqbody) {          if (! $res->is_success) {
1552                  warn "$reqbody\n" if ($self->{debug});                  if ($self->{croak_on_error}) {
1553                  print $sock $reqbody or                          croak("can't get $url: ",$res->status_line);
1554                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  } else {
1555                            return -1;
1556                    }
1557          }          }
1558    
1559          my $line = <$sock>;          $$resbody .= $res->content;
         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});  
         };  
   
         # read body  
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1560    
1561          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1562    
1563          return $self->{status};          return $self->{status};
1564  }  }
1565    
1566    
1567    =head2 set_snippet_width
1568    
1569    Set width of snippets in results
1570    
1571      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1572    
1573    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1574    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1575    
1576    C<$hwidth> specified width of strings from beginning of string. Default
1577    value is C<96>. Negative or zero value keep previous value.
1578    
1579    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1580    If negative of zero value is provided previous value is kept unchanged.
1581    
1582    =cut
1583    
1584    sub set_snippet_width {
1585            my $self = shift;
1586    
1587            my ($wwidth, $hwidth, $awidth) = @_;
1588            $self->{wwidth} = $wwidth;
1589            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1590            $self->{awidth} = $awidth if ($awidth >= 0);
1591    }
1592    
1593    
1594    =head2 set_user
1595    
1596    Manage users of node
1597    
1598      $node->set_user( 'name', $mode );
1599    
1600    C<$mode> can be one of:
1601    
1602    =over 4
1603    
1604    =item 0
1605    
1606    delete account
1607    
1608    =item 1
1609    
1610    set administrative right for user
1611    
1612    =item 2
1613    
1614    set user account as guest
1615    
1616    =back
1617    
1618    Return true on success, otherwise false.
1619    
1620    =cut
1621    
1622    sub set_user {
1623            my $self = shift;
1624            my ($name, $mode) = @_;
1625    
1626            return unless ($self->{url});
1627            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1628    
1629            $self->shuttle_url( $self->{url} . '/_set_user',
1630                    'text/plain',
1631                    'name=' . uri_escape($name) . '&mode=' . $mode,
1632                    undef
1633            ) == 200;
1634    }
1635    
1636    
1637    =head2 set_link
1638    
1639    Manage node links
1640    
1641      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1642    
1643    If C<$credit> is negative, link is removed.
1644    
1645    =cut
1646    
1647    sub set_link {
1648            my $self = shift;
1649            my ($url, $label, $credit) = @_;
1650    
1651            return unless ($self->{url});
1652            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1653    
1654            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1655            $reqbody .= '&credit=' . $credit if ($credit > 0);
1656    
1657            $self->shuttle_url( $self->{url} . '/_set_link',
1658                    'application/x-www-form-urlencoded',
1659                    $reqbody,
1660                    undef
1661            ) == 200;
1662    }
1663    
1664    
1665    =head1 PRIVATE METHODS
1666    
1667    You could call those directly, but you don't have to. I hope.
1668    
1669    =head2 _set_info
1670    
1671    Set information for node
1672    
1673      $node->_set_info;
1674    
1675    =cut
1676    
1677    sub _set_info {
1678            my $self = shift;
1679    
1680            $self->{status} = -1;
1681            return unless ($self->{url});
1682    
1683            my $resbody;
1684            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1685                    'text/plain',
1686                    undef,
1687                    \$resbody,
1688            );
1689    
1690            return if ($rv != 200 || !$resbody);
1691    
1692            # it seems that response can have multiple line endings
1693            $resbody =~ s/[\r\n]+$//;
1694    
1695            ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1696                    split(/\t/, $resbody, 5);
1697    
1698    }
1699    
1700  ###  ###
1701    
1702  =head1 EXPORT  =head1 EXPORT
Legend:
Removed from v.47  
changed lines
  Added in v.102
  ViewVC Help
Powered by ViewVC 1.1.26