/[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 30 by dpavlin,
Thu Jan  5 15:33:48 2006 UTC
+revision 42 by dpavlin,
Thu Jan  5 23:38:32 2006 UTC
 Line 27 
 implementation. It also includes methods
  =cut
+ =head1 Inheritable common methods
+ This methods should really move somewhere else.
  =head2 _s
  Remove multiple whitespaces from string, as well as whitespaces at beginning or end
-Line 56 
 our @ISA = qw/Search::Estraier/;
+Line 60 
 our @ISA = qw/Search::Estraier/;
  This class implements Document which is collection of attributes
  (key=value), vectors (also key value) display text and hidden text.
  =head2 new
  Create new document, empty or from draft.
-Line 175 
 sub add_hidden_text {
+Line 180 
 sub add_hidden_text {
          push @{ $self->{htexts} }, $self->_s($text);
  }
  =head2 id
  Get the ID number of document. If the object has never been registred, C<-1> is returned.
-Line 188 
 sub id {
+Line 194 
 sub id {
          return $self->{id};
  }
  =head2 attr_names
  Returns array with attribute names from document object.
-Line 233 
 sub texts {
+Line 240 
 sub texts {
          return @{ $self->{dtexts} };
  }
  =head2 cat_texts
  Return whole text as single scalar.
-Line 246 
 sub cat_texts {
+Line 254 
 sub cat_texts {
          return join(' ',@{ $self->{dtexts} });
  }
  =head2 dump_draft
  Dump draft data from document object.
-Line 272 
 sub dump_draft {
+Line 281 
 sub dump_draft {
          $draft .= "\n";
-         $draft .= join("\n", @{ $self->{dtexts} }) . "\n";
+         $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
-         $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";
+         $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
          return $draft;
  }
  =head2 delete
  Empty document object
-Line 330 
 sub new {
+Line 340 
 sub new {
          $self ? return $self : return undef;
  }
  =head2 set_phrase
    $cond->set_phrase('search phrase');
-Line 341 
 sub set_phrase {
+Line 352 
 sub set_phrase {
          $self->{phrase} = $self->_s( shift );
  }
  =head2 add_attr
    $cond->add_attr('@URI STRINC /~dpavlin/');
-Line 353 
 sub add_attr {
+Line 365 
 sub add_attr {
          push @{ $self->{attrs} }, $self->_s( $attr );
  }
  =head2 set_order
    $cond->set_order('@mdate NUMD');
-Line 364 
 sub set_order {
+Line 377 
 sub set_order {
          $self->{order} = shift;
  }
  =head2 set_max
    $cond->set_max(42);
-Line 377 
 sub set_max {
+Line 391 
 sub set_max {
          $self->{max} = $max;
  }
  =head2 set_options
    $cond->set_options( SURE => 1 );
-Line 405 
 sub set_options {
+Line 420 
 sub set_options {
          $self->{options} ||= $options->{$option};
  }
  =head2 phrase
  Return search phrase.
-Line 418 
 sub phrase {
+Line 434 
 sub phrase {
          return $self->{phrase};
  }
  =head2 order
  Return search result order.
-Line 431 
 sub order {
+Line 448 
 sub order {
          return $self->{order};
  }
  =head2 attrs
  Return search result attrs.
-Line 445 
 sub attrs {
+Line 463 
 sub attrs {
          return @{ $self->{attrs} };
  }
  =head2 max
  Return maximum number of results.
-Line 460 
 sub max {
+Line 479 
 sub max {
          return $self->{max};
  }
  =head2 options
  Return options for this condition.
-Line 511 
 sub new {
+Line 531 
 sub new {
          $self ? return $self : return undef;
  }
  =head2 uri
  Return URI of result document
-Line 539 
 sub attr_names {
+Line 560 
 sub attr_names {
          return sort keys %{ $self->{attrs} };
  }
  =head2 attr
  Returns value of an attribute.
-Line 553 
 sub attr {
+Line 575 
 sub attr {
          return $self->{attrs}->{ $name };
  }
  =head2 snippet
  Return snippet from result document
-Line 566 
 sub snippet {
+Line 589 
 sub snippet {
          return $self->{snippet};
  }
  =head2 keywords
  Return keywords from result document
-Line 610 
 sub new {
+Line 634 
 sub new {
          $self ? return $self : return undef;
  }
  =head2 doc_num
  Return number of documents
-Line 623 
 sub doc_num {
+Line 648 
 sub doc_num {
          return $#{$self->{docs}};
  }
  =head2 get_doc
  Return single document
-Line 641 
 sub get_doc {
+Line 667 
 sub get_doc {
          return $self->{docs}->[$num];
  }
  =head2 hint
  Return specific hint from results.
-Line 661 
 sub hint {
+Line 688 
 sub hint {
  package Search::Estraier::Node;
- use Carp qw/croak/;
+ use Carp qw/carp croak/;
+ use URI;
+ use MIME::Base64;
+ use IO::Socket::INET;
  =head1 Search::Estraier::Node
-Line 675 
 sub new {
+Line 705 
 sub new {
          my $class = shift;
          my $self = {
                  pxport => -1,
-                 timeout => -1,
+                 timeout => 0,   # this used to be -1
                  dnum => -1,
                  wnum => -1,
                  size => -1.0,
-Line 686 
 sub new {
+Line 716 
 sub new {
          };
          bless($self, $class);
+         if (@_) {
+                 $self->{debug} = shift;
+                 warn "## Node debug on\n";
+         }
          $self ? return $self : return undef;
  }
  =head2 set_url
  Specify URL to node server
-Line 702 
 sub set_url {
+Line 738 
 sub set_url {
          $self->{url} = shift;
  }
  =head2 set_proxy
  Specify proxy server to connect to node server
-Line 718 
 sub set_proxy {
+Line 755 
 sub set_proxy {
          $self->{pxport} = $port;
  }
  =head2 set_timeout
  Specify timeout of connection in seconds
-Line 733 
 sub set_timeout {
+Line 771 
 sub set_timeout {
          $self->{timeout} = $sec;
  }
- package Search::Estraier::Master;
- use Carp;
+ =head2 set_auth
- =head1 Search::Estraier::Master
+ Specify name and password for authentication to node server.
- Controll node master. This requires user with administration priviledges.
+   $node->set_auth('clint','eastwood');
  =cut
- {
+ sub set_auth {
-         package RequestAgent;
+         my $self = shift;
-         our @ISA = qw(LWP::UserAgent);
+         my ($login,$passwd) = @_;
+         my $basic_auth = encode_base64( "$login:$passwd" );
+         chomp($basic_auth);
+         $self->{auth} = $basic_auth;
+ }
-         sub new {
-                 my $self = LWP::UserAgent::new(@_);
-                 $self->agent("Search-Estraier/$Search::Estraer::VERSION");
-                 $self;
-         }
-         sub get_basic_credentials {
+ =head2 status
-                 my($self, $realm, $uri) = @_;
- #               return ($user, $password);
+ Return status code of last request.
-         }
+   print $node->status;
+ C<-1> means connection failure.
+ =cut
+ sub status {
+         my $self = shift;
+         return $self->{status};
  }
+ =head2 put_doc
- =head2 new
+ Add a document
- Create new connection to node master.
+   $node->put_doc( $document_draft ) or die "can't add document";
-   my $master = new Search::Estraier::Master(
+ Return true on success or false on failture.
-         url => 'http://localhost:1978',
-         user => 'admin',
-         passwd => 'admin',
-   );
  =cut
- sub new {
+ sub put_doc {
-         my $class = shift;
+         my $self = shift;
-         my $self = {@_};
+         my $doc = shift || return;
-         bless($self, $class);
+         return unless ($self->{url});
+         $self->shuttle_url( $self->{url} . '/put_doc',
+                 'text/x-estraier-draft',
+                 $doc->dump_draft,
+                 undef
+         ) == 200;
+ }
-         foreach my $p (qw/url user passwd/) {
-                 croak "need $p" unless ($self->{$p});
-         }
-         $self ? return $self : return undef;
+ =head2 out_doc
+ Remove a document
+   $node->out_doc( document_id ) or "can't remove document";
+ Return true on success or false on failture.
+ =cut
+ sub out_doc {
+         my $self = shift;
+         my $id = shift || return;
+         return unless ($self->{url});
+         croak "id must be number" unless ($id =~ m/^\d+$/);
+         $self->shuttle_url( $self->{url} . '/out_doc',
+                 'application/x-www-form-urlencoded',
+                 "id=$id",
+                 undef
+         ) == 200;
+ }
+ =head2 out_doc_by_uri
+ Remove a registrated document using it's uri
+   $node->out_doc_by_uri( 'file:///document_url' ) or "can't remove document";
+ Return true on success or false on failture.
+ =cut
+ sub out_doc_by_uri {
+         my $self = shift;
+         my $uri = shift || return;
+         return unless ($self->{url});
+         $self->shuttle_url( $self->{url} . '/out_doc',
+                 'application/x-www-form-urlencoded',
+                 "uri=$uri",
+                 undef
+         ) == 200;
+ }
+ =head2 edit_doc
+ Edit attributes of a document
+   $node->edit_doc( $document_draft ) or die "can't edit document";
+ Return true on success or false on failture.
+ =cut
+ sub edit_doc {
+         my $self = shift;
+         my $doc = shift || return;
+         return unless ($self->{url});
+         $self->shuttle_url( $self->{url} . '/edit_doc',
+                 'text/x-estraier-draft',
+                 $doc->dump_draft,
+                 undef
+         ) == 200;
  }
+ =head2 shuttle_url
+ This is method which uses C<IO::Socket::INET> to communicate with Hyper Estraier node
+ master.
+   my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );
+ C<$resheads> and C<$resbody> booleans controll if response headers and/or response
+ body will be saved within object.
+ =cut
+ sub shuttle_url {
+         my $self = shift;
+         my ($url, $content_type, $reqbody, $resbody) = @_;
+         $self->{status} = -1;
+         warn "## $url\n" if ($self->{debug});
+         $url = new URI($url);
+         if (
+                         !$url || !$url->scheme || !$url->scheme eq 'http' ||
+                         !$url->host || !$url->port || $url->port < 1
+                 ) {
+                 carp "can't parse $url\n";
+                 return -1;
+         }
+         my ($host,$port,$query) = ($url->host, $url->port, $url->path);
+         if ($self->{pxhost}) {
+                 ($host,$port) = ($self->{pxhost}, $self->{pxport});
+                 $query = "http://$host:$port/$query";
+         }
+         $query .= '?' . $url->query if ($url->query && ! $reqbody);
+         my $headers;
+         if ($reqbody) {
+                 $headers .= "POST $query HTTP/1.0\r\n";
+         } else {
+                 $headers .= "GET $query HTTP/1.0\r\n";
+         }
+         $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";
+         $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;
+         }
+         warn $headers if ($self->{debug});
+         print $sock $headers or
+                 carp "can't send headers to network:\n$headers\n" and return -1;
+         if ($reqbody) {
+                 warn "$reqbody\n" if ($self->{debug});
+                 print $sock $reqbody or
+                         carp "can't send request body to network:\n$$reqbody\n" and return -1;
+         }
+         my $line = <$sock>;
+         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);
+         warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
+         return $self->{status};
+ }
  ###

 Legend:



Removed from v.30
 


changed lines


 
Added in v.42
 Legend:



Removed from v.30
 


changed lines


 
Added in v.42
-Removed from v.30
+Added in v.42

	ViewVC Help
Powered by ViewVC 1.1.26