/[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 100 by dpavlin, Sat Jan 28 19:41:59 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            print "Got ", $nres->hits, " results\n";
54    
55            if (defined($nres)) {
56                    # for each document in results
57                    for my $i ( 0 ... $nres->doc_num - 1 ) {
58                            # get result document
59                            my $rdoc = $nres->get_doc($i);
60                            # display attribte
61                            print "URI: ", $rdoc->attr('@uri'),"\n";
62                            print "Title: ", $rdoc->attr('@title'),"\n";
63                            print $rdoc->snippet,"\n";
64                    }
65            } else {
66                    die "error: ", $node->status,"\n";
67            }
68    
69  =head1 DESCRIPTION  =head1 DESCRIPTION
70    
# Line 25  or Hyper Estraier development files on t Line 76  or Hyper Estraier development files on t
76  It is implemented as multiple packages which closly resamble Ruby  It is implemented as multiple packages which closly resamble Ruby
77  implementation. It also includes methods to manage nodes.  implementation. It also includes methods to manage nodes.
78    
79    There are few examples in C<scripts> directory of this distribution.
80    
81  =cut  =cut
82    
83  =head1 Inheritable common methods  =head1 Inheritable common methods
# Line 41  Remove multiple whitespaces from string, Line 94  Remove multiple whitespaces from string,
94  =cut  =cut
95    
96  sub _s {  sub _s {
97          my $text = $_[1] || return;          my $text = $_[1];
98            return unless defined($text);
99          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
100          $text =~ s/^\s+//;          $text =~ s/^\s+//;
101          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 106  sub new { Line 160  sub new {
160                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
161                                  $in_text = 1;                                  $in_text = 1;
162                                  next;                                  next;
163                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
164                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
165                                  next;                                  next;
166                          }                          }
167    
168                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
169                  }                  }
170          }          }
171    
# Line 205  Returns array with attribute names from Line 259  Returns array with attribute names from
259    
260  sub attr_names {  sub attr_names {
261          my $self = shift;          my $self = shift;
262          croak "attr_names return array, not scalar" if (! wantarray);          return unless ($self->{attrs});
263            #croak "attr_names return array, not scalar" if (! wantarray);
264          return sort keys %{ $self->{attrs} };          return sort keys %{ $self->{attrs} };
265  }  }
266    
# Line 221  Returns value of an attribute. Line 276  Returns value of an attribute.
276  sub attr {  sub attr {
277          my $self = shift;          my $self = shift;
278          my $name = shift;          my $name = shift;
279            return unless (defined($name) && $self->{attrs});
280          return $self->{'attrs'}->{ $name };          return $self->{attrs}->{ $name };
281  }  }
282    
283    
# Line 236  Returns array with text sentences. Line 291  Returns array with text sentences.
291    
292  sub texts {  sub texts {
293          my $self = shift;          my $self = shift;
294          confess "texts return array, not scalar" if (! wantarray);          #confess "texts return array, not scalar" if (! wantarray);
295          return @{ $self->{dtexts} };          return @{ $self->{dtexts} } if ($self->{dtexts});
296  }  }
297    
298    
# Line 251  Return whole text as single scalar. Line 306  Return whole text as single scalar.
306    
307  sub cat_texts {  sub cat_texts {
308          my $self = shift;          my $self = shift;
309          return join(' ',@{ $self->{dtexts} });          return join(' ',@{ $self->{dtexts} }) if ($self->{dtexts});
310  }  }
311    
312    
# Line 268  sub dump_draft { Line 323  sub dump_draft {
323          my $draft;          my $draft;
324    
325          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
326                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
327                    $draft .= $attr_name . '=' . $v . "\n";
328          }          }
329    
330          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 316  sub delete { Line 372  sub delete {
372    
373  package Search::Estraier::Condition;  package Search::Estraier::Condition;
374    
375  use Carp qw/confess croak/;  use Carp qw/carp confess croak/;
376    
377  use Search::Estraier;  use Search::Estraier;
378  our @ISA = qw/Search::Estraier/;  our @ISA = qw/Search::Estraier/;
# Line 394  sub set_max { Line 450  sub set_max {
450    
451  =head2 set_options  =head2 set_options
452    
453    $cond->set_options( SURE => 1 );    $cond->set_options( 'SURE' );
454    
455      $cond->set_options( qw/AGITO NOIDF SIMPLE/ );
456    
457    Possible options are:
458    
459    =over 8
460    
461    =item SURE
462    
463    check every N-gram
464    
465    =item USUAL
466    
467    check every second N-gram
468    
469    =item FAST
470    
471    check every third N-gram
472    
473    =item AGITO
474    
475    check every fourth N-gram
476    
477    =item NOIDF
478    
479    don't perform TF-IDF tuning
480    
481    =item SIMPLE
482    
483    use simplified query phrase
484    
485    =back
486    
487    Skipping N-grams will speed up search, but reduce accuracy. Every call to C<set_options> will reset previous
488    options;
489    
490    This option changed in version C<0.04> of this module. It's backwards compatibile.
491    
492  =cut  =cut
493    
494  my $options = {  my $options = {
         # check N-gram keys skipping by three  
495          SURE => 1 << 0,          SURE => 1 << 0,
         # check N-gram keys skipping by two  
496          USUAL => 1 << 1,          USUAL => 1 << 1,
         # without TF-IDF tuning  
497          FAST => 1 << 2,          FAST => 1 << 2,
         # with the simplified phrase  
498          AGITO => 1 << 3,          AGITO => 1 << 3,
         # check every N-gram key  
499          NOIDF => 1 << 4,          NOIDF => 1 << 4,
         # check N-gram keys skipping by one  
500          SIMPLE => 1 << 10,          SIMPLE => 1 << 10,
501  };  };
502    
503  sub set_options {  sub set_options {
504          my $self = shift;          my $self = shift;
505          my $option = shift;          my $opt = 0;
506          confess "unknown option" unless ($options->{$option});          foreach my $option (@_) {
507          $self->{options} ||= $options->{$option};                  my $mask;
508                    unless ($mask = $options->{$option}) {
509                            if ($option eq '1') {
510                                    next;
511                            } else {
512                                    croak "unknown option $option";
513                            }
514                    }
515                    $opt += $mask;
516            }
517            $self->{options} = $opt;
518  }  }
519    
520    
# Line 460  Return search result attrs. Line 557  Return search result attrs.
557  sub attrs {  sub attrs {
558          my $self = shift;          my $self = shift;
559          #croak "attrs return array, not scalar" if (! wantarray);          #croak "attrs return array, not scalar" if (! wantarray);
560          return @{ $self->{attrs} };          return @{ $self->{attrs} } if ($self->{attrs});
561  }  }
562    
563    
# Line 524  sub new { Line 621  sub new {
621          my $self = {@_};          my $self = {@_};
622          bless($self, $class);          bless($self, $class);
623    
624          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});  
         }  
625    
626          $self ? return $self : return undef;          $self ? return $self : return undef;
627  }  }
# Line 641  Return number of documents Line 736  Return number of documents
736    
737    print $res->doc_num;    print $res->doc_num;
738    
739    This will return real number of documents (limited by C<max>).
740    If you want to get total number of hits, see C<hits>.
741    
742  =cut  =cut
743    
744  sub doc_num {  sub doc_num {
# Line 672  sub get_doc { Line 770  sub get_doc {
770    
771  Return specific hint from results.  Return specific hint from results.
772    
773    print $rec->hint( 'VERSION' );    print $res->hint( 'VERSION' );
774    
775  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,  Possible hints are: C<VERSION>, C<NODE>, C<HIT>, C<HINT#n>, C<DOCNUM>, C<WORDNUM>,
776  C<TIME>, C<LINK#n>, C<VIEW>.  C<TIME>, C<LINK#n>, C<VIEW>.
# Line 685  sub hint { Line 783  sub hint {
783          return $self->{hints}->{$key};          return $self->{hints}->{$key};
784  }  }
785    
786    =head2 hits
787    
788    More perlish version of C<hint>. This one returns hash.
789    
790      my %hints = $res->hints;
791    
792    =cut
793    
794    sub hints {
795            my $self = shift;
796            return $self->{hints};
797    }
798    
799    =head2 hits
800    
801    Syntaxtic sugar for total number of hits for this query
802    
803      print $res->hits;
804    
805    It's same as
806    
807      print $res->hint('HIT');
808    
809    but shorter.
810    
811    =cut
812    
813    sub hits {
814            my $self = shift;
815            return $self->{hints}->{'HIT'} || 0;
816    }
817    
818  package Search::Estraier::Node;  package Search::Estraier::Node;
819    
# Line 700  use URI::Escape qw/uri_escape/; Line 829  use URI::Escape qw/uri_escape/;
829    
830    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
831    
832    or optionally with C<url> as parametar
833    
834      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
835    
836    or in more verbose form
837    
838      my $node = new Search::HyperEstraier::Node(
839            url => 'http://localhost:1978/node/test',
840            debug => 1,
841            croak_on_error => 1
842      );
843    
844    with following arguments:
845    
846    =over 4
847    
848    =item url
849    
850    URL to node
851    
852    =item debug
853    
854    dumps a B<lot> of debugging output
855    
856    =item croak_on_error
857    
858    very helpful during development. It will croak on all errors instead of
859    silently returning C<-1> (which is convention of Hyper Estraier API in other
860    languages).
861    
862    =back
863    
864  =cut  =cut
865    
866  sub new {  sub new {
# Line 717  sub new { Line 878  sub new {
878          };          };
879          bless($self, $class);          bless($self, $class);
880    
881          my $args = {@_};          if ($#_ == 0) {
882                    $self->{url} = shift;
883            } else {
884                    my $args = {@_};
885    
886          $self->{debug} = $args->{debug};                  %$self = ( %$self, @_ );
887          warn "## Node debug on\n" if ($self->{debug});  
888                    warn "## Node debug on\n" if ($self->{debug});
889            }
890    
891          $self ? return $self : return undef;          $self ? return $self : return undef;
892  }  }
# Line 1176  sub search { Line 1342  sub search {
1342    
1343          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1344                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1345                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1346                  \$resbody,                  \$resbody,
1347          );          );
1348          return if ($rv != 200);          return if ($rv != 200);
# Line 1270  sub search { Line 1436  sub search {
1436    
1437  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1438    
1439    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1440    
1441  =cut  =cut
1442    
# Line 1279  sub cond_to_query { Line 1445  sub cond_to_query {
1445    
1446          my $cond = shift || return;          my $cond = shift || return;
1447          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'));
1448            my $depth = shift;
1449    
1450          my @args;          my @args;
1451    
# Line 1288  sub cond_to_query { Line 1455  sub cond_to_query {
1455    
1456          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1457                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1458                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1459                  }                  }
1460          }          }
1461    
# Line 1306  sub cond_to_query { Line 1473  sub cond_to_query {
1473                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1474          }          }
1475    
1476          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1477          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1478          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1479          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
# Line 1317  sub cond_to_query { Line 1484  sub cond_to_query {
1484    
1485  =head2 shuttle_url  =head2 shuttle_url
1486    
1487  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
1488  master.  master.
1489    
1490    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 1494  body will be saved within object.
1494    
1495  =cut  =cut
1496    
1497    use LWP::UserAgent;
1498    
1499  sub shuttle_url {  sub shuttle_url {
1500          my $self = shift;          my $self = shift;
1501    
# Line 1345  sub shuttle_url { Line 1514  sub shuttle_url {
1514                  return -1;                  return -1;
1515          }          }
1516    
1517          my ($host,$port,$query) = ($url->host, $url->port, $url->path);          my $ua = LWP::UserAgent->new;
1518            $ua->agent( "Search-Estraier/$Search::Estraier::VERSION" );
1519    
1520          if ($self->{pxhost}) {          my $req;
1521                  ($host,$port) = ($self->{pxhost}, $self->{pxport});          if ($reqbody) {
1522                  $query = "http://$host:$port/$query";                  $req = HTTP::Request->new(POST => $url);
1523            } else {
1524                    $req = HTTP::Request->new(GET => $url);
1525          }          }
1526    
1527          $query .= '?' . $url->query if ($url->query && ! $reqbody);          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1528            $req->headers->header( 'Connection', 'close' );
1529            $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1530            $req->content_type( $content_type );
1531    
1532          my $headers;          warn $req->headers->as_string,"\n" if ($self->{debug});
1533    
1534          if ($reqbody) {          if ($reqbody) {
1535                  $headers .= "POST $query HTTP/1.0\r\n";                  warn "$reqbody\n" if ($self->{debug});
1536          } else {                  $req->content( $reqbody );
                 $headers .= "GET $query HTTP/1.0\r\n";  
1537          }          }
1538    
1539          $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;  
         }  
1540    
1541          warn $headers if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1542    
1543          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;  
1544    
1545          if ($reqbody) {          if (! $res->is_success) {
1546                  warn "$reqbody\n" if ($self->{debug});                  if ($self->{croak_on_error}) {
1547                  print $sock $reqbody or                          croak("can't get $url: ",$res->status_line);
1548                          carp "can't send request body to network:\n$$reqbody\n" and return -1;                  } else {
1549                            return -1;
1550                    }
1551          }          }
1552    
1553          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);  
1554    
1555          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
1556    
# Line 1518  sub set_link { Line 1649  sub set_link {
1649          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1650    
1651          $self->shuttle_url( $self->{url} . '/_set_link',          $self->shuttle_url( $self->{url} . '/_set_link',
1652                  'text/plain',                  'application/x-www-form-urlencoded',
1653                  $reqbody,                  $reqbody,
1654                  undef                  undef
1655          ) == 200;          ) == 200;
Legend:
Removed from v.58  
changed lines
  Added in v.100
  ViewVC Help
Powered by ViewVC 1.1.26