/[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 98 by dpavlin, Sat Jan 28 19:18:13 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            if (defined($nres)) {
54                    # for each document in results
55                    for my $i ( 0 ... $nres->doc_num - 1 ) {
56                            # get result document
57                            my $rdoc = $nres->get_doc($i);
58                            # display attribte
59                            print "URI: ", $rdoc->attr('@uri'),"\n";
60                            print "Title: ", $rdoc->attr('@title'),"\n";
61                            print $rdoc->snippet,"\n";
62                    }
63            } else {
64                    die "error: ", $node->status,"\n";
65            }
66    
67  =head1 DESCRIPTION  =head1 DESCRIPTION
68    
# Line 25  or Hyper Estraier development files on t Line 74  or Hyper Estraier development files on t
74  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
75  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
76    
77    There are few examples in C<scripts> directory of this distribution.
78    
79  =cut  =cut
80    
81  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 92  Remove multiple whitespaces from string,
92  =cut  =cut
93    
94  sub _s {  sub _s {
95          my $text = $_[1] || return;          my $text = $_[1];
96            return unless defined($text);
97          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
98          $text =~ s/^\s+//;          $text =~ s/^\s+//;
99          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 158  sub new {
158                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
159                                  $in_text = 1;                                  $in_text = 1;
160                                  next;                                  next;
161                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
162                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
163                                  next;                                  next;
164                          }                          }
165    
166                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
167                  }                  }
168          }          }
169    
# Line 205  Returns array with attribute names from Line 257  Returns array with attribute names from
257    
258  sub attr_names {  sub attr_names {
259          my $self = shift;          my $self = shift;
260          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
261            #croak "attr_names return array, not scalar" if (! wantarray);
262          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
263  }  }
264    
# Line 221  Returns value of an attribute. Line 274  Returns value of an attribute.
274  sub attr {  sub attr {
275          my $self = shift;          my $self = shift;
276          my $name = shift;          my $name = shift;
277            return unless (defined($name) && $self->{attrs});
278          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
279  }  }
280    
281    
# Line 236  Returns array with text sentences. Line 289  Returns array with text sentences.
289    
290  sub texts {  sub texts {
291          my $self = shift;          my $self = shift;
292          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
293          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
294  }  }
295    
296    
# Line 251  Return whole text as single scalar. Line 304  Return whole text as single scalar.
304    
305  sub cat_texts {  sub cat_texts {
306          my $self = shift;          my $self = shift;
307          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
308  }  }
309    
310    
# Line 268  sub dump_draft { Line 321  sub dump_draft {
321          my $draft;          my $draft;
322    
323          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
324                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
325                    $draft .= $attr_name . '=' . $v . "\n";
326          }          }
327    
328          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 370  sub delete {
370    
371  package Search::Estraier::Condition;  package Search::Estraier::Condition;
372    
373  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
374    
375  use Search::Estraier;  use Search::Estraier;
376  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 448  sub set_max {
448    
449  =head2 set_options  =head2 set_options
450    
451    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
452    
453      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
454    
455    Possible options are:
456    
457    =over 8
458    
459    =item SURE
460    
461    check every N-gram
462    
463    =item USUAL
464    
465    check every second N-gram
466    
467    =item FAST
468    
469    check every third N-gram
470    
471    =item AGITO
472    
473    check every fourth N-gram
474    
475    =item NOIDF
476    
477    don't perform TF-IDF tuning
478    
479    =item SIMPLE
480    
481    use simplified query phrase
482    
483    =back
484    
485    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
486    options;
487    
488    This option changed in version C<0.04> of this module. It's backwards compatibile.
489    
490  =cut  =cut
491    
492  my $options = {  my $options = {
         # check N-gram keys skipping by three  
493          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
494          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
495          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
496          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
497          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
498          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
499  };  };
500    
501  sub set_options {  sub set_options {
502          my $self = shift;          my $self = shift;
503          my $option = shift;          my $opt = 0;
504          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
505          $self->{options} ||= $options->{$option};                  my $mask;
506                    unless ($mask = $options->{$option}) {
507                            if ($option eq '1') {
508                                    next;
509                            } else {
510                                    croak "unknown option $option";
511                            }
512                    }
513                    $opt += $mask;
514            }
515            $self->{options} = $opt;
516  }  }
517    
518    
# Line 460  Return search result attrs. Line 555  Return search result attrs.
555  sub attrs {  sub attrs {
556          my $self = shift;          my $self = shift;
557          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
558          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
559  }  }
560    
561    
# Line 524  sub new { Line 619  sub new {
619          my $self = {@_};          my $self = {@_};
620          bless($self, $class);          bless($self, $class);
621    
622          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});  
         }  
623    
624          $self ? return $self : return undef;          $self ? return $self : return undef;
625  }  }
# Line 645  Return number of documents Line 738  Return number of documents
738    
739  sub doc_num {  sub doc_num {
740          my $self = shift;          my $self = shift;
741          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
742  }  }
743    
744    
# Line 685  sub hint { Line 778  sub hint {
778          return $self->{hints}->{$key};          return $self->{hints}->{$key};
779  }  }
780    
781    =head2 hints
782    
783    More perlish version of C<hint>. This one returns hash.
784    
785      my %hints = $rec->hints;
786    
787    =cut
788    
789    sub hints {
790            my $self = shift;
791            return $self->{hints};
792    }
793    
794  package Search::Estraier::Node;  package Search::Estraier::Node;
795    
# Line 692  use Carp qw/carp croak confess/; Line 797  use Carp qw/carp croak confess/;
797  use URI;  use URI;
798  use MIME::Base64;  use MIME::Base64;
799  use IO::Socket::INET;  use IO::Socket::INET;
800    use URI::Escape qw/uri_escape/;
801    
802  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
803    
# Line 699  use IO::Socket::INET; Line 805  use IO::Socket::INET;
805    
806    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
807    
808    or optionally with C<url> as parametar
809    
810      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
811    
812    or in more verbose form
813    
814      my $node = new Search::HyperEstraier::Node(
815            url => 'http://localhost:1978/node/test',
816            debug => 1,
817            croak_on_error => 1
818      );
819    
820    with following arguments:
821    
822    =over 4
823    
824    =item url
825    
826    URL to node
827    
828    =item debug
829    
830    dumps a B<lot> of debugging output
831    
832    =item croak_on_error
833    
834    very helpful during development. It will croak on all errors instead of
835    silently returning C<-1> (which is convention of Hyper Estraier API in other
836    languages).
837    
838    =back
839    
840  =cut  =cut
841    
842  sub new {  sub new {
# Line 716  sub new { Line 854  sub new {
854          };          };
855          bless($self, $class);          bless($self, $class);
856    
857          if (@_) {          if ($#_ == 0) {
858                  $self->{debug} = shift;                  $self->{url} = shift;
859                  warn "## Node debug on\n";          } else {
860                    my $args = {@_};
861    
862                    %$self = ( %$self, @_ );
863    
864                    warn "## Node debug on\n" if ($self->{debug});
865          }          }
866    
867          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 1009  sub out_doc_by_uri {
1009          return unless ($self->{url});          return unless ($self->{url});
1010          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
1011                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1012                  "uri=$uri",                  "uri=" . uri_escape($uri),
1013                  undef                  undef
1014          ) == 200;          ) == 200;
1015  }  }
# Line 928  sub get_doc_by_uri { Line 1071  sub get_doc_by_uri {
1071  }  }
1072    
1073    
1074    =head2 get_doc_attr
1075    
1076    Retrieve the value of an atribute from object
1077    
1078      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1079            die "can't get document attribute";
1080    
1081    =cut
1082    
1083    sub get_doc_attr {
1084            my $self = shift;
1085            my ($id,$name) = @_;
1086            return unless ($id && $name);
1087            return $self->_fetch_doc( id => $id, attr => $name );
1088    }
1089    
1090    
1091    =head2 get_doc_attr_by_uri
1092    
1093    Retrieve the value of an atribute from object
1094    
1095      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1096            die "can't get document attribute";
1097    
1098    =cut
1099    
1100    sub get_doc_attr_by_uri {
1101            my $self = shift;
1102            my ($uri,$name) = @_;
1103            return unless ($uri && $name);
1104            return $self->_fetch_doc( uri => $uri, attr => $name );
1105    }
1106    
1107    
1108  =head2 etch_doc  =head2 etch_doc
1109    
1110  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1113  Exctract document keywords
1113    
1114  =cut  =cut
1115    
1116  sub erch_doc {  sub etch_doc {
1117          my $self = shift;          my $self = shift;
1118          my $id = shift || return;          my $id = shift || return;
1119          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 1164  C<etch_doc>, C<etch_doc_by_uri>.
1164   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1165   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1166    
1167     # to get document attrubute add attr
1168     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1169     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1170    
1171   # more general form which allows implementation of   # more general form which allows implementation of
1172   # uri_to_id   # uri_to_id
1173   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1192  sub _fetch_doc {
1192                  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+$/);
1193                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1194          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1195                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1196          } else {          } else {
1197                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1198          }          }
1199    
1200            if ($a->{attr}) {
1201                    $path = '/get_doc_attr';
1202                    $arg .= '&attr=' . uri_escape($a->{attr});
1203                    $a->{chomp_resbody} = 1;
1204            }
1205    
1206          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1207                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1208                  $arg,                  $arg,
# Line 1042  sub _fetch_doc { Line 1229  sub _fetch_doc {
1229  }  }
1230    
1231    
1232    =head2 name
1233    
1234      my $node_name = $node->name;
1235    
1236    =cut
1237    
1238    sub name {
1239            my $self = shift;
1240            $self->_set_info unless ($self->{name});
1241            return $self->{name};
1242    }
1243    
1244    
1245    =head2 label
1246    
1247      my $node_label = $node->label;
1248    
1249    =cut
1250    
1251    sub label {
1252            my $self = shift;
1253            $self->_set_info unless ($self->{label});
1254            return $self->{label};
1255    }
1256    
1257    
1258    =head2 doc_num
1259    
1260      my $documents_in_node = $node->doc_num;
1261    
1262    =cut
1263    
1264    sub doc_num {
1265            my $self = shift;
1266            $self->_set_info if ($self->{dnum} < 0);
1267            return $self->{dnum};
1268    }
1269    
1270    
1271    =head2 word_num
1272    
1273      my $words_in_node = $node->word_num;
1274    
1275    =cut
1276    
1277    sub word_num {
1278            my $self = shift;
1279            $self->_set_info if ($self->{wnum} < 0);
1280            return $self->{wnum};
1281    }
1282    
1283    
1284    =head2 size
1285    
1286      my $node_size = $node->size;
1287    
1288    =cut
1289    
1290    sub size {
1291            my $self = shift;
1292            $self->_set_info if ($self->{size} < 0);
1293            return $self->{size};
1294    }
1295    
1296    
1297    =head2 search
1298    
1299    Search documents which match condition
1300    
1301      my $nres = $node->search( $cond, $depth );
1302    
1303    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1304    depth for meta search.
1305    
1306    Function results C<Search::Estraier::NodeResult> object.
1307    
1308    =cut
1309    
1310    sub search {
1311            my $self = shift;
1312            my ($cond, $depth) = @_;
1313            return unless ($cond && defined($depth) && $self->{url});
1314            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1315            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1316    
1317            my $resbody;
1318    
1319            my $rv = $self->shuttle_url( $self->{url} . '/search',
1320                    'application/x-www-form-urlencoded',
1321                    $self->cond_to_query( $cond, $depth ),
1322                    \$resbody,
1323            );
1324            return if ($rv != 200);
1325    
1326            my (@docs, $hints);
1327    
1328            my @lines = split(/\n/, $resbody);
1329            return unless (@lines);
1330    
1331            my $border = $lines[0];
1332            my $isend = 0;
1333            my $lnum = 1;
1334    
1335            while ( $lnum <= $#lines ) {
1336                    my $line = $lines[$lnum];
1337                    $lnum++;
1338    
1339                    #warn "## $line\n";
1340                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1341                            $isend = $1;
1342                            last;
1343                    }
1344    
1345                    if ($line =~ /\t/) {
1346                            my ($k,$v) = split(/\t/, $line, 2);
1347                            $hints->{$k} = $v;
1348                    }
1349            }
1350    
1351            my $snum = $lnum;
1352    
1353            while( ! $isend && $lnum <= $#lines ) {
1354                    my $line = $lines[$lnum];
1355                    #warn "# $lnum: $line\n";
1356                    $lnum++;
1357    
1358                    if ($line && $line =~ m/^\Q$border\E/) {
1359                            if ($lnum > $snum) {
1360                                    my $rdattrs;
1361                                    my $rdvector;
1362                                    my $rdsnippet;
1363                                    
1364                                    my $rlnum = $snum;
1365                                    while ($rlnum < $lnum - 1 ) {
1366                                            #my $rdline = $self->_s($lines[$rlnum]);
1367                                            my $rdline = $lines[$rlnum];
1368                                            $rlnum++;
1369                                            last unless ($rdline);
1370                                            if ($rdline =~ /^%/) {
1371                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1372                                            } elsif($rdline =~ /=/) {
1373                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1374                                            } else {
1375                                                    confess "invalid format of response";
1376                                            }
1377                                    }
1378                                    while($rlnum < $lnum - 1) {
1379                                            my $rdline = $lines[$rlnum];
1380                                            $rlnum++;
1381                                            $rdsnippet .= "$rdline\n";
1382                                    }
1383                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1384                                    if (my $rduri = $rdattrs->{'@uri'}) {
1385                                            push @docs, new Search::Estraier::ResultDocument(
1386                                                    uri => $rduri,
1387                                                    attrs => $rdattrs,
1388                                                    snippet => $rdsnippet,
1389                                                    keywords => $rdvector,
1390                                            );
1391                                    }
1392                            }
1393                            $snum = $lnum;
1394                            #warn "### $line\n";
1395                            $isend = 1 if ($line =~ /:END$/);
1396                    }
1397    
1398            }
1399    
1400            if (! $isend) {
1401                    warn "received result doesn't have :END\n$resbody";
1402                    return;
1403            }
1404    
1405            #warn Dumper(\@docs, $hints);
1406    
1407            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1408    }
1409    
1410    
1411    =head2 cond_to_query
1412    
1413    Return URI encoded string generated from Search::Estraier::Condition
1414    
1415      my $args = $node->cond_to_query( $cond, $depth );
1416    
1417    =cut
1418    
1419    sub cond_to_query {
1420            my $self = shift;
1421    
1422            my $cond = shift || return;
1423            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1424            my $depth = shift;
1425    
1426            my @args;
1427    
1428            if (my $phrase = $cond->phrase) {
1429                    push @args, 'phrase=' . uri_escape($phrase);
1430            }
1431    
1432            if (my @attrs = $cond->attrs) {
1433                    for my $i ( 0 .. $#attrs ) {
1434                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1435                    }
1436            }
1437    
1438            if (my $order = $cond->order) {
1439                    push @args, 'order=' . uri_escape($order);
1440            }
1441                    
1442            if (my $max = $cond->max) {
1443                    push @args, 'max=' . $max;
1444            } else {
1445                    push @args, 'max=' . (1 << 30);
1446            }
1447    
1448            if (my $options = $cond->options) {
1449                    push @args, 'options=' . $options;
1450            }
1451    
1452            push @args, 'depth=' . $depth if ($depth);
1453            push @args, 'wwidth=' . $self->{wwidth};
1454            push @args, 'hwidth=' . $self->{hwidth};
1455            push @args, 'awidth=' . $self->{awidth};
1456    
1457            return join('&', @args);
1458    }
1459    
1460    
1461  =head2 shuttle_url  =head2 shuttle_url
1462    
1463  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
1464  master.  master.
1465    
1466    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1467    
1468  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
1469  body will be saved within object.  body will be saved within object.
1470    
1471  =cut  =cut
1472    
1473    use LWP::UserAgent;
1474    
1475  sub shuttle_url {  sub shuttle_url {
1476          my $self = shift;          my $self = shift;
1477    
# Line 1074  sub shuttle_url { Line 1490  sub shuttle_url {
1490                  return -1;                  return -1;
1491          }          }
1492    
1493          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1494            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1495    
1496          if ($self->{pxhost}) {          my $req;
1497                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1498                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1499            } else {
1500                    $req = HTTP::Request->new(GET => $url);
1501          }          }
1502    
1503          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1504            $req->headers->header( 'Connection', 'close' );
1505            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1506            $req->content_type( $content_type );
1507    
1508          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1509    
1510          if ($reqbody) {          if ($reqbody) {
1511                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1512          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1513          }          }
1514    
1515          $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,  
         );  
1516    
1517          if (! $sock) {          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
                 carp "can't open socket to $host:$port";  
                 return -1;  
         }  
1518    
1519          warn $headers if ($self->{debug});          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1520    
1521          print $sock $headers or          if (! $res->is_success) {
1522                  carp "can't send headers to network:\n$headers\n" and return -1;                  if ($self->{croak_on_error}) {
1523                            croak("can't get $url: ",$res->status_line);
1524          if ($reqbody) {                  } else {
1525                  warn "$reqbody\n" if ($self->{debug});                          return -1;
1526                  print $sock $reqbody or                  }
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
1527          }          }
1528    
1529          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);  
1530    
1531          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1532    
1533          return $self->{status};          return $self->{status};
1534  }  }
1535    
1536    
1537    =head2 set_snippet_width
1538    
1539    Set width of snippets in results
1540    
1541      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1542    
1543    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1544    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1545    
1546    C<$hwidth> specified width of strings from beginning of string. Default
1547    value is C<96>. Negative or zero value keep previous value.
1548    
1549    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1550    If negative of zero value is provided previous value is kept unchanged.
1551    
1552    =cut
1553    
1554    sub set_snippet_width {
1555            my $self = shift;
1556    
1557            my ($wwidth, $hwidth, $awidth) = @_;
1558            $self->{wwidth} = $wwidth;
1559            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1560            $self->{awidth} = $awidth if ($awidth >= 0);
1561    }
1562    
1563    
1564    =head2 set_user
1565    
1566    Manage users of node
1567    
1568      $node->set_user( 'name', $mode );
1569    
1570    C<$mode> can be one of:
1571    
1572    =over 4
1573    
1574    =item 0
1575    
1576    delete account
1577    
1578    =item 1
1579    
1580    set administrative right for user
1581    
1582    =item 2
1583    
1584    set user account as guest
1585    
1586    =back
1587    
1588    Return true on success, otherwise false.
1589    
1590    =cut
1591    
1592    sub set_user {
1593            my $self = shift;
1594            my ($name, $mode) = @_;
1595    
1596            return unless ($self->{url});
1597            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1598    
1599            $self->shuttle_url( $self->{url} . '/_set_user',
1600                    'text/plain',
1601                    'name=' . uri_escape($name) . '&mode=' . $mode,
1602                    undef
1603            ) == 200;
1604    }
1605    
1606    
1607    =head2 set_link
1608    
1609    Manage node links
1610    
1611      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1612    
1613    If C<$credit> is negative, link is removed.
1614    
1615    =cut
1616    
1617    sub set_link {
1618            my $self = shift;
1619            my ($url, $label, $credit) = @_;
1620    
1621            return unless ($self->{url});
1622            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1623    
1624            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1625            $reqbody .= '&credit=' . $credit if ($credit > 0);
1626    
1627            $self->shuttle_url( $self->{url} . '/_set_link',
1628                    'application/x-www-form-urlencoded',
1629                    $reqbody,
1630                    undef
1631            ) == 200;
1632    }
1633    
1634    
1635    =head1 PRIVATE METHODS
1636    
1637    You could call those directly, but you don't have to. I hope.
1638    
1639    =head2 _set_info
1640    
1641    Set information for node
1642    
1643      $node->_set_info;
1644    
1645    =cut
1646    
1647    sub _set_info {
1648            my $self = shift;
1649    
1650            $self->{status} = -1;
1651            return unless ($self->{url});
1652    
1653            my $resbody;
1654            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1655                    'text/plain',
1656                    undef,
1657                    \$resbody,
1658            );
1659    
1660            return if ($rv != 200 || !$resbody);
1661    
1662            # it seems that response can have multiple line endings
1663            $resbody =~ s/[\r\n]+$//;
1664    
1665            ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1666                    split(/\t/, $resbody, 5);
1667    
1668    }
1669    
1670  ###  ###
1671    
1672  =head1 EXPORT  =head1 EXPORT
Legend:
Removed from v.47  
changed lines
  Added in v.98
  ViewVC Help
Powered by ViewVC 1.1.26