/[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 100 by dpavlin, Sat Jan 28 19:41:59 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            $node->set_url("http://localhost:1978/node/test");
22            $node->set_auth("admin","admin");
23    
24            # create document
25            my $doc = new Search::Estraier::Document;
26    
27            # add attributes
28            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
29            $doc->add_attr('@title', "Over the Rainbow");
30    
31            # add body text to document
32            $doc->add_text("Somewhere over the rainbow.  Way up high.");
33            $doc->add_text("There's a land that I heard of once in a lullaby.");
34    
35            die "error: ", $node->status,"\n" unless ($node->put_doc($doc));
36    
37    =head2 Simple searcher
38    
39            use Search::Estraier;
40    
41            # create and configure node
42            my $node = new Search::Estraier::Node;
43            $node->set_url("http://localhost:1978/node/test");
44            $node->set_auth("admin","admin");
45    
46            # create condition
47            my $cond = new Search::Estraier::Condition;
48    
49            # set search phrase
50            $cond->set_phrase("rainbow AND lullaby");
51    
52            my $nres = $node->search($cond, 0);
53            print "Got ", $nres->hits, " results\n";
54    
55            if (defined($nres)) {
56                    # for each document in results
57                    for my $i ( 0 ... $nres->doc_num - 1 ) {
58                            # get result document
59                            my $rdoc = $nres->get_doc($i);
60                            # display attribte
61                            print "URI: ", $rdoc->attr('@uri'),"\n";
62                            print "Title: ", $rdoc->attr('@title'),"\n";
63                            print $rdoc->snippet,"\n";
64                    }
65            } else {
66                    die "error: ", $node->status,"\n";
67            }
68    
69  =head1 DESCRIPTION  =head1 DESCRIPTION
70    
# Line 25  or Hyper Estraier development files on t Line 76  or Hyper Estraier development files on t
76  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
77  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
78    
79    There are few examples in C<scripts> directory of this distribution.
80    
81  =cut  =cut
82    
83  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 94  Remove multiple whitespaces from string,
94  =cut  =cut
95    
96  sub _s {  sub _s {
97          my $text = $_[1] || return;          my $text = $_[1];
98            return unless defined($text);
99          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
100          $text =~ s/^\s+//;          $text =~ s/^\s+//;
101          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 160  sub new {
160                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
161                                  $in_text = 1;                                  $in_text = 1;
162                                  next;                                  next;
163                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
164                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
165                                  next;                                  next;
166                          }                          }
167    
168                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
169                  }                  }
170          }          }
171    
# Line 205  Returns array with attribute names from Line 259  Returns array with attribute names from
259    
260  sub attr_names {  sub attr_names {
261          my $self = shift;          my $self = shift;
262          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
263            #croak "attr_names return array, not scalar" if (! wantarray);
264          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
265  }  }
266    
# Line 221  Returns value of an attribute. Line 276  Returns value of an attribute.
276  sub attr {  sub attr {
277          my $self = shift;          my $self = shift;
278          my $name = shift;          my $name = shift;
279            return unless (defined($name) && $self->{attrs});
280          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
281  }  }
282    
283    
# Line 236  Returns array with text sentences. Line 291  Returns array with text sentences.
291    
292  sub texts {  sub texts {
293          my $self = shift;          my $self = shift;
294          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
295          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
296  }  }
297    
298    
# Line 251  Return whole text as single scalar. Line 306  Return whole text as single scalar.
306    
307  sub cat_texts {  sub cat_texts {
308          my $self = shift;          my $self = shift;
309          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
310  }  }
311    
312    
# Line 268  sub dump_draft { Line 323  sub dump_draft {
323          my $draft;          my $draft;
324    
325          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
326                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
327                    $draft .= $attr_name . '=' . $v . "\n";
328          }          }
329    
330          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 372  sub delete {
372    
373  package Search::Estraier::Condition;  package Search::Estraier::Condition;
374    
375  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
376    
377  use Search::Estraier;  use Search::Estraier;
378  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 450  sub set_max {
450    
451  =head2 set_options  =head2 set_options
452    
453    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
454    
455      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
456    
457    Possible options are:
458    
459    =over 8
460    
461    =item SURE
462    
463    check every N-gram
464    
465    =item USUAL
466    
467    check every second N-gram
468    
469    =item FAST
470    
471    check every third N-gram
472    
473    =item AGITO
474    
475    check every fourth N-gram
476    
477    =item NOIDF
478    
479    don't perform TF-IDF tuning
480    
481    =item SIMPLE
482    
483    use simplified query phrase
484    
485    =back
486    
487    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
488    options;
489    
490    This option changed in version C<0.04> of this module. It's backwards compatibile.
491    
492  =cut  =cut
493    
494  my $options = {  my $options = {
         # check N-gram keys skipping by three  
495          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
496          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
497          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
498          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
499          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
500          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
501  };  };
502    
503  sub set_options {  sub set_options {
504          my $self = shift;          my $self = shift;
505          my $option = shift;          my $opt = 0;
506          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
507          $self->{options} ||= $options->{$option};                  my $mask;
508                    unless ($mask = $options->{$option}) {
509                            if ($option eq '1') {
510                                    next;
511                            } else {
512                                    croak "unknown option $option";
513                            }
514                    }
515                    $opt += $mask;
516            }
517            $self->{options} = $opt;
518  }  }
519    
520    
# Line 460  Return search result attrs. Line 557  Return search result attrs.
557  sub attrs {  sub attrs {
558          my $self = shift;          my $self = shift;
559          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
560          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
561  }  }
562    
563    
# Line 524  sub new { Line 621  sub new {
621          my $self = {@_};          my $self = {@_};
622          bless($self, $class);          bless($self, $class);
623    
624          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});  
         }  
625    
626          $self ? return $self : return undef;          $self ? return $self : return undef;
627  }  }
# Line 641  Return number of documents Line 736  Return number of documents
736    
737    print $res->doc_num;    print $res->doc_num;
738    
739    This will return real number of documents (limited by C<max>).
740    If you want to get total number of hits, see C<hits>.
741    
742  =cut  =cut
743    
744  sub doc_num {  sub doc_num {
745          my $self = shift;          my $self = shift;
746          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
747  }  }
748    
749    
# Line 672  sub get_doc { Line 770  sub get_doc {
770    
771  Return specific hint from results.  Return specific hint from results.
772    
773    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
774    
775  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>,
776  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 783  sub hint {
783          return $self->{hints}->{$key};          return $self->{hints}->{$key};
784  }  }
785    
786    =head2 hits
787    
788    More perlish version of C<hint>. This one returns hash.
789    
790      my %hints = $res->hints;
791    
792    =cut
793    
794    sub hints {
795            my $self = shift;
796            return $self->{hints};
797    }
798    
799    =head2 hits
800    
801    Syntaxtic sugar for total number of hits for this query
802    
803      print $res->hits;
804    
805    It's same as
806    
807      print $res->hint('HIT');
808    
809    but shorter.
810    
811    =cut
812    
813    sub hits {
814            my $self = shift;
815            return $self->{hints}->{'HIT'} || 0;
816    }
817    
818  package Search::Estraier::Node;  package Search::Estraier::Node;
819    
# Line 692  use Carp qw/carp croak confess/; Line 821  use Carp qw/carp croak confess/;
821  use URI;  use URI;
822  use MIME::Base64;  use MIME::Base64;
823  use IO::Socket::INET;  use IO::Socket::INET;
824    use URI::Escape qw/uri_escape/;
825    
826  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
827    
# Line 699  use IO::Socket::INET; Line 829  use IO::Socket::INET;
829    
830    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
831    
832    or optionally with C<url> as parametar
833    
834      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
835    
836    or in more verbose form
837    
838      my $node = new Search::HyperEstraier::Node(
839            url => 'http://localhost:1978/node/test',
840            debug => 1,
841            croak_on_error => 1
842      );
843    
844    with following arguments:
845    
846    =over 4
847    
848    =item url
849    
850    URL to node
851    
852    =item debug
853    
854    dumps a B<lot> of debugging output
855    
856    =item croak_on_error
857    
858    very helpful during development. It will croak on all errors instead of
859    silently returning C<-1> (which is convention of Hyper Estraier API in other
860    languages).
861    
862    =back
863    
864  =cut  =cut
865    
866  sub new {  sub new {
# Line 716  sub new { Line 878  sub new {
878          };          };
879          bless($self, $class);          bless($self, $class);
880    
881          if (@_) {          if ($#_ == 0) {
882                  $self->{debug} = shift;                  $self->{url} = shift;
883                  warn "## Node debug on\n";          } else {
884                    my $args = {@_};
885    
886                    %$self = ( %$self, @_ );
887    
888                    warn "## Node debug on\n" if ($self->{debug});
889          }          }
890    
891          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 1033  sub out_doc_by_uri {
1033          return unless ($self->{url});          return unless ($self->{url});
1034          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1035                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1036                  "uri=$uri",                  "uri=" . uri_escape($uri),
1037                  undef                  undef
1038          ) == 200;          ) == 200;
1039  }  }
# Line 928  sub get_doc_by_uri { Line 1095  sub get_doc_by_uri {
1095  }  }
1096    
1097    
1098    =head2 get_doc_attr
1099    
1100    Retrieve the value of an atribute from object
1101    
1102      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1103            die "can't get document attribute";
1104    
1105    =cut
1106    
1107    sub get_doc_attr {
1108            my $self = shift;
1109            my ($id,$name) = @_;
1110            return unless ($id && $name);
1111            return $self->_fetch_doc( id => $id, attr => $name );
1112    }
1113    
1114    
1115    =head2 get_doc_attr_by_uri
1116    
1117    Retrieve the value of an atribute from object
1118    
1119      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1120            die "can't get document attribute";
1121    
1122    =cut
1123    
1124    sub get_doc_attr_by_uri {
1125            my $self = shift;
1126            my ($uri,$name) = @_;
1127            return unless ($uri && $name);
1128            return $self->_fetch_doc( uri => $uri, attr => $name );
1129    }
1130    
1131    
1132  =head2 etch_doc  =head2 etch_doc
1133    
1134  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1137  Exctract document keywords
1137    
1138  =cut  =cut
1139    
1140  sub erch_doc {  sub etch_doc {
1141          my $self = shift;          my $self = shift;
1142          my $id = shift || return;          my $id = shift || return;
1143          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 1188  C<etch_doc>, C<etch_doc_by_uri>.
1188   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1189   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1190    
1191     # to get document attrubute add attr
1192     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1193     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1194    
1195   # more general form which allows implementation of   # more general form which allows implementation of
1196   # uri_to_id   # uri_to_id
1197   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1216  sub _fetch_doc {
1216                  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+$/);
1217                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1218          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1219                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1220          } else {          } else {
1221                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1222          }          }
1223    
1224            if ($a->{attr}) {
1225                    $path = '/get_doc_attr';
1226                    $arg .= '&attr=' . uri_escape($a->{attr});
1227                    $a->{chomp_resbody} = 1;
1228            }
1229    
1230          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1231                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1232                  $arg,                  $arg,
# Line 1042  sub _fetch_doc { Line 1253  sub _fetch_doc {
1253  }  }
1254    
1255    
1256    =head2 name
1257    
1258      my $node_name = $node->name;
1259    
1260    =cut
1261    
1262    sub name {
1263            my $self = shift;
1264            $self->_set_info unless ($self->{name});
1265            return $self->{name};
1266    }
1267    
1268    
1269    =head2 label
1270    
1271      my $node_label = $node->label;
1272    
1273    =cut
1274    
1275    sub label {
1276            my $self = shift;
1277            $self->_set_info unless ($self->{label});
1278            return $self->{label};
1279    }
1280    
1281    
1282    =head2 doc_num
1283    
1284      my $documents_in_node = $node->doc_num;
1285    
1286    =cut
1287    
1288    sub doc_num {
1289            my $self = shift;
1290            $self->_set_info if ($self->{dnum} < 0);
1291            return $self->{dnum};
1292    }
1293    
1294    
1295    =head2 word_num
1296    
1297      my $words_in_node = $node->word_num;
1298    
1299    =cut
1300    
1301    sub word_num {
1302            my $self = shift;
1303            $self->_set_info if ($self->{wnum} < 0);
1304            return $self->{wnum};
1305    }
1306    
1307    
1308    =head2 size
1309    
1310      my $node_size = $node->size;
1311    
1312    =cut
1313    
1314    sub size {
1315            my $self = shift;
1316            $self->_set_info if ($self->{size} < 0);
1317            return $self->{size};
1318    }
1319    
1320    
1321    =head2 search
1322    
1323    Search documents which match condition
1324    
1325      my $nres = $node->search( $cond, $depth );
1326    
1327    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1328    depth for meta search.
1329    
1330    Function results C<Search::Estraier::NodeResult> object.
1331    
1332    =cut
1333    
1334    sub search {
1335            my $self = shift;
1336            my ($cond, $depth) = @_;
1337            return unless ($cond && defined($depth) && $self->{url});
1338            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1339            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1340    
1341            my $resbody;
1342    
1343            my $rv = $self->shuttle_url( $self->{url} . '/search',
1344                    'application/x-www-form-urlencoded',
1345                    $self->cond_to_query( $cond, $depth ),
1346                    \$resbody,
1347            );
1348            return if ($rv != 200);
1349    
1350            my (@docs, $hints);
1351    
1352            my @lines = split(/\n/, $resbody);
1353            return unless (@lines);
1354    
1355            my $border = $lines[0];
1356            my $isend = 0;
1357            my $lnum = 1;
1358    
1359            while ( $lnum <= $#lines ) {
1360                    my $line = $lines[$lnum];
1361                    $lnum++;
1362    
1363                    #warn "## $line\n";
1364                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1365                            $isend = $1;
1366                            last;
1367                    }
1368    
1369                    if ($line =~ /\t/) {
1370                            my ($k,$v) = split(/\t/, $line, 2);
1371                            $hints->{$k} = $v;
1372                    }
1373            }
1374    
1375            my $snum = $lnum;
1376    
1377            while( ! $isend && $lnum <= $#lines ) {
1378                    my $line = $lines[$lnum];
1379                    #warn "# $lnum: $line\n";
1380                    $lnum++;
1381    
1382                    if ($line && $line =~ m/^\Q$border\E/) {
1383                            if ($lnum > $snum) {
1384                                    my $rdattrs;
1385                                    my $rdvector;
1386                                    my $rdsnippet;
1387                                    
1388                                    my $rlnum = $snum;
1389                                    while ($rlnum < $lnum - 1 ) {
1390                                            #my $rdline = $self->_s($lines[$rlnum]);
1391                                            my $rdline = $lines[$rlnum];
1392                                            $rlnum++;
1393                                            last unless ($rdline);
1394                                            if ($rdline =~ /^%/) {
1395                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1396                                            } elsif($rdline =~ /=/) {
1397                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1398                                            } else {
1399                                                    confess "invalid format of response";
1400                                            }
1401                                    }
1402                                    while($rlnum < $lnum - 1) {
1403                                            my $rdline = $lines[$rlnum];
1404                                            $rlnum++;
1405                                            $rdsnippet .= "$rdline\n";
1406                                    }
1407                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1408                                    if (my $rduri = $rdattrs->{'@uri'}) {
1409                                            push @docs, new Search::Estraier::ResultDocument(
1410                                                    uri => $rduri,
1411                                                    attrs => $rdattrs,
1412                                                    snippet => $rdsnippet,
1413                                                    keywords => $rdvector,
1414                                            );
1415                                    }
1416                            }
1417                            $snum = $lnum;
1418                            #warn "### $line\n";
1419                            $isend = 1 if ($line =~ /:END$/);
1420                    }
1421    
1422            }
1423    
1424            if (! $isend) {
1425                    warn "received result doesn't have :END\n$resbody";
1426                    return;
1427            }
1428    
1429            #warn Dumper(\@docs, $hints);
1430    
1431            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1432    }
1433    
1434    
1435    =head2 cond_to_query
1436    
1437    Return URI encoded string generated from Search::Estraier::Condition
1438    
1439      my $args = $node->cond_to_query( $cond, $depth );
1440    
1441    =cut
1442    
1443    sub cond_to_query {
1444            my $self = shift;
1445    
1446            my $cond = shift || return;
1447            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1448            my $depth = shift;
1449    
1450            my @args;
1451    
1452            if (my $phrase = $cond->phrase) {
1453                    push @args, 'phrase=' . uri_escape($phrase);
1454            }
1455    
1456            if (my @attrs = $cond->attrs) {
1457                    for my $i ( 0 .. $#attrs ) {
1458                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1459                    }
1460            }
1461    
1462            if (my $order = $cond->order) {
1463                    push @args, 'order=' . uri_escape($order);
1464            }
1465                    
1466            if (my $max = $cond->max) {
1467                    push @args, 'max=' . $max;
1468            } else {
1469                    push @args, 'max=' . (1 << 30);
1470            }
1471    
1472            if (my $options = $cond->options) {
1473                    push @args, 'options=' . $options;
1474            }
1475    
1476            push @args, 'depth=' . $depth if ($depth);
1477            push @args, 'wwidth=' . $self->{wwidth};
1478            push @args, 'hwidth=' . $self->{hwidth};
1479            push @args, 'awidth=' . $self->{awidth};
1480    
1481            return join('&', @args);
1482    }
1483    
1484    
1485  =head2 shuttle_url  =head2 shuttle_url
1486    
1487  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
1488  master.  master.
1489    
1490    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1491    
1492  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
1493  body will be saved within object.  body will be saved within object.
1494    
1495  =cut  =cut
1496    
1497    use LWP::UserAgent;
1498    
1499  sub shuttle_url {  sub shuttle_url {
1500          my $self = shift;          my $self = shift;
1501    
# Line 1074  sub shuttle_url { Line 1514  sub shuttle_url {
1514                  return -1;                  return -1;
1515          }          }
1516    
1517          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1518            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1519    
1520          if ($self->{pxhost}) {          my $req;
1521                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1522                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1523            } else {
1524                    $req = HTTP::Request->new(GET => $url);
1525          }          }
1526    
1527          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1528            $req->headers->header( 'Connection', 'close' );
1529            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1530            $req->content_type( $content_type );
1531    
1532          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1533    
1534          if ($reqbody) {          if ($reqbody) {
1535                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1536          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1537          }          }
1538    
1539          $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;  
         }  
1540    
1541          warn $headers if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1542    
1543          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;  
1544    
1545          if ($reqbody) {          if (! $res->is_success) {
1546                  warn "$reqbody\n" if ($self->{debug});                  if ($self->{croak_on_error}) {
1547                  print $sock $reqbody or                          croak("can't get $url: ",$res->status_line);
1548                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  } else {
1549                            return -1;
1550                    }
1551          }          }
1552    
1553          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);  
1554    
1555          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1556    
1557          return $self->{status};          return $self->{status};
1558  }  }
1559    
1560    
1561    =head2 set_snippet_width
1562    
1563    Set width of snippets in results
1564    
1565      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1566    
1567    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1568    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1569    
1570    C<$hwidth> specified width of strings from beginning of string. Default
1571    value is C<96>. Negative or zero value keep previous value.
1572    
1573    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1574    If negative of zero value is provided previous value is kept unchanged.
1575    
1576    =cut
1577    
1578    sub set_snippet_width {
1579            my $self = shift;
1580    
1581            my ($wwidth, $hwidth, $awidth) = @_;
1582            $self->{wwidth} = $wwidth;
1583            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1584            $self->{awidth} = $awidth if ($awidth >= 0);
1585    }
1586    
1587    
1588    =head2 set_user
1589    
1590    Manage users of node
1591    
1592      $node->set_user( 'name', $mode );
1593    
1594    C<$mode> can be one of:
1595    
1596    =over 4
1597    
1598    =item 0
1599    
1600    delete account
1601    
1602    =item 1
1603    
1604    set administrative right for user
1605    
1606    =item 2
1607    
1608    set user account as guest
1609    
1610    =back
1611    
1612    Return true on success, otherwise false.
1613    
1614    =cut
1615    
1616    sub set_user {
1617            my $self = shift;
1618            my ($name, $mode) = @_;
1619    
1620            return unless ($self->{url});
1621            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1622    
1623            $self->shuttle_url( $self->{url} . '/_set_user',
1624                    'text/plain',
1625                    'name=' . uri_escape($name) . '&mode=' . $mode,
1626                    undef
1627            ) == 200;
1628    }
1629    
1630    
1631    =head2 set_link
1632    
1633    Manage node links
1634    
1635      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1636    
1637    If C<$credit> is negative, link is removed.
1638    
1639    =cut
1640    
1641    sub set_link {
1642            my $self = shift;
1643            my ($url, $label, $credit) = @_;
1644    
1645            return unless ($self->{url});
1646            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1647    
1648            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1649            $reqbody .= '&credit=' . $credit if ($credit > 0);
1650    
1651            $self->shuttle_url( $self->{url} . '/_set_link',
1652                    'application/x-www-form-urlencoded',
1653                    $reqbody,
1654                    undef
1655            ) == 200;
1656    }
1657    
1658    
1659    =head1 PRIVATE METHODS
1660    
1661    You could call those directly, but you don't have to. I hope.
1662    
1663    =head2 _set_info
1664    
1665    Set information for node
1666    
1667      $node->_set_info;
1668    
1669    =cut
1670    
1671    sub _set_info {
1672            my $self = shift;
1673    
1674            $self->{status} = -1;
1675            return unless ($self->{url});
1676    
1677            my $resbody;
1678            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1679                    'text/plain',
1680                    undef,
1681                    \$resbody,
1682            );
1683    
1684            return if ($rv != 200 || !$resbody);
1685    
1686            # it seems that response can have multiple line endings
1687            $resbody =~ s/[\r\n]+$//;
1688    
1689            ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1690                    split(/\t/, $resbody, 5);
1691    
1692    }
1693    
1694  ###  ###
1695    
1696  =head1 EXPORT  =head1 EXPORT
Legend:
Removed from v.47  
changed lines
  Added in v.100
  ViewVC Help
Powered by ViewVC 1.1.26