/[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 60 by dpavlin, Sat Jan 7 00:00:15 2006 UTC revision 97 by dpavlin, Sat Jan 28 18:19:47 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 525  sub new { Line 578  sub new {
578          my $self = {@_};          my $self = {@_};
579          bless($self, $class);          bless($self, $class);
580    
581          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});  
         }  
582    
583          $self ? return $self : return undef;          $self ? return $self : return undef;
584  }  }
# Line 686  sub hint { Line 737  sub hint {
737          return $self->{hints}->{$key};          return $self->{hints}->{$key};
738  }  }
739    
740    =head2 hints
741    
742    More perlish version of C<hint>. This one returns hash.
743    
744      my %hints = $rec->hints;
745    
746    =cut
747    
748    sub hints {
749            my $self = shift;
750            return $self->{hints};
751    }
752    
753  package Search::Estraier::Node;  package Search::Estraier::Node;
754    
# Line 701  use URI::Escape qw/uri_escape/; Line 764  use URI::Escape qw/uri_escape/;
764    
765    my $node = new Search::HyperEstraier::Node;    my $node = new Search::HyperEstraier::Node;
766    
767    or optionally with C<url> as parametar
768    
769      my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
770    
771    or in more verbose form
772    
773      my $node = new Search::HyperEstraier::Node(
774            url => 'http://localhost:1978/node/test',
775            debug => 1,
776            croak_on_error => 1
777      );
778    
779    with following arguments:
780    
781    =over 4
782    
783    =item url
784    
785    URL to node
786    
787    =item debug
788    
789    dumps a B<lot> of debugging output
790    
791    =item croak_on_error
792    
793    very helpful during development. It will croak on all errors instead of
794    silently returning C<-1> (which is convention of Hyper Estraier API in other
795    languages).
796    
797    =back
798    
799  =cut  =cut
800    
801  sub new {  sub new {
# Line 718  sub new { Line 813  sub new {
813          };          };
814          bless($self, $class);          bless($self, $class);
815    
816          my $args = {@_};          if ($#_ == 0) {
817                    $self->{url} = shift;
818            } else {
819                    my $args = {@_};
820    
821          $self->{debug} = $args->{debug};                  %$self = ( %$self, @_ );
822          warn "## Node debug on\n" if ($self->{debug});  
823                    warn "## Node debug on\n" if ($self->{debug});
824            }
825    
826          $self ? return $self : return undef;          $self ? return $self : return undef;
827  }  }
# Line 1177  sub search { Line 1277  sub search {
1277    
1278          my $rv = $self->shuttle_url( $self->{url} . '/search',          my $rv = $self->shuttle_url( $self->{url} . '/search',
1279                  'application/x-www-form-urlencoded',                  'application/x-www-form-urlencoded',
1280                  $self->cond_to_query( $cond ),                  $self->cond_to_query( $cond, $depth ),
1281                  \$resbody,                  \$resbody,
1282          );          );
1283          return if ($rv != 200);          return if ($rv != 200);
# Line 1271  sub search { Line 1371  sub search {
1371    
1372  Return URI encoded string generated from Search::Estraier::Condition  Return URI encoded string generated from Search::Estraier::Condition
1373    
1374    my $args = $node->cond_to_query( $cond );    my $args = $node->cond_to_query( $cond, $depth );
1375    
1376  =cut  =cut
1377    
# Line 1280  sub cond_to_query { Line 1380  sub cond_to_query {
1380    
1381          my $cond = shift || return;          my $cond = shift || return;
1382          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'));
1383            my $depth = shift;
1384    
1385          my @args;          my @args;
1386    
# Line 1289  sub cond_to_query { Line 1390  sub cond_to_query {
1390    
1391          if (my @attrs = $cond->attrs) {          if (my @attrs = $cond->attrs) {
1392                  for my $i ( 0 .. $#attrs ) {                  for my $i ( 0 .. $#attrs ) {
1393                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] );                          push @args,'attr' . ($i+1) . '=' . uri_escape( $attrs[$i] ) if ($attrs[$i]);
1394                  }                  }
1395          }          }
1396    
# Line 1307  sub cond_to_query { Line 1408  sub cond_to_query {
1408                  push @args, 'options=' . $options;                  push @args, 'options=' . $options;
1409          }          }
1410    
1411          push @args, 'depth=' . $self->{depth} if ($self->{depth});          push @args, 'depth=' . $depth if ($depth);
1412          push @args, 'wwidth=' . $self->{wwidth};          push @args, 'wwidth=' . $self->{wwidth};
1413          push @args, 'hwidth=' . $self->{hwidth};          push @args, 'hwidth=' . $self->{hwidth};
1414          push @args, 'awidth=' . $self->{awidth};          push @args, 'awidth=' . $self->{awidth};
# Line 1318  sub cond_to_query { Line 1419  sub cond_to_query {
1419    
1420  =head2 shuttle_url  =head2 shuttle_url
1421    
1422  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
1423  master.  master.
1424    
1425    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );    my $rv = shuttle_url( $url, $content_type, $req_body, \$resbody );
# Line 1360  sub shuttle_url { Line 1461  sub shuttle_url {
1461    
1462          $req->headers->header( 'Host' => $url->host . ":" . $url->port );          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1463          $req->headers->header( 'Connection', 'close' );          $req->headers->header( 'Connection', 'close' );
1464          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} );          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1465          $req->content_type( $content_type );          $req->content_type( $content_type );
1466    
1467          warn $req->headers->as_string,"\n" if ($self->{debug});          warn $req->headers->as_string,"\n" if ($self->{debug});
# Line 1374  sub shuttle_url { Line 1475  sub shuttle_url {
1475    
1476          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1477    
         return -1 if (! $res->is_success);  
   
1478          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1479    
1480            if (! $res->is_success) {
1481                    if ($self->{croak_on_error}) {
1482                            croak("can't get $url: ",$res->status_line);
1483                    } else {
1484                            return -1;
1485                    }
1486            }
1487    
1488          $$resbody .= $res->content;          $$resbody .= $res->content;
1489    
1490          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
# Line 1477  sub set_link { Line 1584  sub set_link {
1584          $reqbody .= '&credit=' . $credit if ($credit > 0);          $reqbody .= '&credit=' . $credit if ($credit > 0);
1585    
1586          $self->shuttle_url( $self->{url} . '/_set_link',          $self->shuttle_url( $self->{url} . '/_set_link',
1587                  'text/plain',                  'application/x-www-form-urlencoded',
1588                  $reqbody,                  $reqbody,
1589                  undef                  undef
1590          ) == 200;          ) == 200;
Legend:
Removed from v.60  
changed lines
  Added in v.97
  ViewVC Help
Powered by ViewVC 1.1.26