/[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!

Diff of /trunk/lib/Search/Estraier.pm

Parent Directory | Revision Log | View Patch Patch

-revision 103 by dpavlin,
Sat Jan 28 20:44:15 2006 UTC
+revision 150 by dpavlin,
Mon May 15 22:26:08 2006 UTC
 Line 4 
 use 5.008;
  use strict;
  use warnings;
- our $VERSION = '0.04_1';
+ our $VERSION = '0.07_1';
  =head1 NAME
 Line 20 
 Search::Estraier - pure perl module to u
          my $node = new Search::Estraier::Node(
                  url => 'http://localhost:1978/node/test',
                  user => 'admin',
-                 passwd => 'admin'
+                 passwd => 'admin',
+                 create => 1,
+                 label => 'Label for node',
+                 croak_on_error => 1,
          );
          # create document
-Line 599 
 sub options {
+Line 602 
 sub options {
  }
+ =head2 set_skip
+ Set number of skipped documents from beginning of results
+   $cond->set_skip(42);
+ Similar to C<offset> in RDBMS.
+ =cut
+ sub set_skip {
+         my $self = shift;
+         $self->{skip} = shift;
+ }
+ =head2 skip
+ Return skip for this condition.
+   print $cond->skip;
+ =cut
+ sub skip {
+         my $self = shift;
+         return $self->{skip};
+ }
  package Search::Estraier::ResultDocument;
  use Carp qw/croak/;
-Line 789 
 sub hint {
+Line 821 
 sub hint {
          return $self->{hints}->{$key};
  }
- =head2 hits
+ =head2 hints
  More perlish version of C<hint>. This one returns hash.
-Line 843 
 or in more verbose form
+Line 875 
 or in more verbose form
    my $node = new Search::HyperEstraier::Node(
          url => 'http://localhost:1978/node/test',
+         user => 'admin',
+         passwd => 'admin'
+         create => 1,
+         label => 'optional node label',
          debug => 1,
          croak_on_error => 1
    );
-Line 855 
 with following arguments:
+Line 891 
 with following arguments:
  URL to node
+ =item user
+ specify username for node server authentication
+ =item passwd
+ password for authentication
+ =item create
+ create node if it doesn't exists
+ =item label
+ optional label for new node if C<create> is used
  =item debug
  dumps a B<lot> of debugging output
-Line 874 
 sub new {
+Line 926 
 sub new {
          my $self = {
                  pxport => -1,
                  timeout => 0,   # this used to be -1
-                 dnum => -1,
-                 wnum => -1,
-                 size => -1.0,
                  wwidth => 480,
                  hwidth => 96,
                  awidth => 96,
                  status => -1,
          };
          bless($self, $class);
          if ($#_ == 0) {
                  $self->{url} = shift;
          } else {
-                 my $args = {@_};
                  %$self = ( %$self, @_ );
+                 $self->set_auth( $self->{user}, $self->{passwd} ) if ($self->{user});
                  warn "## Node debug on\n" if ($self->{debug});
          }
+         $self->{inform} = {
+                 dnum => -1,
+                 wnum => -1,
+                 size => -1.0,
+         };
+         if ($self->{create}) {
+                 if (! eval { $self->name } || $@) {
+                         my $name = $1 if ($self->{url} =~ m#/node/([^/]+)/*#);
+                         croak "can't find node name in '$self->{url}'" unless ($name);
+                         my $label = $self->{label} || $name;
+                         $self->master(
+                                 action => 'nodeadd',
+                                 name => $name,
+                                 label => $label,
+                         ) || croak "can't create node $name ($label)";
+                 }
+         }
          $self ? return $self : return undef;
  }
-Line 1015 
 sub out_doc {
+Line 1084 
 sub out_doc {
          my $id = shift || return;
          return unless ($self->{url});
          croak "id must be number, not '$id'" unless ($id =~ m/^\d+$/);
-         $self->shuttle_url( $self->{url} . '/out_doc',
+         if ($self->shuttle_url( $self->{url} . '/out_doc',
                  'application/x-www-form-urlencoded',
                  "id=$id",
                  undef
-         ) == 200;
+         ) == 200) {
+                 $self->_set_info;
+                 return $id;
+         }
+         return undef;
  }
-Line 1037 
 sub out_doc_by_uri {
+Line 1110 
 sub out_doc_by_uri {
          my $self = shift;
          my $uri = shift || return;
          return unless ($self->{url});
-         $self->shuttle_url( $self->{url} . '/out_doc',
+         if ($self->shuttle_url( $self->{url} . '/out_doc',
                  'application/x-www-form-urlencoded',
                  "uri=" . uri_escape($uri),
                  undef
-         ) == 200;
+         ) == 200) {
+                 $self->_set_info;
+                 return $uri;
+         }
+         return undef;
  }
-Line 1270 
 sub _fetch_doc {
+Line 1347 
 sub _fetch_doc {
  sub name {
          my $self = shift;
-         $self->_set_info unless ($self->{name});
+         $self->_set_info unless ($self->{inform}->{name});
-         return $self->{name};
+         return $self->{inform}->{name};
  }
-Line 1283 
 sub name {
+Line 1360 
 sub name {
  sub label {
          my $self = shift;
-         $self->_set_info unless ($self->{label});
+         $self->_set_info unless ($self->{inform}->{label});
-         return $self->{label};
+         return $self->{inform}->{label};
  }
-Line 1296 
 sub label {
+Line 1373 
 sub label {
  sub doc_num {
          my $self = shift;
-         $self->_set_info if ($self->{dnum} < 0);
+         $self->_set_info if ($self->{inform}->{dnum} < 0);
-         return $self->{dnum};
+         return $self->{inform}->{dnum};
  }
-Line 1309 
 sub doc_num {
+Line 1386 
 sub doc_num {
  sub word_num {
          my $self = shift;
-         $self->_set_info if ($self->{wnum} < 0);
+         $self->_set_info if ($self->{inform}->{wnum} < 0);
-         return $self->{wnum};
+         return $self->{inform}->{wnum};
  }
-Line 1322 
 sub word_num {
+Line 1399 
 sub word_num {
  sub size {
          my $self = shift;
-         $self->_set_info if ($self->{size} < 0);
+         $self->_set_info if ($self->{inform}->{size} < 0);
-         return $self->{size};
+         return $self->{inform}->{size};
  }
-Line 1356 
 sub search {
+Line 1433 
 sub search {
          );
          return if ($rv != 200);
-         my (@docs, $hints);
+         my @records     = split /--------\[.*?\]--------(?::END)?\r?\n/, $resbody;
+         my $hintsText   = splice @records, 0, 2; # starts with empty record
-         my @lines = split(/\n/, $resbody);
+         my $hints               = { $hintsText =~ m/^(.*?)\t(.*?)$/gsm };
-         return unless (@lines);
+         # process records
-         my $border = $lines[0];
+         my $docs = [];
-         my $isend = 0;
+         foreach my $record (@records)
-         my $lnum = 1;
+         {
+                 # split into keys and snippets
-         while ( $lnum <= $#lines ) {
+                 my ($keys, $snippet) = $record =~ m/^(.*?)\n\n(.*?)$/s;
-                 my $line = $lines[$lnum];
-                 $lnum++;
+                 # create document hash
+                 my $doc                         = { $keys =~ m/^(.*?)=(.*?)$/gsm };
-                 #warn "## $line\n";
+                 $doc->{'@keywords'}     = $doc->{keywords};
-                 if ($line && $line =~ m/^\Q$border\E(:END)*$/) {
+                 ($doc->{keywords})      = $keys =~ m/^%VECTOR\t(.*?)$/gm;
-                         $isend = $1;
+                 $doc->{snippet}         = $snippet;
-                         last;
-                 }
+                 push @$docs, new Search::Estraier::ResultDocument(
+                         attrs           => $doc,
-                 if ($line =~ /\t/) {
+                         uri             => $doc->{'@uri'},
-                         my ($k,$v) = split(/\t/, $line, 2);
+                         snippet         => $snippet,
-                         $hints->{$k} = $v;
+                         keywords        => $doc->{'keywords'},
-                 }
+                 );
-         }
-         my $snum = $lnum;
-         while( ! $isend && $lnum <= $#lines ) {
-                 my $line = $lines[$lnum];
-                 #warn "# $lnum: $line\n";
-                 $lnum++;
-                 if ($line && $line =~ m/^\Q$border\E/) {
-                         if ($lnum > $snum) {
-                                 my $rdattrs;
-                                 my $rdvector;
-                                 my $rdsnippet;
-                                 my $rlnum = $snum;
-                                 while ($rlnum < $lnum - 1 ) {
-                                         #my $rdline = $self->_s($lines[$rlnum]);
-                                         my $rdline = $lines[$rlnum];
-                                         $rlnum++;
-                                         last unless ($rdline);
-                                         if ($rdline =~ /^%/) {
-                                                 $rdvector = $1 if ($rdline =~ /^%VECTOR\t(.+)$/);
-                                         } elsif($rdline =~ /=/) {
-                                                 $rdattrs->{$1} = $2 if ($rdline =~ /^(.+)=(.+)$/);
-                                         } else {
-                                                 confess "invalid format of response";
-                                         }
-                                 }
-                                 while($rlnum < $lnum - 1) {
-                                         my $rdline = $lines[$rlnum];
-                                         $rlnum++;
-                                         $rdsnippet .= "$rdline\n";
-                                 }
-                                 #warn Dumper($rdvector, $rdattrs, $rdsnippet);
-                                 if (my $rduri = $rdattrs->{'@uri'}) {
-                                         push @docs, new Search::Estraier::ResultDocument(
-                                                 uri => $rduri,
-                                                 attrs => $rdattrs,
-                                                 snippet => $rdsnippet,
-                                                 keywords => $rdvector,
-                                         );
-                                 }
-                         }
-                         $snum = $lnum;
-                         #warn "### $line\n";
-                         $isend = 1 if ($line =~ /:END$/);
-                 }
-         }
-         if (! $isend) {
-                 warn "received result doesn't have :END\n$resbody";
-                 return;
          }
-         #warn Dumper(\@docs, $hints);
+         return new Search::Estraier::NodeResult( docs => $docs, hints => $hints );
-         return new Search::Estraier::NodeResult( docs => \@docs, hints => $hints );
  }
-Line 1486 
 sub cond_to_query {
+Line 1507 
 sub cond_to_query {
          push @args, 'wwidth=' . $self->{wwidth};
          push @args, 'hwidth=' . $self->{hwidth};
          push @args, 'awidth=' . $self->{awidth};
+         push @args, 'skip=' . $self->{skip} if ($self->{skip});
          return join('&', @args);
  }
-Line 1659 
 sub set_link {
+Line 1681 
 sub set_link {
          my $reqbody = 'url=' . uri_escape($url) . '&label=' . uri_escape($label);
          $reqbody .= '&credit=' . $credit if ($credit > 0);
-         $self->shuttle_url( $self->{url} . '/_set_link',
+         if ($self->shuttle_url( $self->{url} . '/_set_link',
                  'application/x-www-form-urlencoded',
                  $reqbody,
                  undef
-         ) == 200;
+         ) == 200) {
+                 # refresh node info after adding link
+                 $self->_set_info;
+                 return 1;
+         }
+         return undef;
+ }
+ =head2 admins
+  my @admins = @{ $node->admins };
+ Return array of users with admin rights on node
+ =cut
+ sub admins {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{admins};
+ }
+ =head2 guests
+  my @guests = @{ $node->guests };
+ Return array of users with guest rights on node
+ =cut
+ sub guests {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{guests};
  }
+ =head2 links
+  my $links = @{ $node->links };
+ Return array of links for this node
+ =cut
+ sub links {
+         my $self = shift;
+         $self->_set_info unless ($self->{inform}->{name});
+         return $self->{inform}->{links};
+ }
+ =head2 master
+ Set actions on Hyper Estraier node master (C<estmaster> process)
+   $node->master(
+         action => 'sync'
+   );
+ All available actions are documented in
+ L<http://hyperestraier.sourceforge.net/nguide-en.html#protocol>
+ =cut
+ my $estmaster_rest = {
+         shutdown => {
+                 status => 202,
+         },
+         sync => {
+                 status => 202,
+         },
+         backup => {
+                 status => 202,
+         },
+         userlist => {
+                 status => 200,
+                 returns => [ qw/name passwd flags fname misc/ ],
+         },
+         useradd => {
+                 required => [ qw/name passwd flags/ ],
+                 optional => [ qw/fname misc/ ],
+                 status => 200,
+         },
+         userdel => {
+                 required => [ qw/name/ ],
+                 status => 200,
+         },
+         nodelist => {
+                 status => 200,
+                 returns => [ qw/name label doc_num word_num size/ ],
+         },
+         nodeadd => {
+                 required => [ qw/name/ ],
+                 optional => [ qw/label/ ],
+                 status => 200,
+         },
+         nodedel => {
+                 required => [ qw/name/ ],
+                 status => 200,
+         },
+         nodeclr => {
+                 required => [ qw/name/ ],
+                 status => 200,
+         },
+         nodertt => {
+                 status => 200,
+         },
+ };
+ sub master {
+         my $self = shift;
+         my $args = {@_};
+         # have action?
+         my $action = $args->{action} || croak "need action, available: ",
+                 join(", ",keys %{ $estmaster_rest });
+         # check if action is valid
+         my $rest = $estmaster_rest->{$action};
+         croak "action '$action' is not supported, available actions: ",
+                 join(", ",keys %{ $estmaster_rest }) unless ($rest);
+         croak "BUG: action '$action' needs return status" unless ($rest->{status});
+         my @args;
+         if ($rest->{required} || $rest->{optional}) {
+                 map {
+                         croak "need parametar '$_' for action '$action'" unless ($args->{$_});
+                         push @args, $_ . '=' . uri_escape( $args->{$_} );
+                 } ( @{ $rest->{required} } );
+                 map {
+                         push @args, $_ . '=' . uri_escape( $args->{$_} ) if ($args->{$_});
+                 } ( @{ $rest->{optional} } );
+         }
+         my $uri = new URI( $self->{url} );
+         my $resbody;
+         my $status = $self->shuttle_url(
+                 'http://' . $uri->host_port . '/master?action=' . $action ,
+                 'application/x-www-form-urlencoded',
+                 join('&', @args),
+                 \$resbody,
+,
+         ) or confess "shuttle_url failed";
+         if ($status == $rest->{status}) {
+                 # refresh node info after sync
+                 $self->_set_info if ($action eq 'sync');
+                 if ($rest->{returns} && wantarray) {
+                         my @results;
+                         my $fields = $#{$rest->{returns}};
+                         foreach my $line ( split(/[\r\n]/,$resbody) ) {
+                                 my @e = split(/\t/, $line, $fields + 1);
+                                 my $row;
+                                 foreach my $i ( 0 .. $fields) {
+                                         $row->{ $rest->{returns}->[$i] } = $e[ $i ];
+                                 }
+                                 push @results, $row;
+                         }
+                         return @results;
+                 } elsif ($resbody) {
+                         chomp $resbody;
+                         return $resbody;
+                 } else {
+                         return 0E0;
+                 }
+         }
+         carp "expected status $rest->{status}, but got $status";
+         return undef;
+ }
  =head1 PRIVATE METHODS
-Line 1694 
 sub _set_info {
+Line 1896 
 sub _set_info {
          return if ($rv != 200 || !$resbody);
-         # it seems that response can have multiple line endings
+         my @lines = split(/[\r\n]/,$resbody);
-         $resbody =~ s/[\r\n]+$//;
+         $self->{inform} = {};
+         ( $self->{inform}->{name}, $self->{inform}->{label}, $self->{inform}->{dnum},
+                 $self->{inform}->{wnum}, $self->{inform}->{size} ) = split(/\t/, shift @lines, 5);
+         return $resbody unless (@lines);
+         shift @lines;
+         while(my $admin = shift @lines) {
+                 push @{$self->{inform}->{admins}}, $admin;
+         }
+         while(my $guest = shift @lines) {
+                 push @{$self->{inform}->{guests}}, $guest;
+         }
+         while(my $link = shift @lines) {
+                 push @{$self->{inform}->{links}}, $link;
+         }
-         ( $self->{name}, $self->{label}, $self->{dnum}, $self->{wnum}, $self->{size} ) =
+         return $resbody;
-                 split(/\t/, $resbody, 5);
  }
-Line 1718 
 Hyper Estraier Ruby interface on which t
+Line 1939 
 Hyper Estraier Ruby interface on which t
  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
+ Robert Klep E<lt>robert@klep.nameE<gt> contributed refactored search code
  =head1 COPYRIGHT AND LICENSE

 Legend:



Removed from v.103
 


changed lines


 
Added in v.150
 Legend:



Removed from v.103
 


changed lines


 
Added in v.150
-Removed from v.103
+Added in v.150

	ViewVC Help
Powered by ViewVC 1.1.26