/[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 53 by dpavlin, Fri Jan 6 14:39:45 2006 UTC revision 102 by dpavlin, Sat Jan 28 19:46:20 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.04_1';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node(
21                    url => 'http://localhost:1978/node/test',
22                    user => 'admin',
23                    passwd => 'admin'
24            );
25    
26            # create document
27            my $doc = new Search::Estraier::Document;
28    
29            # add attributes
30            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
31            $doc->add_attr('@title', "Over the Rainbow");
32    
33            # add body text to document
34            $doc->add_text("Somewhere over the rainbow.  Way up high.");
35            $doc->add_text("There's a land that I heard of once in a lullaby.");
36    
37            die "error: ", $node->status,"\n" unless (eval { $node->put_doc($doc) });
38    
39    =head2 Simple searcher
40    
41            use Search::Estraier;
42    
43            # create and configure node
44            my $node = new Search::Estraier::Node(
45                    url => 'http://localhost:1978/node/test',
46                    user => 'admin',
47                    passwd => 'admin',
48                    croak_on_error => 1,
49            );
50    
51            # create condition
52            my $cond = new Search::Estraier::Condition;
53    
54            # set search phrase
55            $cond->set_phrase("rainbow AND lullaby");
56    
57            my $nres = $node->search($cond, 0);
58    
59            if (defined($nres)) {
60                    print "Got ", $nres->hits, " results\n";
61    
62                    # for each document in results
63                    for my $i ( 0 ... $nres->doc_num - 1 ) {
64                            # get result document
65                            my $rdoc = $nres->get_doc($i);
66                            # display attribte
67                            print "URI: ", $rdoc->attr('@uri'),"\n";
68                            print "Title: ", $rdoc->attr('@title'),"\n";
69                            print $rdoc->snippet,"\n";
70                    }
71            } else {
72                    die "error: ", $node->status,"\n";
73            }
74    
75  =head1 DESCRIPTION  =head1 DESCRIPTION
76    
# Line 25  or Hyper Estraier development files on t Line 82  or Hyper Estraier development files on t
82  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
83  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
84    
85    There are few examples in C<scripts> directory of this distribution.
86    
87  =cut  =cut
88    
89  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 100  Remove multiple whitespaces from string,
100  =cut  =cut
101    
102  sub _s {  sub _s {
103          my $text = $_[1] || return;          my $text = $_[1];
104            return unless defined($text);
105          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
106          $text =~ s/^\s+//;          $text =~ s/^\s+//;
107          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 166  sub new {
166                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
167                                  $in_text = 1;                                  $in_text = 1;
168                                  next;                                  next;
169                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
170                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
171                                  next;                                  next;
172                          }                          }
173    
174                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
175                  }                  }
176          }          }
177    
# Line 205  Returns array with attribute names from Line 265  Returns array with attribute names from
265    
266  sub attr_names {  sub attr_names {
267          my $self = shift;          my $self = shift;
268          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
269            #croak "attr_names return array, not scalar" if (! wantarray);
270          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
271  }  }
272    
# Line 221  Returns value of an attribute. Line 282  Returns value of an attribute.
282  sub attr {  sub attr {
283          my $self = shift;          my $self = shift;
284          my $name = shift;          my $name = shift;
285            return unless (defined($name) && $self->{attrs});
286          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
287  }  }
288    
289    
# Line 236  Returns array with text sentences. Line 297  Returns array with text sentences.
297    
298  sub texts {  sub texts {
299          my $self = shift;          my $self = shift;
300          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
301          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
302  }  }
303    
304    
# Line 251  Return whole text as single scalar. Line 312  Return whole text as single scalar.
312    
313  sub cat_texts {  sub cat_texts {
314          my $self = shift;          my $self = shift;
315          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
316  }  }
317    
318    
# Line 268  sub dump_draft { Line 329  sub dump_draft {
329          my $draft;          my $draft;
330    
331          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
332                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
333                    $draft .= $attr_name . '=' . $v . "\n";
334          }          }
335    
336          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 378  sub delete {
378    
379  package Search::Estraier::Condition;  package Search::Estraier::Condition;
380    
381  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
382    
383  use Search::Estraier;  use Search::Estraier;
384  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 456  sub set_max {
456    
457  =head2 set_options  =head2 set_options
458    
459    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
460    
461      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
462    
463    Possible options are:
464    
465    =over 8
466    
467    =item SURE
468    
469    check every N-gram
470    
471    =item USUAL
472    
473    check every second N-gram
474    
475    =item FAST
476    
477    check every third N-gram
478    
479    =item AGITO
480    
481    check every fourth N-gram
482    
483    =item NOIDF
484    
485    don't perform TF-IDF tuning
486    
487    =item SIMPLE
488    
489    use simplified query phrase
490    
491    =back
492    
493    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
494    options;
495    
496    This option changed in version C<0.04> of this module. It's backwards compatibile.
497    
498  =cut  =cut
499    
500  my $options = {  my $options = {
         # check N-gram keys skipping by three  
501          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
502          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
503          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
504          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
505          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
506          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
507  };  };
508    
509  sub set_options {  sub set_options {
510          my $self = shift;          my $self = shift;
511          my $option = shift;          my $opt = 0;
512          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
513          $self->{options} ||= $options->{$option};                  my $mask;
514                    unless ($mask = $options->{$option}) {
515                            if ($option eq '1') {
516                                    next;
517                            } else {
518                                    croak "unknown option $option";
519                            }
520                    }
521                    $opt += $mask;
522            }
523            $self->{options} = $opt;
524  }  }
525    
526    
# Line 460  Return search result attrs. Line 563  Return search result attrs.
563  sub attrs {  sub attrs {
564          my $self = shift;          my $self = shift;
565          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
566          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
567  }  }
568    
569    
# Line 524  sub new { Line 627  sub new {
627          my $self = {@_};          my $self = {@_};
628          bless($self, $class);          bless($self, $class);
629    
630          foreach my $f (qw/uri attrs snippet keywords/) {          croak "missing uri for ResultDocument" unless defined($self->{uri});
                 croak "missing $f for ResultDocument" unless defined($self->{$f});  
         }  
631    
632          $self ? return $self : return undef;          $self ? return $self : return undef;
633  }  }
# Line 641  Return number of documents Line 742  Return number of documents
742    
743    print $res->doc_num;    print $res->doc_num;
744    
745    This will return real number of documents (limited by C<max>).
746    If you want to get total number of hits, see C<hits>.
747    
748  =cut  =cut
749    
750  sub doc_num {  sub doc_num {
# Line 672  sub get_doc { Line 776  sub get_doc {
776    
777  Return specific hint from results.  Return specific hint from results.
778    
779    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
780    
781  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
782  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 789  sub hint {
789          return $self->{hints}->{$key};          return $self->{hints}->{$key};
790  }  }
791    
792    =head2 hits
793    
794    More perlish version of C<hint>. This one returns hash.
795    
796      my %hints = $res->hints;
797    
798    =cut
799    
800    sub hints {
801            my $self = shift;
802            return $self->{hints};
803    }
804    
805    =head2 hits
806    
807    Syntaxtic sugar for total number of hits for this query
808    
809      print $res->hits;
810    
811    It's same as
812    
813      print $res->hint('HIT');
814    
815    but shorter.
816    
817    =cut
818    
819    sub hits {
820            my $self = shift;
821            return $self->{hints}->{'HIT'} || 0;
822    }
823    
824  package Search::Estraier::Node;  package Search::Estraier::Node;
825    
# Line 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 1095  sub _fetch_doc { Line 1267  sub _fetch_doc {
1267    
1268  sub name {  sub name {
1269          my $self = shift;          my $self = shift;
1270          $self->set_info unless ($self->{name});          $self->_set_info unless ($self->{name});
1271          return $self->{name};          return $self->{name};
1272  }  }
1273    
# Line 1108  sub name { Line 1280  sub name {
1280    
1281  sub label {  sub label {
1282          my $self = shift;          my $self = shift;
1283          $self->set_info unless ($self->{label});          $self->_set_info unless ($self->{label});
1284          return $self->{label};          return $self->{label};
1285  }  }
1286    
# Line 1121  sub label { Line 1293  sub label {
1293    
1294  sub doc_num {  sub doc_num {
1295          my $self = shift;          my $self = shift;
1296          $self->set_info if ($self->{dnum} < 0);          $self->_set_info if ($self->{dnum} < 0);
1297          return $self->{dnum};          return $self->{dnum};
1298  }  }
1299    
# Line 1134  sub doc_num { Line 1306  sub doc_num {
1306    
1307  sub word_num {  sub word_num {
1308          my $self = shift;          my $self = shift;
1309          $self->set_info if ($self->{wnum} < 0);          $self->_set_info if ($self->{wnum} < 0);
1310          return $self->{wnum};          return $self->{wnum};
1311  }  }
1312    
# Line 1147  sub word_num { Line 1319  sub word_num {
1319    
1320  sub size {  sub size {
1321          my $self = shift;          my $self = shift;
1322          $self->set_info if ($self->{size} < 0);          $self->_set_info if ($self->{size} < 0);
1323          return $self->{size};          return $self->{size};
1324  }  }
1325    
# Line 1176  sub search { Line 1348  sub search {
1348    
1349          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1350                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1351                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1352                  \$resbody,                  \$resbody,
1353          );          );
1354          return if ($rv != 200);          return if ($rv != 200);
# Line 1268  sub search { Line 1440  sub search {
1440    
1441  =head2 cond_to_query  =head2 cond_to_query
1442    
1443    my $args = $node->cond_to_query( $cond );  Return URI encoded string generated from Search::Estraier::Condition
1444    
1445      my $args = $node->cond_to_query( $cond, $depth );
1446    
1447  =cut  =cut
1448    
# Line 1277  sub cond_to_query { Line 1451  sub cond_to_query {
1451    
1452          my $cond = shift || return;          my $cond = shift || return;
1453          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'));
1454            my $depth = shift;
1455    
1456          my @args;          my @args;
1457    
# Line 1286  sub cond_to_query { Line 1461  sub cond_to_query {
1461    
1462          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1463                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1464                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1465                  }                  }
1466          }          }
1467    
# Line 1304  sub cond_to_query { Line 1479  sub cond_to_query {
1479                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1480          }          }
1481    
1482          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1483          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1484          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1485          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
# Line 1315  sub cond_to_query { Line 1490  sub cond_to_query {
1490    
1491  =head2 shuttle_url  =head2 shuttle_url
1492    
1493  This is method which uses C<IO::Socket::INET> to communicate with Hyper Estraier node  This is method which uses C<LWP::UserAgent> to communicate with Hyper Estraier node
1494  master.  master.
1495    
1496    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
# Line 1325  body will be saved within object. Line 1500  body will be saved within object.
1500    
1501  =cut  =cut
1502    
1503    use LWP::UserAgent;
1504    
1505  sub shuttle_url {  sub shuttle_url {
1506          my $self = shift;          my $self = shift;
1507    
# Line 1343  sub shuttle_url { Line 1520  sub shuttle_url {
1520                  return -1;                  return -1;
1521          }          }
1522    
1523          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1524            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1525    
1526          if ($self->{pxhost}) {          my $req;
1527                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1528                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1529            } else {
1530                    $req = HTTP::Request->new(GET => $url);
1531          }          }
1532    
1533          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1534            $req->headers->header( 'Connection', 'close' );
1535            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1536            $req->content_type( $content_type );
1537    
1538          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1539    
1540          if ($reqbody) {          if ($reqbody) {
1541                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1542          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1543          }          }
1544    
1545          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          my $res = $ua->request($req) || croak "can't make request to $url: $!";
         $headers .= "Connection: close\r\n";  
         $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";  
         $headers .= "Content-Type: $content_type\r\n";  
         $headers .= "Authorization: Basic $self->{auth}\r\n";  
         my $len = 0;  
         {  
                 use bytes;  
                 $len = length($reqbody) if ($reqbody);  
         }  
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
   
         my $sock = IO::Socket::INET->new(  
                 PeerAddr        => $host,  
                 PeerPort        => $port,  
                 Proto           => 'tcp',  
                 Timeout         => $self->{timeout} || 90,  
         );  
   
         if (! $sock) {  
                 carp "can't open socket to $host:$port";  
                 return -1;  
         }  
1546    
1547          warn $headers if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1548    
1549          print $sock $headers or          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1550    
1551          if ($reqbody) {          if (! $res->is_success) {
1552                  warn "$reqbody\n" if ($self->{debug});                  if ($self->{croak_on_error}) {
1553                  print $sock $reqbody or                          croak("can't get $url: ",$res->status_line);
1554                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  } else {
1555                            return -1;
1556                    }
1557          }          }
1558    
1559          my $line = <$sock>;          $$resbody .= $res->content;
         chomp($line);  
         my ($schema, $res_status, undef) = split(/  */, $line, 3);  
         return if ($schema !~ /^HTTP/ || ! $res_status);  
   
         $self->{status} = $res_status;  
         warn "## response status: $res_status\n" if ($self->{debug});  
   
         # skip rest of headers  
         $line = <$sock>;  
         while ($line) {  
                 $line = <$sock>;  
                 $line =~ s/[\r\n]+$//;  
                 warn "## ", $line || 'NULL', " ##\n" if ($self->{debug});  
         };  
   
         # read body  
         $len = 0;  
         do {  
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1560    
1561          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1562    
# Line 1425  sub shuttle_url { Line 1564  sub shuttle_url {
1564  }  }
1565    
1566    
1567  =head2 set_info  =head2 set_snippet_width
1568    
1569    Set width of snippets in results
1570    
1571      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1572    
1573    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1574    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1575    
1576    C<$hwidth> specified width of strings from beginning of string. Default
1577    value is C<96>. Negative or zero value keep previous value.
1578    
1579    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1580    If negative of zero value is provided previous value is kept unchanged.
1581    
1582    =cut
1583    
1584    sub set_snippet_width {
1585            my $self = shift;
1586    
1587            my ($wwidth, $hwidth, $awidth) = @_;
1588            $self->{wwidth} = $wwidth;
1589            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1590            $self->{awidth} = $awidth if ($awidth >= 0);
1591    }
1592    
1593    
1594    =head2 set_user
1595    
1596    Manage users of node
1597    
1598      $node->set_user( 'name', $mode );
1599    
1600    C<$mode> can be one of:
1601    
1602    =over 4
1603    
1604    =item 0
1605    
1606    delete account
1607    
1608    =item 1
1609    
1610    set administrative right for user
1611    
1612    =item 2
1613    
1614    set user account as guest
1615    
1616    =back
1617    
1618    Return true on success, otherwise false.
1619    
1620    =cut
1621    
1622    sub set_user {
1623            my $self = shift;
1624            my ($name, $mode) = @_;
1625    
1626            return unless ($self->{url});
1627            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1628    
1629            $self->shuttle_url( $self->{url} . '/_set_user',
1630                    'text/plain',
1631                    'name=' . uri_escape($name) . '&mode=' . $mode,
1632                    undef
1633            ) == 200;
1634    }
1635    
1636    
1637    =head2 set_link
1638    
1639    Manage node links
1640    
1641      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1642    
1643    If C<$credit> is negative, link is removed.
1644    
1645    =cut
1646    
1647    sub set_link {
1648            my $self = shift;
1649            my ($url, $label, $credit) = @_;
1650    
1651            return unless ($self->{url});
1652            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1653    
1654            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1655            $reqbody .= '&credit=' . $credit if ($credit > 0);
1656    
1657            $self->shuttle_url( $self->{url} . '/_set_link',
1658                    'application/x-www-form-urlencoded',
1659                    $reqbody,
1660                    undef
1661            ) == 200;
1662    }
1663    
1664    
1665    =head1 PRIVATE METHODS
1666    
1667    You could call those directly, but you don't have to. I hope.
1668    
1669    =head2 _set_info
1670    
1671  Set information for node  Set information for node
1672    
1673    $node->set_info;    $node->_set_info;
1674    
1675  =cut  =cut
1676    
1677  sub set_info {  sub _set_info {
1678          my $self = shift;          my $self = shift;
1679    
1680          $self->{status} = -1;          $self->{status} = -1;
# Line 1448  sub set_info { Line 1689  sub set_info {
1689    
1690          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1691    
1692          chomp($resbody);          # it seems that response can have multiple line endings
1693            $resbody =~ s/[\r\n]+$//;
1694    
1695          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1696                  split(/\t/, $resbody, 5);                  split(/\t/, $resbody, 5);
Legend:
Removed from v.53  
changed lines
  Added in v.102
  ViewVC Help
Powered by ViewVC 1.1.26