/[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 74 by dpavlin, Mon Jan 9 15:28:24 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.03';
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 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 692  use Carp qw/carp croak confess/; Line 742  use Carp qw/carp croak confess/;
742  use URI;  use URI;
743  use MIME::Base64;  use MIME::Base64;
744  use IO::Socket::INET;  use IO::Socket::INET;
745    use URI::Escape qw/uri_escape/;
746    
747  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
748    
# Line 699  use IO::Socket::INET; Line 750  use IO::Socket::INET;
750    
751    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
752    
753    or optionally with C<url> as parametar
754    
755      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
756    
757  =cut  =cut
758    
759  sub new {  sub new {
# Line 716  sub new { Line 771  sub new {
771          };          };
772          bless($self, $class);          bless($self, $class);
773    
774          if (@_) {          if ($#_ == 0) {
775                  $self->{debug} = shift;                  $self->{url} = shift;
776                  warn "## Node debug on\n";          } else {
777                    my $args = {@_};
778    
779                    $self->{debug} = $args->{debug};
780                    warn "## Node debug on\n" if ($self->{debug});
781          }          }
782    
783          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 866  sub out_doc_by_uri { Line 925  sub out_doc_by_uri {
925          return unless ($self->{url});          return unless ($self->{url});
926          $self->shuttle_url( $self->{url} . '/out_doc',          $self->shuttle_url( $self->{url} . '/out_doc',
927                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
928                  "uri=$uri",                  "uri=" . uri_escape($uri),
929                  undef                  undef
930          ) == 200;          ) == 200;
931  }  }
# Line 928  sub get_doc_by_uri { Line 987  sub get_doc_by_uri {
987  }  }
988    
989    
990    =head2 get_doc_attr
991    
992    Retrieve the value of an atribute from object
993    
994      my $val = $node->get_doc_attr( document_id, 'attribute_name' ) or
995            die "can't get document attribute";
996    
997    =cut
998    
999    sub get_doc_attr {
1000            my $self = shift;
1001            my ($id,$name) = @_;
1002            return unless ($id && $name);
1003            return $self->_fetch_doc( id => $id, attr => $name );
1004    }
1005    
1006    
1007    =head2 get_doc_attr_by_uri
1008    
1009    Retrieve the value of an atribute from object
1010    
1011      my $val = $node->get_doc_attr_by_uri( document_id, 'attribute_name' ) or
1012            die "can't get document attribute";
1013    
1014    =cut
1015    
1016    sub get_doc_attr_by_uri {
1017            my $self = shift;
1018            my ($uri,$name) = @_;
1019            return unless ($uri && $name);
1020            return $self->_fetch_doc( uri => $uri, attr => $name );
1021    }
1022    
1023    
1024  =head2 etch_doc  =head2 etch_doc
1025    
1026  Exctract document keywords  Exctract document keywords
# Line 936  Exctract document keywords Line 1029  Exctract document keywords
1029    
1030  =cut  =cut
1031    
1032  sub erch_doc {  sub etch_doc {
1033          my $self = shift;          my $self = shift;
1034          my $id = shift || return;          my $id = shift || return;
1035          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 1080  C<etch_doc>, C<etch_doc_by_uri>.
1080   my $doc = $node->_fetch_doc( id => 42, etch => 1 );   my $doc = $node->_fetch_doc( id => 42, etch => 1 );
1081   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );   my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', etch => 1 );
1082    
1083     # to get document attrubute add attr
1084     my $doc = $node->_fetch_doc( id => 42, attr => '@mdate' );
1085     my $doc = $node->_fetch_doc( uri => 'file:///document/uri/42', attr => '@mdate' );
1086    
1087   # more general form which allows implementation of   # more general form which allows implementation of
1088   # uri_to_id   # uri_to_id
1089   my $id = $node->_fetch_doc(   my $id = $node->_fetch_doc(
# Line 1011  sub _fetch_doc { Line 1108  sub _fetch_doc {
1108                  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+$/);
1109                  $arg = 'id=' . $a->{id};                  $arg = 'id=' . $a->{id};
1110          } elsif ($a->{uri}) {          } elsif ($a->{uri}) {
1111                  $arg = 'uri=' . $a->{uri};                  $arg = 'uri=' . uri_escape($a->{uri});
1112          } else {          } else {
1113                  confess "unhandled argument. Need id or uri.";                  confess "unhandled argument. Need id or uri.";
1114          }          }
1115    
1116            if ($a->{attr}) {
1117                    $path = '/get_doc_attr';
1118                    $arg .= '&attr=' . uri_escape($a->{attr});
1119                    $a->{chomp_resbody} = 1;
1120            }
1121    
1122          my $rv = $self->shuttle_url( $self->{url} . $path,          my $rv = $self->shuttle_url( $self->{url} . $path,
1123                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1124                  $arg,                  $arg,
# Line 1042  sub _fetch_doc { Line 1145  sub _fetch_doc {
1145  }  }
1146    
1147    
1148    =head2 name
1149    
1150      my $node_name = $node->name;
1151    
1152    =cut
1153    
1154    sub name {
1155            my $self = shift;
1156            $self->_set_info unless ($self->{name});
1157            return $self->{name};
1158    }
1159    
1160    
1161    =head2 label
1162    
1163      my $node_label = $node->label;
1164    
1165    =cut
1166    
1167    sub label {
1168            my $self = shift;
1169            $self->_set_info unless ($self->{label});
1170            return $self->{label};
1171    }
1172    
1173    
1174    =head2 doc_num
1175    
1176      my $documents_in_node = $node->doc_num;
1177    
1178    =cut
1179    
1180    sub doc_num {
1181            my $self = shift;
1182            $self->_set_info if ($self->{dnum} < 0);
1183            return $self->{dnum};
1184    }
1185    
1186    
1187    =head2 word_num
1188    
1189      my $words_in_node = $node->word_num;
1190    
1191    =cut
1192    
1193    sub word_num {
1194            my $self = shift;
1195            $self->_set_info if ($self->{wnum} < 0);
1196            return $self->{wnum};
1197    }
1198    
1199    
1200    =head2 size
1201    
1202      my $node_size = $node->size;
1203    
1204    =cut
1205    
1206    sub size {
1207            my $self = shift;
1208            $self->_set_info if ($self->{size} < 0);
1209            return $self->{size};
1210    }
1211    
1212    
1213    =head2 search
1214    
1215    Search documents which match condition
1216    
1217      my $nres = $node->search( $cond, $depth );
1218    
1219    C<$cond> is C<Search::Estraier::Condition> object, while <$depth> specifies
1220    depth for meta search.
1221    
1222    Function results C<Search::Estraier::NodeResult> object.
1223    
1224    =cut
1225    
1226    sub search {
1227            my $self = shift;
1228            my ($cond, $depth) = @_;
1229            return unless ($cond && defined($depth) && $self->{url});
1230            croak "cond mush be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1231            croak "depth needs number, not '$depth'" unless ($depth =~ m/^\d+$/);
1232    
1233            my $resbody;
1234    
1235            my $rv = $self->shuttle_url( $self->{url} . '/search',
1236                    'application/x-www-form-urlencoded',
1237                    $self->cond_to_query( $cond, $depth ),
1238                    \$resbody,
1239            );
1240            return if ($rv != 200);
1241    
1242            my (@docs, $hints);
1243    
1244            my @lines = split(/\n/, $resbody);
1245            return unless (@lines);
1246    
1247            my $border = $lines[0];
1248            my $isend = 0;
1249            my $lnum = 1;
1250    
1251            while ( $lnum <= $#lines ) {
1252                    my $line = $lines[$lnum];
1253                    $lnum++;
1254    
1255                    #warn "## $line\n";
1256                    if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
1257                            $isend = $1;
1258                            last;
1259                    }
1260    
1261                    if ($line =~ /\t/) {
1262                            my ($k,$v) = split(/\t/, $line, 2);
1263                            $hints->{$k} = $v;
1264                    }
1265            }
1266    
1267            my $snum = $lnum;
1268    
1269            while( ! $isend && $lnum <= $#lines ) {
1270                    my $line = $lines[$lnum];
1271                    #warn "# $lnum: $line\n";
1272                    $lnum++;
1273    
1274                    if ($line && $line =~ m/^\Q$border\E/) {
1275                            if ($lnum > $snum) {
1276                                    my $rdattrs;
1277                                    my $rdvector;
1278                                    my $rdsnippet;
1279                                    
1280                                    my $rlnum = $snum;
1281                                    while ($rlnum < $lnum - 1 ) {
1282                                            #my $rdline = $self->_s($lines[$rlnum]);
1283                                            my $rdline = $lines[$rlnum];
1284                                            $rlnum++;
1285                                            last unless ($rdline);
1286                                            if ($rdline =~ /^%/) {
1287                                                    $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
1288                                            } elsif($rdline =~ /=/) {
1289                                                    $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
1290                                            } else {
1291                                                    confess "invalid format of response";
1292                                            }
1293                                    }
1294                                    while($rlnum < $lnum - 1) {
1295                                            my $rdline = $lines[$rlnum];
1296                                            $rlnum++;
1297                                            $rdsnippet .= "$rdline\n";
1298                                    }
1299                                    #warn Dumper($rdvector, $rdattrs, $rdsnippet);
1300                                    if (my $rduri = $rdattrs->{'@uri'}) {
1301                                            push @docs, new Search::Estraier::ResultDocument(
1302                                                    uri => $rduri,
1303                                                    attrs => $rdattrs,
1304                                                    snippet => $rdsnippet,
1305                                                    keywords => $rdvector,
1306                                            );
1307                                    }
1308                            }
1309                            $snum = $lnum;
1310                            #warn "### $line\n";
1311                            $isend = 1 if ($line =~ /:END$/);
1312                    }
1313    
1314            }
1315    
1316            if (! $isend) {
1317                    warn "received result doesn't have :END\n$resbody";
1318                    return;
1319            }
1320    
1321            #warn Dumper(\@docs, $hints);
1322    
1323            return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
1324    }
1325    
1326    
1327    =head2 cond_to_query
1328    
1329    Return URI encoded string generated from Search::Estraier::Condition
1330    
1331      my $args = $node->cond_to_query( $cond, $depth );
1332    
1333    =cut
1334    
1335    sub cond_to_query {
1336            my $self = shift;
1337    
1338            my $cond = shift || return;
1339            croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1340            my $depth = shift;
1341    
1342            my @args;
1343    
1344            if (my $phrase = $cond->phrase) {
1345                    push @args, 'phrase=' . uri_escape($phrase);
1346            }
1347    
1348            if (my @attrs = $cond->attrs) {
1349                    for my $i ( 0 .. $#attrs ) {
1350                            push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1351                    }
1352            }
1353    
1354            if (my $order = $cond->order) {
1355                    push @args, 'order=' . uri_escape($order);
1356            }
1357                    
1358            if (my $max = $cond->max) {
1359                    push @args, 'max=' . $max;
1360            } else {
1361                    push @args, 'max=' . (1 << 30);
1362            }
1363    
1364            if (my $options = $cond->options) {
1365                    push @args, 'options=' . $options;
1366            }
1367    
1368            push @args, 'depth=' . $depth if ($depth);
1369            push @args, 'wwidth=' . $self->{wwidth};
1370            push @args, 'hwidth=' . $self->{hwidth};
1371            push @args, 'awidth=' . $self->{awidth};
1372    
1373            return join('&', @args);
1374    }
1375    
1376    
1377  =head2 shuttle_url  =head2 shuttle_url
1378    
1379  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
1380  master.  master.
1381    
1382    my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
1383    
1384  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
1385  body will be saved within object.  body will be saved within object.
1386    
1387  =cut  =cut
1388    
1389    use LWP::UserAgent;
1390    
1391  sub shuttle_url {  sub shuttle_url {
1392          my $self = shift;          my $self = shift;
1393    
# Line 1074  sub shuttle_url { Line 1406  sub shuttle_url {
1406                  return -1;                  return -1;
1407          }          }
1408    
1409          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1410            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
         if ($self->{pxhost}) {  
                 ($host,$port) = ($self->{pxhost}, $self->{pxport});  
                 $query = "http://$host:$port/$query";  
         }  
   
         $query .= '?' . $url->query if ($url->query && ! $reqbody);  
   
         my $headers;  
1411    
1412            my $req;
1413          if ($reqbody) {          if ($reqbody) {
1414                  $headers .= "POST $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(POST => $url);
1415          } else {          } else {
1416                  $headers .= "GET $query HTTP/1.0\r\n";                  $req = HTTP::Request->new(GET => $url);
1417          }          }
1418    
1419          $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1420          $headers .= "Connection: close\r\n";          $req->headers->header( 'Connection', 'close' );
1421          $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} );
1422          $headers .= "Content-Type: $content_type\r\n";          $req->content_type( $content_type );
         $headers .= "Authorization: Basic $self->{auth}\r\n";  
         my $len = 0;  
         {  
                 use bytes;  
                 $len = length($reqbody) if ($reqbody);  
         }  
         $headers .= "Content-Length: $len\r\n";  
         $headers .= "\r\n";  
   
         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;  
         }  
1423    
1424          warn $headers if ($self->{debug});          warn $req->headers->as_string,"\n" if ($self->{debug});
   
         print $sock $headers or  
                 carp "can't send headers to network:\n$headers\n" and return -1;  
1425    
1426          if ($reqbody) {          if ($reqbody) {
1427                  warn "$reqbody\n" if ($self->{debug});                  warn "$reqbody\n" if ($self->{debug});
1428                  print $sock $reqbody or                  $req->content( $reqbody );
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
1429          }          }
1430    
1431          my $line = <$sock>;          my $res = $ua->request($req) || croak "can't make request to $url: $!";
1432          chomp($line);  
1433          my ($schema, $res_status, undef) = split(/  */, $line, 3);          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1434          return if ($schema !~ /^HTTP/ || ! $res_status);  
1435            return -1 if (! $res->is_success);
         $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});  
         };  
1436    
1437          # read body          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1438          $len = 0;  
1439          do {          $$resbody .= $res->content;
                 $len = read($sock, my $buf, 8192);  
                 $$resbody .= $buf if ($resbody);  
         } while ($len);  
1440    
1441          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1442    
1443          return $self->{status};          return $self->{status};
1444  }  }
1445    
1446    
1447    =head2 set_snippet_width
1448    
1449    Set width of snippets in results
1450    
1451      $node->set_snippet_width( $wwidth, $hwidth, $awidth );
1452    
1453    C<$wwidth> specifies whole width of snippet. It's C<480> by default. If it's C<0> snippet
1454    is not sent with results. If it is negative, whole document text is sent instead of snippet.
1455    
1456    C<$hwidth> specified width of strings from beginning of string. Default
1457    value is C<96>. Negative or zero value keep previous value.
1458    
1459    C<$awidth> specifies width of strings around each highlighted word. It's C<96> by default.
1460    If negative of zero value is provided previous value is kept unchanged.
1461    
1462    =cut
1463    
1464    sub set_snippet_width {
1465            my $self = shift;
1466    
1467            my ($wwidth, $hwidth, $awidth) = @_;
1468            $self->{wwidth} = $wwidth;
1469            $self->{hwidth} = $hwidth if ($hwidth >= 0);
1470            $self->{awidth} = $awidth if ($awidth >= 0);
1471    }
1472    
1473    
1474    =head2 set_user
1475    
1476    Manage users of node
1477    
1478      $node->set_user( 'name', $mode );
1479    
1480    C<$mode> can be one of:
1481    
1482    =over 4
1483    
1484    =item 0
1485    
1486    delete account
1487    
1488    =item 1
1489    
1490    set administrative right for user
1491    
1492    =item 2
1493    
1494    set user account as guest
1495    
1496    =back
1497    
1498    Return true on success, otherwise false.
1499    
1500    =cut
1501    
1502    sub set_user {
1503            my $self = shift;
1504            my ($name, $mode) = @_;
1505    
1506            return unless ($self->{url});
1507            croak "mode must be number, not '$mode'" unless ($mode =~ m/^\d+$/);
1508    
1509            $self->shuttle_url( $self->{url} . '/_set_user',
1510                    'text/plain',
1511                    'name=' . uri_escape($name) . '&mode=' . $mode,
1512                    undef
1513            ) == 200;
1514    }
1515    
1516    
1517    =head2 set_link
1518    
1519    Manage node links
1520    
1521      $node->set_link('http://localhost:1978/node/another', 'another node label', $credit);
1522    
1523    If C<$credit> is negative, link is removed.
1524    
1525    =cut
1526    
1527    sub set_link {
1528            my $self = shift;
1529            my ($url, $label, $credit) = @_;
1530    
1531            return unless ($self->{url});
1532            croak "mode credit be number, not '$credit'" unless ($credit =~ m/^\d+$/);
1533    
1534            my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
1535            $reqbody .= '&credit=' . $credit if ($credit > 0);
1536    
1537            $self->shuttle_url( $self->{url} . '/_set_link',
1538                    'application/x-www-form-urlencoded',
1539                    $reqbody,
1540                    undef
1541            ) == 200;
1542    }
1543    
1544    
1545    =head1 PRIVATE METHODS
1546    
1547    You could call those directly, but you don't have to. I hope.
1548    
1549    =head2 _set_info
1550    
1551    Set information for node
1552    
1553      $node->_set_info;
1554    
1555    =cut
1556    
1557    sub _set_info {
1558            my $self = shift;
1559    
1560            $self->{status} = -1;
1561            return unless ($self->{url});
1562    
1563            my $resbody;
1564            my $rv = $self->shuttle_url( $self->{url} . '/inform',
1565                    'text/plain',
1566                    undef,
1567                    \$resbody,
1568            );
1569    
1570            return if ($rv != 200 || !$resbody);
1571    
1572            # it seems that response can have multiple line endings
1573            $resbody =~ s/[\r\n]+$//;
1574    
1575            ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1576                    split(/\t/, $resbody, 5);
1577    
1578    }
1579    
1580  ###  ###
1581    
1582  =head1 EXPORT  =head1 EXPORT
Legend:
Removed from v.47  
changed lines
  Added in v.74
  ViewVC Help
Powered by ViewVC 1.1.26