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