/[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 51 by dpavlin, Fri Jan 6 13:19:50 2006 UTC revision 108 by dpavlin, Sun Feb 19 17:13:57 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.04_2';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node(
21                    url => 'http://localhost:1978/node/test',
22                    user => 'admin',
23                    passwd => 'admin'
24            );
25    
26            # create document
27            my $doc = new Search::Estraier::Document;
28    
29            # add attributes
30            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
31            $doc->add_attr('@title', "Over the Rainbow");
32    
33            # add body text to document
34            $doc->add_text("Somewhere over the rainbow.  Way up high.");
35            $doc->add_text("There's a land that I heard of once in a lullaby.");
36    
37            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
38    
39    =head2 Simple searcher
40    
41            use Search::Estraier;
42    
43            # create and configure node
44            my $node = new Search::Estraier::Node(
45                    url => 'http://localhost:1978/node/test',
46                    user => 'admin',
47                    passwd => 'admin',
48                    croak_on_error => 1,
49            );
50    
51            # create condition
52            my $cond = new Search::Estraier::Condition;
53    
54            # set search phrase
55            $cond->set_phrase("rainbow AND lullaby");
56    
57            my $nres = $node->search($cond, 0);
58    
59            if (defined($nres)) {
60                    print "Got ", $nres->hits, " results\n";
61    
62                    # for each document in results
63                    for my $i ( 0 ... $nres->doc_num - 1 ) {
64                            # get result document
65                            my $rdoc = $nres->get_doc($i);
66                            # display attribte
67                            print "URI: ", $rdoc->attr('@uri'),"\n";
68                            print "Title: ", $rdoc->attr('@title'),"\n";
69                            print $rdoc->snippet,"\n";
70                    }
71            } else {
72                    die "error: ", $node->status,"\n";
73            }
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 25  or Hyper Estraier development files on t Line 82  or Hyper Estraier development files on t
82  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
83  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
84    
85    There are few examples in C<scripts> directory of this distribution.
86    
87  =cut  =cut
88    
89  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 100  Remove multiple whitespaces from string,
100  =cut  =cut
101    
102  sub _s {  sub _s {
103          my $text = $_[1] || return;          my $text = $_[1];
104            return unless defined($text);
105          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
106          $text =~ s/^\s+//;          $text =~ s/^\s+//;
107          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 166  sub new {
166                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
167                                  $in_text = 1;                                  $in_text = 1;
168                                  next;                                  next;
169                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
170                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
171                                  next;                                  next;
172                          }                          }
173    
174                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
175                  }                  }
176          }          }
177    
# Line 205  Returns array with attribute names from Line 265  Returns array with attribute names from
265    
266  sub attr_names {  sub attr_names {
267          my $self = shift;          my $self = shift;
268          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
269            #croak "attr_names return array, not scalar" if (! wantarray);
270          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
271  }  }
272    
# Line 221  Returns value of an attribute. Line 282  Returns value of an attribute.
282  sub attr {  sub attr {
283          my $self = shift;          my $self = shift;
284          my $name = shift;          my $name = shift;
285            return unless (defined($name) && $self->{attrs});
286          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
287  }  }
288    
289    
# Line 236  Returns array with text sentences. Line 297  Returns array with text sentences.
297    
298  sub texts {  sub texts {
299          my $self = shift;          my $self = shift;
300          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
301          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
302  }  }
303    
304    
# Line 251  Return whole text as single scalar. Line 312  Return whole text as single scalar.
312    
313  sub cat_texts {  sub cat_texts {
314          my $self = shift;          my $self = shift;
315          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
316  }  }
317    
318    
# Line 268  sub dump_draft { Line 329  sub dump_draft {
329          my $draft;          my $draft;
330    
331          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
332                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
333                    $draft .= $attr_name . '=' . $v . "\n";
334          }          }
335    
336          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 378  sub delete {
378    
379  package Search::Estraier::Condition;  package Search::Estraier::Condition;
380    
381  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
382    
383  use Search::Estraier;  use Search::Estraier;
384  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 456  sub set_max {
456    
457  =head2 set_options  =head2 set_options
458    
459    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
460    
461      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
462    
463    Possible options are:
464    
465    =over 8
466    
467    =item SURE
468    
469    check every N-gram
470    
471    =item USUAL
472    
473    check every second N-gram
474    
475    =item FAST
476    
477    check every third N-gram
478    
479    =item AGITO
480    
481    check every fourth N-gram
482    
483    =item NOIDF
484    
485    don't perform TF-IDF tuning
486    
487    =item SIMPLE
488    
489    use simplified query phrase
490    
491    =back
492    
493    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
494    options;
495    
496    This option changed in version C<0.04> of this module. It's backwards compatibile.
497    
498  =cut  =cut
499    
500  my $options = {  my $options = {
         # check N-gram keys skipping by three  
501          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
502          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
503          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
504          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
505          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
506          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
507  };  };
508    
509  sub set_options {  sub set_options {
510          my $self = shift;          my $self = shift;
511          my $option = shift;          my $opt = 0;
512          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
513          $self->{options} ||= $options->{$option};                  my $mask;
514                    unless ($mask = $options->{$option}) {
515                            if ($option eq '1') {
516                                    next;
517                            } else {
518                                    croak "unknown option $option";
519                            }
520                    }
521                    $opt += $mask;
522            }
523            $self->{options} = $opt;
524  }  }
525    
526    
# Line 460  Return search result attrs. Line 563  Return search result attrs.
563  sub attrs {  sub attrs {
564          my $self = shift;          my $self = shift;
565          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
566          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
567  }  }
568    
569    
# Line 524  sub new { Line 627  sub new {
627          my $self = {@_};          my $self = {@_};
628          bless($self, $class);          bless($self, $class);
629    
630          foreach my $f (qw/uri attrs snippet keywords/) {          croak "missing uri for ResultDocument" unless defined($self->{uri});
                 croak "missing $f for ResultDocument" unless defined($self->{$f});  
         }  
631    
632          $self ? return $self : return undef;          $self ? return $self : return undef;
633  }  }
# Line 641  Return number of documents Line 742  Return number of documents
742    
743    print $res->doc_num;    print $res->doc_num;
744    
745    This will return real number of documents (limited by C<max>).
746    If you want to get total number of hits, see C<hits>.
747    
748  =cut  =cut
749    
750  sub doc_num {  sub doc_num {
751          my $self = shift;          my $self = shift;
752          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
753  }  }
754    
755    
# Line 672  sub get_doc { Line 776  sub get_doc {
776    
777  Return specific hint from results.  Return specific hint from results.
778    
779    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
780    
781  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
782  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 789  sub hint {
789          return $self->{hints}->{$key};          return $self->{hints}->{$key};
790  }  }
791    
792    =head2 hints
793    
794    More perlish version of C<hint>. This one returns hash.
795    
796      my %hints = $res->hints;
797    
798    =cut
799    
800    sub hints {
801            my $self = shift;
802            return $self->{hints};
803    }
804    
805    =head2 hits
806    
807    Syntaxtic sugar for total number of hits for this query
808    
809      print $res->hits;
810    
811    It's same as
812    
813      print $res->hint('HIT');
814    
815    but shorter.
816    
817    =cut
818    
819    sub hits {
820            my $self = shift;
821            return $self->{hints}->{'HIT'} || 0;
822    }
823    
824  package Search::Estraier::Node;  package Search::Estraier::Node;
825    
# Line 700  use URI::Escape qw/uri_escape/; Line 835  use URI::Escape qw/uri_escape/;
835    
836    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
837    
838    or optionally with C<url> as parametar
839    
840      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
841    
842    or in more verbose form
843    
844      my $node = new Search::HyperEstraier::Node(
845            url => 'http://localhost:1978/node/test',
846            debug => 1,
847            croak_on_error => 1
848      );
849    
850    with following arguments:
851    
852    =over 4
853    
854    =item url
855    
856    URL to node
857    
858    =item debug
859    
860    dumps a B<lot> of debugging output
861    
862    =item croak_on_error
863    
864    very helpful during development. It will croak on all errors instead of
865    silently returning C<-1> (which is convention of Hyper Estraier API in other
866    languages).
867    
868    =back
869    
870  =cut  =cut
871    
872  sub new {  sub new {
# Line 717  sub new { Line 884  sub new {
884          };          };
885          bless($self, $class);          bless($self, $class);
886    
887          if (@_) {          if ($#_ == 0) {
888                  $self->{debug} = shift;                  $self->{url} = shift;
889                  warn "## Node debug on\n";          } else {
890                    my $args = {@_};
891    
892                    %$self = ( %$self, @_ );
893    
894                    warn "## Node debug on\n" if ($self->{debug});
895          }          }
896    
897          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 1000  Get ID of document specified by URI Line 1172  Get ID of document specified by URI
1172    
1173    my $id = $node->uri_to_id( 'file:///document/uri/42' );    my $id = $node->uri_to_id( 'file:///document/uri/42' );
1174    
1175    This method won't croak, even if using C<croak_on_error>.
1176    
1177  =cut  =cut
1178    
1179  sub uri_to_id {  sub uri_to_id {
1180          my $self = shift;          my $self = shift;
1181          my $uri = shift || return;          my $uri = shift || return;
1182          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 );
1183  }  }
1184    
1185    
# Line 1065  sub _fetch_doc { Line 1239  sub _fetch_doc {
1239                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1240                  $arg,                  $arg,
1241                  \$resbody,                  \$resbody,
1242                    $a->{croak_on_error},
1243          );          );
1244    
1245          return if ($rv != 200);          return if ($rv != 200);
# Line 1095  sub _fetch_doc { Line 1270  sub _fetch_doc {
1270    
1271  sub name {  sub name {
1272          my $self = shift;          my $self = shift;
1273          $self->set_info unless ($self->{name});          $self->_set_info unless ($self->{name});
1274          return $self->{name};          return $self->{name};
1275  }  }
1276    
# Line 1108  sub name { Line 1283  sub name {
1283    
1284  sub label {  sub label {
1285          my $self = shift;          my $self = shift;
1286          $self->set_info unless ($self->{label});          $self->_set_info unless ($self->{label});
1287          return $self->{label};          return $self->{label};
1288  }  }
1289    
# Line 1121  sub label { Line 1296  sub label {
1296    
1297  sub doc_num {  sub doc_num {
1298          my $self = shift;          my $self = shift;
1299          $self->set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{dnum} < 0);
1300          return $self->{dnum};          return $self->{dnum};
1301  }  }
1302    
# Line 1134  sub doc_num { Line 1309  sub doc_num {
1309    
1310  sub word_num {  sub word_num {
1311          my $self = shift;          my $self = shift;
1312          $self->set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{wnum} < 0);
1313          return $self->{wnum};          return $self->{wnum};
1314  }  }
1315    
# Line 1147  sub word_num { Line 1322  sub word_num {
1322    
1323  sub size {  sub size {
1324          my $self = shift;          my $self = shift;
1325          $self->set_info if ($self->{size} < 0);          $self->_set_info if ($self->{size} < 0);
1326          return $self->{size};          return $self->{size};
1327  }  }
1328    
# Line 1172  sub search { Line 1347  sub search {
1347          croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));          croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1348          croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);          croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1349    
1350            my $resbody;
1351    
1352            my $rv = $self->shuttle_url( $self->{url} . '/search',
1353                    'application/x-www-form-urlencoded',
1354                    $self->cond_to_query( $cond, $depth ),
1355                    \$resbody,
1356            );
1357            return if ($rv != 200);
1358    
1359            my (@docs, $hints);
1360    
1361            my @lines = split(/\n/, $resbody);
1362            return unless (@lines);
1363    
1364            my $border = $lines[0];
1365            my $isend = 0;
1366            my $lnum = 1;
1367    
1368            while ( $lnum <= $#lines ) {
1369                    my $line = $lines[$lnum];
1370                    $lnum++;
1371    
1372                    #warn "## $line\n";
1373                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1374                            $isend = $1;
1375                            last;
1376                    }
1377    
1378                    if ($line =~ /\t/) {
1379                            my ($k,$v) = split(/\t/, $line, 2);
1380                            $hints->{$k} = $v;
1381                    }
1382            }
1383    
1384            my $snum = $lnum;
1385    
1386            while( ! $isend && $lnum <= $#lines ) {
1387                    my $line = $lines[$lnum];
1388                    #warn "# $lnum: $line\n";
1389                    $lnum++;
1390    
1391                    if ($line && $line =~ m/^\Q$border\E/) {
1392                            if ($lnum > $snum) {
1393                                    my $rdattrs;
1394                                    my $rdvector;
1395                                    my $rdsnippet;
1396                                    
1397                                    my $rlnum = $snum;
1398                                    while ($rlnum < $lnum - 1 ) {
1399                                            #my $rdline = $self->_s($lines[$rlnum]);
1400                                            my $rdline = $lines[$rlnum];
1401                                            $rlnum++;
1402                                            last unless ($rdline);
1403                                            if ($rdline =~ /^%/) {
1404                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1405                                            } elsif($rdline =~ /=/) {
1406                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1407                                            } else {
1408                                                    confess "invalid format of response";
1409                                            }
1410                                    }
1411                                    while($rlnum < $lnum - 1) {
1412                                            my $rdline = $lines[$rlnum];
1413                                            $rlnum++;
1414                                            $rdsnippet .= "$rdline\n";
1415                                    }
1416                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1417                                    if (my $rduri = $rdattrs->{'@uri'}) {
1418                                            push @docs, new Search::Estraier::ResultDocument(
1419                                                    uri => $rduri,
1420                                                    attrs => $rdattrs,
1421                                                    snippet => $rdsnippet,
1422                                                    keywords => $rdvector,
1423                                            );
1424                                    }
1425                            }
1426                            $snum = $lnum;
1427                            #warn "### $line\n";
1428                            $isend = 1 if ($line =~ /:END$/);
1429                    }
1430    
1431            }
1432    
1433            if (! $isend) {
1434                    warn "received result doesn't have :END\n$resbody";
1435                    return;
1436            }
1437    
1438            #warn Dumper(\@docs, $hints);
1439    
1440            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1441  }  }
1442    
1443    
1444  =head2 cond_to_query  =head2 cond_to_query
1445    
1446    my $args = $node->cond_to_query( $cond );  Return URI encoded string generated from Search::Estraier::Condition
1447    
1448      my $args = $node->cond_to_query( $cond, $depth );
1449    
1450  =cut  =cut
1451    
# Line 1187  sub cond_to_query { Line 1454  sub cond_to_query {
1454    
1455          my $cond = shift || return;          my $cond = shift || return;
1456          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'));
1457            my $depth = shift;
1458    
1459          my @args;          my @args;
1460    
# Line 1196  sub cond_to_query { Line 1464  sub cond_to_query {
1464    
1465          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1466                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1467                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1468                  }                  }
1469          }          }
1470    
# Line 1214  sub cond_to_query { Line 1482  sub cond_to_query {
1482                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1483          }          }
1484    
1485          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1486          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1487          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1488          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
# Line 1225  sub cond_to_query { Line 1493  sub cond_to_query {
1493    
1494  =head2 shuttle_url  =head2 shuttle_url
1495    
1496  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
1497  master.  master.
1498    
1499    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1500    
1501  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
1502  body will be saved within object.  body will be saved within object.
1503    
1504  =cut  =cut
1505    
1506    use LWP::UserAgent;
1507    
1508  sub shuttle_url {  sub shuttle_url {
1509          my $self = shift;          my $self = shift;
1510    
1511          my ($url, $content_type, $reqbody, $resbody) = @_;          my ($url, $content_type, $reqbody, $resbody, $croak_on_error) = @_;
1512    
1513            $croak_on_error = $self->{croak_on_error} unless defined($croak_on_error);
1514    
1515          $self->{status} = -1;          $self->{status} = -1;
1516    
# Line 1253  sub shuttle_url { Line 1525  sub shuttle_url {
1525                  return -1;                  return -1;
1526          }          }
1527    
1528          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1529            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1530    
1531          if ($self->{pxhost}) {          my $req;
1532                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1533                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1534            } else {
1535                    $req = HTTP::Request->new(GET => $url);
1536          }          }
1537    
1538          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1539            $req->headers->header( 'Connection', 'close' );
1540            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1541            $req->content_type( $content_type );
1542    
1543          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1544    
1545          if ($reqbody) {          if ($reqbody) {
1546                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1547          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1548          }          }
1549    
1550          $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,  
         );  
1551    
1552          if (! $sock) {          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1553                  carp "can't open socket to $host:$port";  
1554                  return -1;          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1555    
1556            if (! $res->is_success) {
1557                    if ($croak_on_error) {
1558                            croak("can't get $url: ",$res->status_line);
1559                    } else {
1560                            return -1;
1561                    }
1562          }          }
1563    
1564          warn $headers if ($self->{debug});          $$resbody .= $res->content;
1565    
1566          print $sock $headers or          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1567    
1568          if ($reqbody) {          return $self->{status};
1569                  warn "$reqbody\n" if ($self->{debug});  }
1570                  print $sock $reqbody or  
1571                          carp "can't send request body to network:\n$$reqbody\n" and return -1;  
1572    =head2 set_snippet_width
1573    
1574    Set width of snippets in results
1575    
1576      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1577    
1578    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1579    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1580    
1581    C<$hwidth> specified width of strings from beginning of string. Default
1582    value is C<96>. Negative or zero value keep previous value.
1583    
1584    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1585    If negative of zero value is provided previous value is kept unchanged.
1586    
1587    =cut
1588    
1589    sub set_snippet_width {
1590            my $self = shift;
1591    
1592            my ($wwidth, $hwidth, $awidth) = @_;
1593            $self->{wwidth} = $wwidth;
1594            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1595            $self->{awidth} = $awidth if ($awidth >= 0);
1596    }
1597    
1598    
1599    =head2 set_user
1600    
1601    Manage users of node
1602    
1603      $node->set_user( 'name', $mode );
1604    
1605    C<$mode> can be one of:
1606    
1607    =over 4
1608    
1609    =item 0
1610    
1611    delete account
1612    
1613    =item 1
1614    
1615    set administrative right for user
1616    
1617    =item 2
1618    
1619    set user account as guest
1620    
1621    =back
1622    
1623    Return true on success, otherwise false.
1624    
1625    =cut
1626    
1627    sub set_user {
1628            my $self = shift;
1629            my ($name, $mode) = @_;
1630    
1631            return unless ($self->{url});
1632            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1633    
1634            $self->shuttle_url( $self->{url} . '/_set_user',
1635                    'text/plain',
1636                    'name=' . uri_escape($name) . '&mode=' . $mode,
1637                    undef
1638            ) == 200;
1639    }
1640    
1641    
1642    =head2 set_link
1643    
1644    Manage node links
1645    
1646      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1647    
1648    If C<$credit> is negative, link is removed.
1649    
1650    =cut
1651    
1652    sub set_link {
1653            my $self = shift;
1654            my ($url, $label, $credit) = @_;
1655    
1656            return unless ($self->{url});
1657            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1658    
1659            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1660            $reqbody .= '&credit=' . $credit if ($credit > 0);
1661    
1662            if ($self->shuttle_url( $self->{url} . '/_set_link',
1663                    'application/x-www-form-urlencoded',
1664                    $reqbody,
1665                    undef
1666            ) == 200) {
1667                    # refresh node info after adding link
1668                    $self->_set_info;
1669                    return 1;
1670          }          }
1671    }
1672    
1673          my $line = <$sock>;  =head2 admins
         chomp($line);  
         my ($schema, $res_status, undef) = split(/  */, $line, 3);  
         return if ($schema !~ /^HTTP/ || ! $res_status);  
   
         $self->{status} = $res_status;  
         warn "## response status: $res_status\n" if ($self->{debug});  
   
         # skip rest of headers  
         $line = <$sock>;  
         while ($line) {  
                 $line = <$sock>;  
                 $line =~ s/[\r\n]+$//;  
                 warn "## ", $line || 'NULL', " ##\n" if ($self->{debug});  
         };  
1674    
1675          # read body   my @admins = @{ $node->admins };
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1676    
1677          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});  Return array of users with admin rights on node
1678    
1679          return $self->{status};  =cut
1680    
1681    sub admins {
1682            my $self = shift;
1683            $self->_set_info unless ($self->{name});
1684            return $self->{admins};
1685  }  }
1686    
1687    =head2 guests
1688    
1689     my @guests = @{ $node->guests };
1690    
1691  =head2 set_info  Return array of users with guest rights on node
1692    
1693    =cut
1694    
1695    sub guests {
1696            my $self = shift;
1697            $self->_set_info unless ($self->{name});
1698            return $self->{guests};
1699    }
1700    
1701    =head2 links
1702    
1703     my $links = @{ $node->links };
1704    
1705    Return array of links for this node
1706    
1707    =cut
1708    
1709    sub links {
1710            my $self = shift;
1711            $self->_set_info unless ($self->{name});
1712            return $self->{links};
1713    }
1714    
1715    
1716    =head1 PRIVATE METHODS
1717    
1718    You could call those directly, but you don't have to. I hope.
1719    
1720    =head2 _set_info
1721    
1722  Set information for node  Set information for node
1723    
1724    $node->set_info;    $node->_set_info;
1725    
1726  =cut  =cut
1727    
1728  sub set_info {  sub _set_info {
1729          my $self = shift;          my $self = shift;
1730    
1731          $self->{status} = -1;          $self->{status} = -1;
# Line 1358  sub set_info { Line 1740  sub set_info {
1740    
1741          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1742    
1743          chomp($resbody);          my @lines = split(/[\r\n]/,$resbody);
1744            
1745          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1746                  split(/\t/, $resbody, 5);                  split(/\t/, shift @lines, 5);
1747    
1748            return $resbody unless (@lines);
1749    
1750            shift @lines;
1751    
1752            while(my $admin = shift @lines) {
1753                    push @{$self->{admins}}, $admin;
1754            }
1755            
1756            while(my $guest = shift @lines) {
1757                    push @{$self->{guests}}, $guest;
1758            }
1759    
1760            while(my $link = shift @lines) {
1761                    push @{$self->{links}}, $link;
1762            }
1763    
1764            return $resbody;
1765    
1766  }  }
1767    
Legend:
Removed from v.51  
changed lines
  Added in v.108
  ViewVC Help
Powered by ViewVC 1.1.26