/[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 61 by dpavlin, Sat Jan 7 01:21:28 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.01';  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 269  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 317  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 395  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 525  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 686  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 701  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 718  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 1290  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 1319  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 1361  sub shuttle_url { Line 1502  sub shuttle_url {
1502    
1503          $req->headers->header( 'Host' => $url->host . ":" . $url->port );          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1504          $req->headers->header( 'Connection', 'close' );          $req->headers->header( 'Connection', 'close' );
1505          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} );          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1506          $req->content_type( $content_type );          $req->content_type( $content_type );
1507    
1508          warn $req->headers->as_string,"\n" if ($self->{debug});          warn $req->headers->as_string,"\n" if ($self->{debug});
# Line 1375  sub shuttle_url { Line 1516  sub shuttle_url {
1516    
1517          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1518    
         return -1 if (! $res->is_success);  
   
1519          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1520    
1521            if (! $res->is_success) {
1522                    if ($self->{croak_on_error}) {
1523                            croak("can't get $url: ",$res->status_line);
1524                    } else {
1525                            return -1;
1526                    }
1527            }
1528    
1529          $$resbody .= $res->content;          $$resbody .= $res->content;
1530    
1531          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
# Line 1478  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.61  
changed lines
  Added in v.98
  ViewVC Help
Powered by ViewVC 1.1.26