/[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 58 by dpavlin, Fri Jan 6 21:05:05 2006 UTC revision 128 by dpavlin, Mon May 8 12:00:43 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.06_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 496  sub options { Line 599  sub options {
599  }  }
600    
601    
602    =head2 set_skip
603    
604    Set number of skipped documents from beginning of results
605    
606      $cond->set_skip(42);
607    
608    Similar to C<offset> in RDBMS.
609    
610    =cut
611    
612    sub set_skip {
613            my $self = shift;
614            $self->{skip} = shift;
615    }
616    
617    =head2 skip
618    
619    Return skip for this condition.
620    
621      print $cond->skip;
622    
623    =cut
624    
625    sub skip {
626            my $self = shift;
627            return $self->{skip};
628    }
629    
630    
631  package Search::Estraier::ResultDocument;  package Search::Estraier::ResultDocument;
632    
633  use Carp qw/croak/;  use Carp qw/croak/;
# Line 524  sub new { Line 656  sub new {
656          my $self = {@_};          my $self = {@_};
657          bless($self, $class);          bless($self, $class);
658    
659          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});  
         }  
660    
661          $self ? return $self : return undef;          $self ? return $self : return undef;
662  }  }
# Line 641  Return number of documents Line 771  Return number of documents
771    
772    print $res->doc_num;    print $res->doc_num;
773    
774    This will return real number of documents (limited by C<max>).
775    If you want to get total number of hits, see C<hits>.
776    
777  =cut  =cut
778    
779  sub doc_num {  sub doc_num {
# Line 672  sub get_doc { Line 805  sub get_doc {
805    
806  Return specific hint from results.  Return specific hint from results.
807    
808    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
809    
810  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>,
811  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 818  sub hint {
818          return $self->{hints}->{$key};          return $self->{hints}->{$key};
819  }  }
820    
821    =head2 hints
822    
823    More perlish version of C<hint>. This one returns hash.
824    
825      my %hints = $res->hints;
826    
827    =cut
828    
829    sub hints {
830            my $self = shift;
831            return $self->{hints};
832    }
833    
834    =head2 hits
835    
836    Syntaxtic sugar for total number of hits for this query
837    
838      print $res->hits;
839    
840    It's same as
841    
842      print $res->hint('HIT');
843    
844    but shorter.
845    
846    =cut
847    
848    sub hits {
849            my $self = shift;
850            return $self->{hints}->{'HIT'} || 0;
851    }
852    
853  package Search::Estraier::Node;  package Search::Estraier::Node;
854    
# Line 700  use URI::Escape qw/uri_escape/; Line 864  use URI::Escape qw/uri_escape/;
864    
865    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
866    
867    or optionally with C<url> as parametar
868    
869      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
870    
871    or in more verbose form
872    
873      my $node = new Search::HyperEstraier::Node(
874            url => 'http://localhost:1978/node/test',
875            debug => 1,
876            croak_on_error => 1
877      );
878    
879    with following arguments:
880    
881    =over 4
882    
883    =item url
884    
885    URL to node
886    
887    =item debug
888    
889    dumps a B<lot> of debugging output
890    
891    =item croak_on_error
892    
893    very helpful during development. It will croak on all errors instead of
894    silently returning C<-1> (which is convention of Hyper Estraier API in other
895    languages).
896    
897    =back
898    
899  =cut  =cut
900    
901  sub new {  sub new {
# Line 707  sub new { Line 903  sub new {
903          my $self = {          my $self = {
904                  pxport => -1,                  pxport => -1,
905                  timeout => 0,   # this used to be -1                  timeout => 0,   # this used to be -1
                 dnum => -1,  
                 wnum => -1,  
                 size => -1.0,  
906                  wwidth => 480,                  wwidth => 480,
907                  hwidth => 96,                  hwidth => 96,
908                  awidth => 96,                  awidth => 96,
909                  status => -1,                  status => -1,
910          };          };
911    
912          bless($self, $class);          bless($self, $class);
913    
914          my $args = {@_};          if ($#_ == 0) {
915                    $self->{url} = shift;
916            } else {
917                    my $args = {@_};
918    
919                    %$self = ( %$self, @_ );
920    
921                    warn "## Node debug on\n" if ($self->{debug});
922            }
923    
924          $self->{debug} = $args->{debug};          $self->{inform} = {
925          warn "## Node debug on\n" if ($self->{debug});                  dnum => -1,
926                    wnum => -1,
927                    size => -1.0,
928            };
929    
930          $self ? return $self : return undef;          $self ? return $self : return undef;
931  }  }
# Line 1000  Get ID of document specified by URI Line 1205  Get ID of document specified by URI
1205    
1206    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1207    
1208    This method won't croak, even if using C<croak_on_error>.
1209    
1210  =cut  =cut
1211    
1212  sub uri_to_id {  sub uri_to_id {
1213          my $self = shift;          my $self = shift;
1214          my $uri = shift || return;          my $uri = shift || return;
1215          return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1 );          return $self->_fetch_doc( uri => $uri, path => '/uri_to_id', chomp_resbody => 1, croak_on_error => 0 );
1216  }  }
1217    
1218    
# Line 1065  sub _fetch_doc { Line 1272  sub _fetch_doc {
1272                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1273                  $arg,                  $arg,
1274                  \$resbody,                  \$resbody,
1275                    $a->{croak_on_error},
1276          );          );
1277    
1278          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1303  sub _fetch_doc {
1303    
1304  sub name {  sub name {
1305          my $self = shift;          my $self = shift;
1306          $self->_set_info unless ($self->{name});          $self->_set_info unless ($self->{inform}->{name});
1307          return $self->{name};          return $self->{inform}->{name};
1308  }  }
1309    
1310    
# Line 1108  sub name { Line 1316  sub name {
1316    
1317  sub label {  sub label {
1318          my $self = shift;          my $self = shift;
1319          $self->_set_info unless ($self->{label});          $self->_set_info unless ($self->{inform}->{label});
1320          return $self->{label};          return $self->{inform}->{label};
1321  }  }
1322    
1323    
# Line 1121  sub label { Line 1329  sub label {
1329    
1330  sub doc_num {  sub doc_num {
1331          my $self = shift;          my $self = shift;
1332          $self->_set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{inform}->{dnum} < 0);
1333          return $self->{dnum};          return $self->{inform}->{dnum};
1334  }  }
1335    
1336    
# Line 1134  sub doc_num { Line 1342  sub doc_num {
1342    
1343  sub word_num {  sub word_num {
1344          my $self = shift;          my $self = shift;
1345          $self->_set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{inform}->{wnum} < 0);
1346          return $self->{wnum};          return $self->{inform}->{wnum};
1347  }  }
1348    
1349    
# Line 1147  sub word_num { Line 1355  sub word_num {
1355    
1356  sub size {  sub size {
1357          my $self = shift;          my $self = shift;
1358          $self->_set_info if ($self->{size} < 0);          $self->_set_info if ($self->{inform}->{size} < 0);
1359          return $self->{size};          return $self->{inform}->{size};
1360  }  }
1361    
1362    
# Line 1176  sub search { Line 1384  sub search {
1384    
1385          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1386                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1387                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1388                  \$resbody,                  \$resbody,
1389          );          );
1390          return if ($rv != 200);          return if ($rv != 200);
1391    
1392          my (@docs, $hints);          my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
1393            my $hintsText   = splice @records, 0, 2; # starts with empty record
1394          my @lines = split(/\n/, $resbody);          my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
1395          return unless (@lines);  
1396            # process records
1397          my $border = $lines[0];          my $docs = [];
1398          my $isend = 0;          foreach my $record (@records)
1399          my $lnum = 1;          {
1400                    # split into keys and snippets
1401          while ( $lnum <= $#lines ) {                  my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
                 my $line = $lines[$lnum];  
                 $lnum++;  
   
                 #warn "## $line\n";  
                 if ($line && $line =~ m/^\Q$border\E(:END)*$/) {  
                         $isend = $1;  
                         last;  
                 }  
   
                 if ($line =~ /\t/) {  
                         my ($k,$v) = split(/\t/, $line, 2);  
                         $hints->{$k} = $v;  
                 }  
         }  
   
         my $snum = $lnum;  
   
         while( ! $isend && $lnum <= $#lines ) {  
                 my $line = $lines[$lnum];  
                 #warn "# $lnum: $line\n";  
                 $lnum++;  
   
                 if ($line && $line =~ m/^\Q$border\E/) {  
                         if ($lnum > $snum) {  
                                 my $rdattrs;  
                                 my $rdvector;  
                                 my $rdsnippet;  
                                   
                                 my $rlnum = $snum;  
                                 while ($rlnum < $lnum - 1 ) {  
                                         #my $rdline = $self->_s($lines[$rlnum]);  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         last unless ($rdline);  
                                         if ($rdline =~ /^%/) {  
                                                 $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);  
                                         } elsif($rdline =~ /=/) {  
                                                 $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);  
                                         } else {  
                                                 confess "invalid format of response";  
                                         }  
                                 }  
                                 while($rlnum < $lnum - 1) {  
                                         my $rdline = $lines[$rlnum];  
                                         $rlnum++;  
                                         $rdsnippet .= "$rdline\n";  
                                 }  
                                 #warn Dumper($rdvector, $rdattrs, $rdsnippet);  
                                 if (my $rduri = $rdattrs->{'@uri'}) {  
                                         push @docs, new Search::Estraier::ResultDocument(  
                                                 uri => $rduri,  
                                                 attrs => $rdattrs,  
                                                 snippet => $rdsnippet,  
                                                 keywords => $rdvector,  
                                         );  
                                 }  
                         }  
                         $snum = $lnum;  
                         #warn "### $line\n";  
                         $isend = 1 if ($line =~ /:END$/);  
                 }  
   
         }  
1402    
1403          if (! $isend) {                  # create document hash
1404                  warn "received result doesn't have :END\n$resbody";                  my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
1405                  return;                  $doc->{'@keywords'}     = $doc->{keywords};
1406                    ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
1407                    $doc->{snippet}         = $snippet;
1408    
1409                    push @$docs, new Search::Estraier::ResultDocument(
1410                            attrs           => $doc,
1411                            uri             => $doc->{'@uri'},
1412                            snippet         => $snippet,
1413                            keywords        => $doc->{'keywords'},
1414                    );
1415          }          }
1416    
1417          #warn Dumper(\@docs, $hints);          return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
   
         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );  
1418  }  }
1419    
1420    
# Line 1270  sub search { Line 1422  sub search {
1422    
1423  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1424    
1425    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1426    
1427  =cut  =cut
1428    
# Line 1279  sub cond_to_query { Line 1431  sub cond_to_query {
1431    
1432          my $cond = shift || return;          my $cond = shift || return;
1433          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1434            my $depth = shift;
1435    
1436          my @args;          my @args;
1437    
# Line 1288  sub cond_to_query { Line 1441  sub cond_to_query {
1441    
1442          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1443                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1444                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1445                  }                  }
1446          }          }
1447    
# Line 1306  sub cond_to_query { Line 1459  sub cond_to_query {
1459                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1460          }          }
1461    
1462          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1463          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1464          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1465          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
1466            push @args, 'skip=' . $self->{skip} if ($self->{skip});
1467    
1468          return join('&', @args);          return join('&', @args);
1469  }  }
# Line 1317  sub cond_to_query { Line 1471  sub cond_to_query {
1471    
1472  =head2 shuttle_url  =head2 shuttle_url
1473    
1474  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
1475  master.  master.
1476    
1477    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
# Line 1327  body will be saved within object. Line 1481  body will be saved within object.
1481    
1482  =cut  =cut
1483    
1484    use LWP::UserAgent;
1485    
1486  sub shuttle_url {  sub shuttle_url {
1487          my $self = shift;          my $self = shift;
1488    
1489          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1490    
1491            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1492    
1493          $self->{status} = -1;          $self->{status} = -1;
1494    
# Line 1345  sub shuttle_url { Line 1503  sub shuttle_url {
1503                  return -1;                  return -1;
1504          }          }
1505    
1506          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1507            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
         if ($self->{pxhost}) {  
                 ($host,$port) = ($self->{pxhost}, $self->{pxport});  
                 $query = "http://$host:$port/$query";  
         }  
   
         $query .= '?' . $url->query if ($url->query && ! $reqbody);  
   
         my $headers;  
1508    
1509            my $req;
1510          if ($reqbody) {          if ($reqbody) {
1511                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1512          } else {          } else {
1513                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1514          }          }
1515    
1516          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1517          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1518          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1519          $headers .= "Content-Type: $content_type\r\n";          $req->content_type( $content_type );
         $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";  
1520    
1521          my $sock = IO::Socket::INET->new(          warn $req->headers->as_string,"\n" if ($self->{debug});
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
1522    
1523          if (! $sock) {          if ($reqbody) {
1524                  carp "can't open socket to $host:$port";                  warn "$reqbody\n" if ($self->{debug});
1525                  return -1;                  $req->content( $reqbody );
1526          }          }
1527    
1528          warn $headers if ($self->{debug});          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1529    
1530          print $sock $headers or          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1531    
1532          if ($reqbody) {          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
                 warn "$reqbody\n" if ($self->{debug});  
                 print $sock $reqbody or  
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
         }  
1533    
1534          my $line = <$sock>;          if (! $res->is_success) {
1535          chomp($line);                  if ($croak_on_error) {
1536          my ($schema, $res_status, undef) = split(/  */, $line, 3);                          croak("can't get $url: ",$res->status_line);
1537          return if ($schema !~ /^HTTP/ || ! $res_status);                  } else {
1538                            return -1;
1539          $self->{status} = $res_status;                  }
1540          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});  
         };  
1541    
1542          # read body          $$resbody .= $res->content;
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1543    
1544          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1545    
# Line 1517  sub set_link { Line 1637  sub set_link {
1637          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1638          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1639    
1640          $self->shuttle_url( $self->{url} . '/_set_link',          if ($self->shuttle_url( $self->{url} . '/_set_link',
1641                  'text/plain',                  'application/x-www-form-urlencoded',
1642                  $reqbody,                  $reqbody,
1643                  undef                  undef
1644          ) == 200;          ) == 200) {
1645                    # refresh node info after adding link
1646                    $self->_set_info;
1647                    return 1;
1648            }
1649    }
1650    
1651    =head2 admins
1652    
1653     my @admins = @{ $node->admins };
1654    
1655    Return array of users with admin rights on node
1656    
1657    =cut
1658    
1659    sub admins {
1660            my $self = shift;
1661            $self->_set_info unless ($self->{inform}->{name});
1662            return $self->{inform}->{admins};
1663    }
1664    
1665    =head2 guests
1666    
1667     my @guests = @{ $node->guests };
1668    
1669    Return array of users with guest rights on node
1670    
1671    =cut
1672    
1673    sub guests {
1674            my $self = shift;
1675            $self->_set_info unless ($self->{inform}->{name});
1676            return $self->{inform}->{guests};
1677    }
1678    
1679    =head2 links
1680    
1681     my $links = @{ $node->links };
1682    
1683    Return array of links for this node
1684    
1685    =cut
1686    
1687    sub links {
1688            my $self = shift;
1689            $self->_set_info unless ($self->{inform}->{name});
1690            return $self->{inform}->{links};
1691  }  }
1692    
1693    
# Line 1552  sub _set_info { Line 1718  sub _set_info {
1718    
1719          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1720    
1721          # it seems that response can have multiple line endings          my @lines = split(/[\r\n]/,$resbody);
1722          $resbody =~ s/[\r\n]+$//;  
1723            $self->{inform} = {};
1724    
1725            ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
1726                    $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
1727    
1728            return $resbody unless (@lines);
1729    
1730            shift @lines;
1731    
1732            while(my $admin = shift @lines) {
1733                    push @{$self->{inform}->{admins}}, $admin;
1734            }
1735    
1736            while(my $guest = shift @lines) {
1737                    push @{$self->{inform}->{guests}}, $guest;
1738            }
1739    
1740            while(my $link = shift @lines) {
1741                    push @{$self->{inform}->{links}}, $link;
1742            }
1743    
1744          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          return $resbody;
                 split(/\t/, $resbody, 5);  
1745    
1746  }  }
1747    
# Line 1576  Hyper Estraier Ruby interface on which t Line 1761  Hyper Estraier Ruby interface on which t
1761    
1762  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1763    
1764    Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
1765    
1766  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1767    
Legend:
Removed from v.58  
changed lines
  Added in v.128
  ViewVC Help
Powered by ViewVC 1.1.26