/[Search-Estraier]/trunk/lib/Search/Estraier.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/Search/Estraier.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 47 by dpavlin, Fri Jan 6 01:51:28 2006 UTC revision 91 by dpavlin, Thu Jan 26 01:53:58 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.00';  our $VERSION = '0.04_1';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 12  Search::Estraier - pure perl module to u Line 12  Search::Estraier - pure perl module to u
12    
13  =head1 SYNOPSIS  =head1 SYNOPSIS
14    
15    use Search::Estraier;  =head2 Simple indexer
16    my $est = new Search::Estraier();  
17            use Search::Estraier;
18    
19            # create and configure node
20            my $node = new Search::Estraier::Node;
21            $node->set_url("http://localhost:1978/node/test");
22            $node->set_auth("admin","admin");
23    
24            # create document
25            my $doc = new Search::Estraier::Document;
26    
27            # add attributes
28            $doc->add_attr('@uri', "http://estraier.gov/example.txt");
29            $doc->add_attr('@title', "Over the Rainbow");
30    
31            # add body text to document
32            $doc->add_text("Somewhere over the rainbow.  Way up high.");
33            $doc->add_text("There's a land that I heard of once in a lullaby.");
34    
35            die "error: ", $node->status,"\n" unless ($node->put_doc($doc));
36    
37    =head2 Simple searcher
38    
39            use Search::Estraier;
40    
41            # create and configure node
42            my $node = new Search::Estraier::Node;
43            $node->set_url("http://localhost:1978/node/test");
44            $node->set_auth("admin","admin");
45    
46            # create condition
47            my $cond = new Search::Estraier::Condition;
48    
49            # set search phrase
50            $cond->set_phrase("rainbow AND lullaby");
51    
52            my $nres = $node->search($cond, 0);
53            if (defined($nres)) {
54                    # for each document in results
55                    for my $i ( 0 ... $nres->doc_num - 1 ) {
56                            # get result document
57                            my $rdoc = $nres->get_doc($i);
58                            # display attribte
59                            print "URI: ", $rdoc->attr('@uri'),"\n";
60                            print "Title: ", $rdoc->attr('@title'),"\n";
61                            print $rdoc->snippet,"\n";
62                    }
63            } else {
64                    die "error: ", $node->status,"\n";
65            }
66    
67  =head1 DESCRIPTION  =head1 DESCRIPTION
68    
# Line 25  or Hyper Estraier development files on t Line 74  or Hyper Estraier development files on t
74  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
75  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
76    
77    There are few examples in C<scripts> directory of this distribution.
78    
79  =cut  =cut
80    
81  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 106  sub new { Line 157  sub new {
157                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
158                                  $in_text = 1;                                  $in_text = 1;
159                                  next;                                  next;
160                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
161                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
162                                  next;                                  next;
163                          }                          }
164    
165                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
166                  }                  }
167          }          }
168    
# Line 205  Returns array with attribute names from Line 256  Returns array with attribute names from
256    
257  sub attr_names {  sub attr_names {
258          my $self = shift;          my $self = shift;
259          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
260            #croak "attr_names return array, not scalar" if (! wantarray);
261          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
262  }  }
263    
# Line 221  Returns value of an attribute. Line 273  Returns value of an attribute.
273  sub attr {  sub attr {
274          my $self = shift;          my $self = shift;
275          my $name = shift;          my $name = shift;
276            return unless (defined($name) && $self->{attrs});
277          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
278  }  }
279    
280    
# Line 236  Returns array with text sentences. Line 288  Returns array with text sentences.
288    
289  sub texts {  sub texts {
290          my $self = shift;          my $self = shift;
291          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
292          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
293  }  }
294    
295    
# Line 251  Return whole text as single scalar. Line 303  Return whole text as single scalar.
303    
304  sub cat_texts {  sub cat_texts {
305          my $self = shift;          my $self = shift;
306          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
307  }  }
308    
309    
# Line 460  Return search result attrs. Line 512  Return search result attrs.
512  sub attrs {  sub attrs {
513          my $self = shift;          my $self = shift;
514          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
515          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
516  }  }
517    
518    
# Line 524  sub new { Line 576  sub new {
576          my $self = {@_};          my $self = {@_};
577          bless($self, $class);          bless($self, $class);
578    
579          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});  
         }  
580    
581          $self ? return $self : return undef;          $self ? return $self : return undef;
582  }  }
# Line 645  Return number of documents Line 695  Return number of documents
695    
696  sub doc_num {  sub doc_num {
697          my $self = shift;          my $self = shift;
698          return $#{$self->{docs}};          return $#{$self->{docs}} + 1;
699  }  }
700    
701    
# Line 685  sub hint { Line 735  sub hint {
735          return $self->{hints}->{$key};          return $self->{hints}->{$key};
736  }  }
737    
738    =head2 hints
739    
740    More perlish version of C<hint>. This one returns hash.
741    
742      my %hints = $rec->hints;
743    
744    =cut
745    
746    sub hints {
747            my $self = shift;
748            return $self->{hints};
749    }
750    
751  package Search::Estraier::Node;  package Search::Estraier::Node;
752    
# Line 692  use Carp qw/carp croak confess/; Line 754  use Carp qw/carp croak confess/;
754  use URI;  use URI;
755  use MIME::Base64;  use MIME::Base64;
756  use IO::Socket::INET;  use IO::Socket::INET;
757    use URI::Escape qw/uri_escape/;
758    
759  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
760    
# Line 699  use IO::Socket::INET; Line 762  use IO::Socket::INET;
762    
763    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
764    
765    or optionally with C<url> as parametar
766    
767      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
768    
769    or in more verbose form
770    
771      my $node = new Search::HyperEstraier::Node(
772            url => 'http://localhost:1978/node/test',
773            debug => 1,
774            croak_on_error => 1
775      );
776    
777    with following arguments:
778    
779    =over 4
780    
781    =item url
782    
783    URL to node
784    
785    =item debug
786    
787    dumps a B<lot> of debugging output
788    
789    =item croak_on_error
790    
791    very helpful during development. It will croak on all errors instead of
792    silently returning C<-1> (which is convention of Hyper Estraier API in other
793    languages).
794    
795    =back
796    
797  =cut  =cut
798    
799  sub new {  sub new {
# Line 716  sub new { Line 811  sub new {
811          };          };
812          bless($self, $class);          bless($self, $class);
813    
814          if (@_) {          if ($#_ == 0) {
815                  $self->{debug} = shift;                  $self->{url} = shift;
816                  warn "## Node debug on\n";          } else {
817                    my $args = {@_};
818    
819                    %$self = ( %$self, @_ );
820    
821                    warn "## Node debug on\n" if ($self->{debug});
822          }          }
823    
824          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 966  sub out_doc_by_uri {
966          return unless ($self->{url});          return unless ($self->{url});
967          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
968                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
969                  "uri=$uri",                  "uri=" . uri_escape($uri),
970                  undef                  undef
971          ) == 200;          ) == 200;
972  }  }
# Line 928  sub get_doc_by_uri { Line 1028  sub get_doc_by_uri {
1028  }  }
1029    
1030    
1031    =head2 get_doc_attr
1032    
1033    Retrieve the value of an atribute from object
1034    
1035      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
1036            die "can't get document attribute";
1037    
1038    =cut
1039    
1040    sub get_doc_attr {
1041            my $self = shift;
1042            my ($id,$name) = @_;
1043            return unless ($id && $name);
1044            return $self->_fetch_doc( id => $id, attr => $name );
1045    }
1046    
1047    
1048    =head2 get_doc_attr_by_uri
1049    
1050    Retrieve the value of an atribute from object
1051    
1052      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1053            die "can't get document attribute";
1054    
1055    =cut
1056    
1057    sub get_doc_attr_by_uri {
1058            my $self = shift;
1059            my ($uri,$name) = @_;
1060            return unless ($uri && $name);
1061            return $self->_fetch_doc( uri => $uri, attr => $name );
1062    }
1063    
1064    
1065  =head2 etch_doc  =head2 etch_doc
1066    
1067  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1070  Exctract document keywords
1070    
1071  =cut  =cut
1072    
1073  sub erch_doc {  sub etch_doc {
1074          my $self = shift;          my $self = shift;
1075          my $id = shift || return;          my $id = shift || return;
1076          return $self->_fetch_doc( id => $id, etch => 1 );          return $self->_fetch_doc( id => $id, etch => 1 );
# Line 987  C<etch_doc>, C<etch_doc_by_uri>. Line 1121  C<etch_doc>, C<etch_doc_by_uri>.
1121   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1122   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1123    
1124     # to get document attrubute add attr
1125     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1126     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1127    
1128   # more general form which allows implementation of   # more general form which allows implementation of
1129   # uri_to_id   # uri_to_id
1130   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1149  sub _fetch_doc {
1149                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);                  croak "id must be numberm not '$a->{id}'" unless ($a->{id} =~ m/^\d+$/);
1150                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1151          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1152                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1153          } else {          } else {
1154                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1155          }          }
1156    
1157            if ($a->{attr}) {
1158                    $path = '/get_doc_attr';
1159                    $arg .= '&attr=' . uri_escape($a->{attr});
1160                    $a->{chomp_resbody} = 1;
1161            }
1162    
1163          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1164                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1165                  $arg,                  $arg,
# Line 1042  sub _fetch_doc { Line 1186  sub _fetch_doc {
1186  }  }
1187    
1188    
1189    =head2 name
1190    
1191      my $node_name = $node->name;
1192    
1193    =cut
1194    
1195    sub name {
1196            my $self = shift;
1197            $self->_set_info unless ($self->{name});
1198            return $self->{name};
1199    }
1200    
1201    
1202    =head2 label
1203    
1204      my $node_label = $node->label;
1205    
1206    =cut
1207    
1208    sub label {
1209            my $self = shift;
1210            $self->_set_info unless ($self->{label});
1211            return $self->{label};
1212    }
1213    
1214    
1215    =head2 doc_num
1216    
1217      my $documents_in_node = $node->doc_num;
1218    
1219    =cut
1220    
1221    sub doc_num {
1222            my $self = shift;
1223            $self->_set_info if ($self->{dnum} < 0);
1224            return $self->{dnum};
1225    }
1226    
1227    
1228    =head2 word_num
1229    
1230      my $words_in_node = $node->word_num;
1231    
1232    =cut
1233    
1234    sub word_num {
1235            my $self = shift;
1236            $self->_set_info if ($self->{wnum} < 0);
1237            return $self->{wnum};
1238    }
1239    
1240    
1241    =head2 size
1242    
1243      my $node_size = $node->size;
1244    
1245    =cut
1246    
1247    sub size {
1248            my $self = shift;
1249            $self->_set_info if ($self->{size} < 0);
1250            return $self->{size};
1251    }
1252    
1253    
1254    =head2 search
1255    
1256    Search documents which match condition
1257    
1258      my $nres = $node->search( $cond, $depth );
1259    
1260    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1261    depth for meta search.
1262    
1263    Function results C<Search::Estraier::NodeResult> object.
1264    
1265    =cut
1266    
1267    sub search {
1268            my $self = shift;
1269            my ($cond, $depth) = @_;
1270            return unless ($cond && defined($depth) && $self->{url});
1271            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1272            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1273    
1274            my $resbody;
1275    
1276            my $rv = $self->shuttle_url( $self->{url} . '/search',
1277                    'application/x-www-form-urlencoded',
1278                    $self->cond_to_query( $cond, $depth ),
1279                    \$resbody,
1280            );
1281            return if ($rv != 200);
1282    
1283            my (@docs, $hints);
1284    
1285            my @lines = split(/\n/, $resbody);
1286            return unless (@lines);
1287    
1288            my $border = $lines[0];
1289            my $isend = 0;
1290            my $lnum = 1;
1291    
1292            while ( $lnum <= $#lines ) {
1293                    my $line = $lines[$lnum];
1294                    $lnum++;
1295    
1296                    #warn "## $line\n";
1297                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1298                            $isend = $1;
1299                            last;
1300                    }
1301    
1302                    if ($line =~ /\t/) {
1303                            my ($k,$v) = split(/\t/, $line, 2);
1304                            $hints->{$k} = $v;
1305                    }
1306            }
1307    
1308            my $snum = $lnum;
1309    
1310            while( ! $isend && $lnum <= $#lines ) {
1311                    my $line = $lines[$lnum];
1312                    #warn "# $lnum: $line\n";
1313                    $lnum++;
1314    
1315                    if ($line && $line =~ m/^\Q$border\E/) {
1316                            if ($lnum > $snum) {
1317                                    my $rdattrs;
1318                                    my $rdvector;
1319                                    my $rdsnippet;
1320                                    
1321                                    my $rlnum = $snum;
1322                                    while ($rlnum < $lnum - 1 ) {
1323                                            #my $rdline = $self->_s($lines[$rlnum]);
1324                                            my $rdline = $lines[$rlnum];
1325                                            $rlnum++;
1326                                            last unless ($rdline);
1327                                            if ($rdline =~ /^%/) {
1328                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1329                                            } elsif($rdline =~ /=/) {
1330                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1331                                            } else {
1332                                                    confess "invalid format of response";
1333                                            }
1334                                    }
1335                                    while($rlnum < $lnum - 1) {
1336                                            my $rdline = $lines[$rlnum];
1337                                            $rlnum++;
1338                                            $rdsnippet .= "$rdline\n";
1339                                    }
1340                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1341                                    if (my $rduri = $rdattrs->{'@uri'}) {
1342                                            push @docs, new Search::Estraier::ResultDocument(
1343                                                    uri => $rduri,
1344                                                    attrs => $rdattrs,
1345                                                    snippet => $rdsnippet,
1346                                                    keywords => $rdvector,
1347                                            );
1348                                    }
1349                            }
1350                            $snum = $lnum;
1351                            #warn "### $line\n";
1352                            $isend = 1 if ($line =~ /:END$/);
1353                    }
1354    
1355            }
1356    
1357            if (! $isend) {
1358                    warn "received result doesn't have :END\n$resbody";
1359                    return;
1360            }
1361    
1362            #warn Dumper(\@docs, $hints);
1363    
1364            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1365    }
1366    
1367    
1368    =head2 cond_to_query
1369    
1370    Return URI encoded string generated from Search::Estraier::Condition
1371    
1372      my $args = $node->cond_to_query( $cond, $depth );
1373    
1374    =cut
1375    
1376    sub cond_to_query {
1377            my $self = shift;
1378    
1379            my $cond = shift || return;
1380            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1381            my $depth = shift;
1382    
1383            my @args;
1384    
1385            if (my $phrase = $cond->phrase) {
1386                    push @args, 'phrase=' . uri_escape($phrase);
1387            }
1388    
1389            if (my @attrs = $cond->attrs) {
1390                    for my $i ( 0 .. $#attrs ) {
1391                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1392                    }
1393            }
1394    
1395            if (my $order = $cond->order) {
1396                    push @args, 'order=' . uri_escape($order);
1397            }
1398                    
1399            if (my $max = $cond->max) {
1400                    push @args, 'max=' . $max;
1401            } else {
1402                    push @args, 'max=' . (1 << 30);
1403            }
1404    
1405            if (my $options = $cond->options) {
1406                    push @args, 'options=' . $options;
1407            }
1408    
1409            push @args, 'depth=' . $depth if ($depth);
1410            push @args, 'wwidth=' . $self->{wwidth};
1411            push @args, 'hwidth=' . $self->{hwidth};
1412            push @args, 'awidth=' . $self->{awidth};
1413    
1414            return join('&', @args);
1415    }
1416    
1417    
1418  =head2 shuttle_url  =head2 shuttle_url
1419    
1420  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
1421  master.  master.
1422    
1423    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1424    
1425  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
1426  body will be saved within object.  body will be saved within object.
1427    
1428  =cut  =cut
1429    
1430    use LWP::UserAgent;
1431    
1432  sub shuttle_url {  sub shuttle_url {
1433          my $self = shift;          my $self = shift;
1434    
# Line 1074  sub shuttle_url { Line 1447  sub shuttle_url {
1447                  return -1;                  return -1;
1448          }          }
1449    
1450          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1451            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1452    
1453          if ($self->{pxhost}) {          my $req;
1454                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1455                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1456            } else {
1457                    $req = HTTP::Request->new(GET => $url);
1458          }          }
1459    
1460          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1461            $req->headers->header( 'Connection', 'close' );
1462            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1463            $req->content_type( $content_type );
1464    
1465          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1466    
1467          if ($reqbody) {          if ($reqbody) {
1468                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1469          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1470          }          }
1471    
1472          $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;  
         }  
1473    
1474          warn $headers if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1475    
1476          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;  
1477    
1478          if ($reqbody) {          if (! $res->is_success) {
1479                  warn "$reqbody\n" if ($self->{debug});                  if ($self->{croak_on_error}) {
1480                  print $sock $reqbody or                          croak("can't get $url: ",$res->status_line);
1481                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  } else {
1482                            return -1;
1483                    }
1484          }          }
1485    
1486          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);  
1487    
1488          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1489    
1490          return $self->{status};          return $self->{status};
1491  }  }
1492    
1493    
1494    =head2 set_snippet_width
1495    
1496    Set width of snippets in results
1497    
1498      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1499    
1500    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1501    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1502    
1503    C<$hwidth> specified width of strings from beginning of string. Default
1504    value is C<96>. Negative or zero value keep previous value.
1505    
1506    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1507    If negative of zero value is provided previous value is kept unchanged.
1508    
1509    =cut
1510    
1511    sub set_snippet_width {
1512            my $self = shift;
1513    
1514            my ($wwidth, $hwidth, $awidth) = @_;
1515            $self->{wwidth} = $wwidth;
1516            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1517            $self->{awidth} = $awidth if ($awidth >= 0);
1518    }
1519    
1520    
1521    =head2 set_user
1522    
1523    Manage users of node
1524    
1525      $node->set_user( 'name', $mode );
1526    
1527    C<$mode> can be one of:
1528    
1529    =over 4
1530    
1531    =item 0
1532    
1533    delete account
1534    
1535    =item 1
1536    
1537    set administrative right for user
1538    
1539    =item 2
1540    
1541    set user account as guest
1542    
1543    =back
1544    
1545    Return true on success, otherwise false.
1546    
1547    =cut
1548    
1549    sub set_user {
1550            my $self = shift;
1551            my ($name, $mode) = @_;
1552    
1553            return unless ($self->{url});
1554            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1555    
1556            $self->shuttle_url( $self->{url} . '/_set_user',
1557                    'text/plain',
1558                    'name=' . uri_escape($name) . '&mode=' . $mode,
1559                    undef
1560            ) == 200;
1561    }
1562    
1563    
1564    =head2 set_link
1565    
1566    Manage node links
1567    
1568      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1569    
1570    If C<$credit> is negative, link is removed.
1571    
1572    =cut
1573    
1574    sub set_link {
1575            my $self = shift;
1576            my ($url, $label, $credit) = @_;
1577    
1578            return unless ($self->{url});
1579            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1580    
1581            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1582            $reqbody .= '&credit=' . $credit if ($credit > 0);
1583    
1584            $self->shuttle_url( $self->{url} . '/_set_link',
1585                    'application/x-www-form-urlencoded',
1586                    $reqbody,
1587                    undef
1588            ) == 200;
1589    }
1590    
1591    
1592    =head1 PRIVATE METHODS
1593    
1594    You could call those directly, but you don't have to. I hope.
1595    
1596    =head2 _set_info
1597    
1598    Set information for node
1599    
1600      $node->_set_info;
1601    
1602    =cut
1603    
1604    sub _set_info {
1605            my $self = shift;
1606    
1607            $self->{status} = -1;
1608            return unless ($self->{url});
1609    
1610            my $resbody;
1611            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1612                    'text/plain',
1613                    undef,
1614                    \$resbody,
1615            );
1616    
1617            return if ($rv != 200 || !$resbody);
1618    
1619            # it seems that response can have multiple line endings
1620            $resbody =~ s/[\r\n]+$//;
1621    
1622            ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1623                    split(/\t/, $resbody, 5);
1624    
1625    }
1626    
1627  ###  ###
1628    
1629  =head1 EXPORT  =head1 EXPORT
Legend:
Removed from v.47  
changed lines
  Added in v.91
  ViewVC Help
Powered by ViewVC 1.1.26