/[Search-Estraier]/trunk/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/Estraier.pm

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

revision 55 by dpavlin, Fri Jan 6 20:39:58 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 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 700  use URI::Escape qw/uri_escape/; Line 763  use URI::Escape qw/uri_escape/;
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 717  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 1176  sub search { Line 1276  sub search {
1276    
1277          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1278                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1279                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1280                  \$resbody,                  \$resbody,
1281          );          );
1282          return if ($rv != 200);          return if ($rv != 200);
# Line 1270  sub search { Line 1370  sub search {
1370    
1371  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1372    
1373    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1374    
1375  =cut  =cut
1376    
# Line 1279  sub cond_to_query { Line 1379  sub cond_to_query {
1379    
1380          my $cond = shift || return;          my $cond = shift || return;
1381          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));          croak "condition must be Search::Estraier::Condition, not '$cond->isa'" unless ($cond->isa('Search::Estraier::Condition'));
1382            my $depth = shift;
1383    
1384          my @args;          my @args;
1385    
# Line 1288  sub cond_to_query { Line 1389  sub cond_to_query {
1389    
1390          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1391                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1392                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1393                  }                  }
1394          }          }
1395    
# Line 1306  sub cond_to_query { Line 1407  sub cond_to_query {
1407                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1408          }          }
1409    
1410          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1411          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1412          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1413          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
# Line 1317  sub cond_to_query { Line 1418  sub cond_to_query {
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 );
# Line 1327  body will be saved within object. Line 1428  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 1345  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,  
         );  
1474    
1475          if (! $sock) {          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
                 carp "can't open socket to $host:$port";  
                 return -1;  
         }  
1476    
1477          warn $headers if ($self->{debug});          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1478    
1479          print $sock $headers or          if (! $res->is_success) {
1480                  carp "can't send headers to network:\n$headers\n" and return -1;                  if ($self->{croak_on_error}) {
1481                            croak("can't get $url: ",$res->status_line);
1482          if ($reqbody) {                  } else {
1483                  warn "$reqbody\n" if ($self->{debug});                          return -1;
1484                  print $sock $reqbody or                  }
                         carp "can't send request body to network:\n$$reqbody\n" and return -1;  
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    
# Line 1454  sub set_snippet_width { Line 1519  sub set_snippet_width {
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  =head1 PRIVATE METHODS
1594    
# Line 1482  sub _set_info { Line 1617  sub _set_info {
1617    
1618          return if ($rv != 200 || !$resbody);          return if ($rv != 200 || !$resbody);
1619    
1620          chomp($resbody);          # 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} ) =          ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
1624                  split(/\t/, $resbody, 5);                  split(/\t/, $resbody, 5);
Legend:
Removed from v.55  
changed lines
  Added in v.93
  ViewVC Help
Powered by ViewVC 1.1.26