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