/[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 58 by dpavlin, Fri Jan 6 21:05:05 2006 UTC revision 98 by dpavlin, Sat Jan 28 19:18:13 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 41  Remove multiple whitespaces from string, Line 92  Remove multiple whitespaces from string,
92  =cut  =cut
93    
94  sub _s {  sub _s {
95          my $text = $_[1] || return;          my $text = $_[1];
96            return unless defined($text);
97          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
98          $text =~ s/^\s+//;          $text =~ s/^\s+//;
99          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 158  sub new {
158                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
159                                  $in_text = 1;                                  $in_text = 1;
160                                  next;                                  next;
161                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
162                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
163                                  next;                                  next;
164                          }                          }
165    
166                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
167                  }                  }
168          }          }
169    
# Line 205  Returns array with attribute names from Line 257  Returns array with attribute names from
257    
258  sub attr_names {  sub attr_names {
259          my $self = shift;          my $self = shift;
260          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
261            #croak "attr_names return array, not scalar" if (! wantarray);
262          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
263  }  }
264    
# Line 221  Returns value of an attribute. Line 274  Returns value of an attribute.
274  sub attr {  sub attr {
275          my $self = shift;          my $self = shift;
276          my $name = shift;          my $name = shift;
277            return unless (defined($name) && $self->{attrs});
278          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
279  }  }
280    
281    
# Line 236  Returns array with text sentences. Line 289  Returns array with text sentences.
289    
290  sub texts {  sub texts {
291          my $self = shift;          my $self = shift;
292          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
293          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
294  }  }
295    
296    
# Line 251  Return whole text as single scalar. Line 304  Return whole text as single scalar.
304    
305  sub cat_texts {  sub cat_texts {
306          my $self = shift;          my $self = shift;
307          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
308  }  }
309    
310    
# Line 268  sub dump_draft { Line 321  sub dump_draft {
321          my $draft;          my $draft;
322    
323          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
324                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
325                    $draft .= $attr_name . '=' . $v . "\n";
326          }          }
327    
328          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 370  sub delete {
370    
371  package Search::Estraier::Condition;  package Search::Estraier::Condition;
372    
373  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
374    
375  use Search::Estraier;  use Search::Estraier;
376  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 448  sub set_max {
448    
449  =head2 set_options  =head2 set_options
450    
451    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
452    
453      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
454    
455    Possible options are:
456    
457    =over 8
458    
459    =item SURE
460    
461    check every N-gram
462    
463    =item USUAL
464    
465    check every second N-gram
466    
467    =item FAST
468    
469    check every third N-gram
470    
471    =item AGITO
472    
473    check every fourth N-gram
474    
475    =item NOIDF
476    
477    don't perform TF-IDF tuning
478    
479    =item SIMPLE
480    
481    use simplified query phrase
482    
483    =back
484    
485    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
486    options;
487    
488    This option changed in version C<0.04> of this module. It's backwards compatibile.
489    
490  =cut  =cut
491    
492  my $options = {  my $options = {
         # check N-gram keys skipping by three  
493          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
494          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
495          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
496          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
497          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
498          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
499  };  };
500    
501  sub set_options {  sub set_options {
502          my $self = shift;          my $self = shift;
503          my $option = shift;          my $opt = 0;
504          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
505          $self->{options} ||= $options->{$option};                  my $mask;
506                    unless ($mask = $options->{$option}) {
507                            if ($option eq '1') {
508                                    next;
509                            } else {
510                                    croak "unknown option $option";
511                            }
512                    }
513                    $opt += $mask;
514            }
515            $self->{options} = $opt;
516  }  }
517    
518    
# Line 460  Return search result attrs. Line 555  Return search result attrs.
555  sub attrs {  sub attrs {
556          my $self = shift;          my $self = shift;
557          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
558          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
559  }  }
560    
561    
# Line 524  sub new { Line 619  sub new {
619          my $self = {@_};          my $self = {@_};
620          bless($self, $class);          bless($self, $class);
621    
622          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});  
         }  
623    
624          $self ? return $self : return undef;          $self ? return $self : return undef;
625  }  }
# Line 685  sub hint { Line 778  sub hint {
778          return $self->{hints}->{$key};          return $self->{hints}->{$key};
779  }  }
780    
781    =head2 hints
782    
783    More perlish version of C<hint>. This one returns hash.
784    
785      my %hints = $rec->hints;
786    
787    =cut
788    
789    sub hints {
790            my $self = shift;
791            return $self->{hints};
792    }
793    
794  package Search::Estraier::Node;  package Search::Estraier::Node;
795    
# Line 700  use URI::Escape qw/uri_escape/; Line 805  use URI::Escape qw/uri_escape/;
805    
806    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
807    
808    or optionally with C<url> as parametar
809    
810      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
811    
812    or in more verbose form
813    
814      my $node = new Search::HyperEstraier::Node(
815            url => 'http://localhost:1978/node/test',
816            debug => 1,
817            croak_on_error => 1
818      );
819    
820    with following arguments:
821    
822    =over 4
823    
824    =item url
825    
826    URL to node
827    
828    =item debug
829    
830    dumps a B<lot> of debugging output
831    
832    =item croak_on_error
833    
834    very helpful during development. It will croak on all errors instead of
835    silently returning C<-1> (which is convention of Hyper Estraier API in other
836    languages).
837    
838    =back
839    
840  =cut  =cut
841    
842  sub new {  sub new {
# Line 717  sub new { Line 854  sub new {
854          };          };
855          bless($self, $class);          bless($self, $class);
856    
857          my $args = {@_};          if ($#_ == 0) {
858                    $self->{url} = shift;
859            } else {
860                    my $args = {@_};
861    
862                    %$self = ( %$self, @_ );
863    
864          $self->{debug} = $args->{debug};                  warn "## Node debug on\n" if ($self->{debug});
865          warn "## Node debug on\n" if ($self->{debug});          }
866    
867          $self ? return $self : return undef;          $self ? return $self : return undef;
868  }  }
# Line 1176  sub search { Line 1318  sub search {
1318    
1319          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1320                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1321                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1322                  \$resbody,                  \$resbody,
1323          );          );
1324          return if ($rv != 200);          return if ($rv != 200);
# Line 1270  sub search { Line 1412  sub search {
1412    
1413  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1414    
1415    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1416    
1417  =cut  =cut
1418    
# Line 1279  sub cond_to_query { Line 1421  sub cond_to_query {
1421    
1422          my $cond = shift || return;          my $cond = shift || return;
1423          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'));
1424            my $depth = shift;
1425    
1426          my @args;          my @args;
1427    
# Line 1288  sub cond_to_query { Line 1431  sub cond_to_query {
1431    
1432          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1433                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1434                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1435                  }                  }
1436          }          }
1437    
# Line 1306  sub cond_to_query { Line 1449  sub cond_to_query {
1449                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1450          }          }
1451    
1452          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1453          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1454          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1455          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
# Line 1317  sub cond_to_query { Line 1460  sub cond_to_query {
1460    
1461  =head2 shuttle_url  =head2 shuttle_url
1462    
1463  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
1464  master.  master.
1465    
1466    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 1470  body will be saved within object.
1470    
1471  =cut  =cut
1472    
1473    use LWP::UserAgent;
1474    
1475  sub shuttle_url {  sub shuttle_url {
1476          my $self = shift;          my $self = shift;
1477    
# Line 1345  sub shuttle_url { Line 1490  sub shuttle_url {
1490                  return -1;                  return -1;
1491          }          }
1492    
1493          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1494            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1495    
1496          if ($self->{pxhost}) {          my $req;
1497                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1498                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1499            } else {
1500                    $req = HTTP::Request->new(GET => $url);
1501          }          }
1502    
1503          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1504            $req->headers->header( 'Connection', 'close' );
1505            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1506            $req->content_type( $content_type );
1507    
1508          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1509    
1510          if ($reqbody) {          if ($reqbody) {
1511                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1512          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1513          }          }
1514    
1515          $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;  
         }  
1516    
1517          warn $headers if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1518    
1519          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;  
1520    
1521          if ($reqbody) {          if (! $res->is_success) {
1522                  warn "$reqbody\n" if ($self->{debug});                  if ($self->{croak_on_error}) {
1523                  print $sock $reqbody or                          croak("can't get $url: ",$res->status_line);
1524                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  } else {
1525                            return -1;
1526                    }
1527          }          }
1528    
1529          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);  
1530    
1531          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1532    
# Line 1518  sub set_link { Line 1625  sub set_link {
1625          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1626    
1627          $self->shuttle_url( $self->{url} . '/_set_link',          $self->shuttle_url( $self->{url} . '/_set_link',
1628                  'text/plain',                  'application/x-www-form-urlencoded',
1629                  $reqbody,                  $reqbody,
1630                  undef                  undef
1631          ) == 200;          ) == 200;
Legend:
Removed from v.58  
changed lines
  Added in v.98
  ViewVC Help
Powered by ViewVC 1.1.26