/[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 30 by dpavlin, Thu Jan 5 15:33:48 2006 UTC revision 41 by dpavlin, Thu Jan 5 23:32:31 2006 UTC
# Line 272  sub dump_draft { Line 272  sub dump_draft {
272    
273          $draft .= "\n";          $draft .= "\n";
274    
275          $draft .= join("\n", @{ $self->{dtexts} }) . "\n";          $draft .= join("\n", @{ $self->{dtexts} }) . "\n" if ($self->{dtexts});
276          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n";          $draft .= "\t" . join("\n\t", @{ $self->{htexts} }) . "\n" if ($self->{htexts});
277    
278          return $draft;          return $draft;
279  }  }
# Line 661  sub hint { Line 661  sub hint {
661    
662  package Search::Estraier::Node;  package Search::Estraier::Node;
663    
664  use Carp qw/croak/;  use Carp qw/carp croak/;
665    use URI;
666    use MIME::Base64;
667    use IO::Socket::INET;
668    
669  =head1 Search::Estraier::Node  =head1 Search::Estraier::Node
670    
# Line 675  sub new { Line 678  sub new {
678          my $class = shift;          my $class = shift;
679          my $self = {          my $self = {
680                  pxport => -1,                  pxport => -1,
681                  timeout => -1,                  timeout => 0,   # this used to be -1
682                  dnum => -1,                  dnum => -1,
683                  wnum => -1,                  wnum => -1,
684                  size => -1.0,                  size => -1.0,
# Line 686  sub new { Line 689  sub new {
689          };          };
690          bless($self, $class);          bless($self, $class);
691    
692            if (@_) {
693                    $self->{debug} = shift;
694                    warn "## Node debug on\n";
695            }
696    
697          $self ? return $self : return undef;          $self ? return $self : return undef;
698  }  }
699    
# Line 733  sub set_timeout { Line 741  sub set_timeout {
741          $self->{timeout} = $sec;          $self->{timeout} = $sec;
742  }  }
743    
744  package Search::Estraier::Master;  =head2 set_auth
745    
746    Specify name and password for authentication to node server.
747    
748      $node->set_auth('clint','eastwood');
749    
750    =cut
751    
752    sub set_auth {
753            my $self = shift;
754            my ($login,$passwd) = @_;
755            my $basic_auth = encode_base64( "$login:$passwd" );
756            chomp($basic_auth);
757            $self->{auth} = $basic_auth;
758    }
759    
760    =head2 status
761    
762  use Carp;  Return status code of last request.
763    
764  =head1 Search::Estraier::Master    print $node->status;
765    
766  Controll node master. This requires user with administration priviledges.  C<-1> means connection failure.
767    
768  =cut  =cut
769    
770  {  sub status {
771          package RequestAgent;          my $self = shift;
772          our @ISA = qw(LWP::UserAgent);          return $self->{status};
773    }
774    
775          sub new {  =head2 put_doc
                 my $self = LWP::UserAgent::new(@_);  
                 $self->agent("Search-Estraier/$Search::Estraer::VERSION");  
                 $self;  
         }  
776    
777          sub get_basic_credentials {  Add a document
778                  my($self, $realm, $uri) = @_;  
779  #               return ($user, $password);    $node->put_doc( $document_draft ) or die "can't add document";
780          }  
781    Return true on success or false on failture.
782    
783    =cut
784    
785    sub put_doc {
786            my $self = shift;
787            my $doc = shift || return;
788            return unless ($self->{url});
789            $self->shuttle_url( $self->{url} . '/put_doc',
790                    'text/x-estraier-draft',
791                    $doc->dump_draft,
792                    undef
793            ) == 200;
794  }  }
795    
796    
797    =head2 out_doc
798    
799  =head2 new  Remove a document
800    
801  Create new connection to node master.    $node->out_doc( document_id ) or "can't remove document";
802    
803    my $master = new Search::Estraier::Master(  Return true on success or false on failture.
         url => 'http://localhost:1978',  
         user => 'admin',  
         passwd => 'admin',  
   );  
804    
805  =cut  =cut
806    
807  sub new {  sub out_doc {
808          my $class = shift;          my $self = shift;
809          my $self = {@_};          my $id = shift || return;
810          bless($self, $class);          return unless ($self->{url});
811            croak "id must be number" unless ($id =~ m/^\d+$/);
812            $self->shuttle_url( $self->{url} . '/out_doc',
813                    'application/x-www-form-urlencoded',
814                    "id=$id",
815                    undef
816            ) == 200;
817    }
818    
         foreach my $p (qw/url user passwd/) {  
                 croak "need $p" unless ($self->{$p});  
         }  
819    
820          $self ? return $self : return undef;  =head2 out_doc_by_uri
821    
822    Remove a registrated document using it's uri
823    
824      $node->out_doc_by_uri( 'file:///document_url' ) or "can't remove document";
825    
826    Return true on success or false on failture.
827    
828    =cut
829    
830    sub out_doc_by_uri {
831            my $self = shift;
832            my $uri = shift || return;
833            return unless ($self->{url});
834            $self->shuttle_url( $self->{url} . '/out_doc',
835                    'application/x-www-form-urlencoded',
836                    "uri=$uri",
837                    undef
838            ) == 200;
839  }  }
840    
841    =head2 shuttle_url
842    
843    This is method which uses C<IO::Socket::INET> to communicate with Hyper Estraier node
844    master.
845    
846      my $rv = shuttle_url( $url, $content_type, \$req_body, \$resbody );
847    
848    C<$resheads> and C<$resbody> booleans controll if response headers and/or response
849    body will be saved within object.
850    
851    =cut
852    
853    sub shuttle_url {
854            my $self = shift;
855    
856            my ($url, $content_type, $reqbody, $resbody) = @_;
857    
858            $self->{status} = -1;
859    
860            warn "## $url\n" if ($self->{debug});
861    
862            $url = new URI($url);
863            if (
864                            !$url || !$url->scheme || !$url->scheme eq 'http' ||
865                            !$url->host || !$url->port || $url->port < 1
866                    ) {
867                    carp "can't parse $url\n";
868                    return -1;
869            }
870    
871            my ($host,$port,$query) = ($url->host, $url->port, $url->path);
872    
873            if ($self->{pxhost}) {
874                    ($host,$port) = ($self->{pxhost}, $self->{pxport});
875                    $query = "http://$host:$port/$query";
876            }
877    
878            $query .= '?' . $url->query if ($url->query && ! $reqbody);
879    
880            my $headers;
881    
882            if ($reqbody) {
883                    $headers .= "POST $query HTTP/1.0\r\n";
884            } else {
885                    $headers .= "GET $query HTTP/1.0\r\n";
886            }
887    
888            $headers .= "Host: " . $url->host . ":" . $url->port . "\r\n";
889            $headers .= "Connection: close\r\n";
890            $headers .= "User-Agent: Search-Estraier/$Search::Estraier::VERSION\r\n";
891            $headers .= "Content-Type: $content_type\r\n";
892            $headers .= "Authorization: Basic $self->{auth}\r\n";
893            my $len = 0;
894            {
895                    use bytes;
896                    $len = length($reqbody) if ($reqbody);
897            }
898            $headers .= "Content-Length: $len\r\n";
899            $headers .= "\r\n";
900    
901            my $sock = IO::Socket::INET->new(
902                    PeerAddr        => $host,
903                    PeerPort        => $port,
904                    Proto           => 'tcp',
905                    Timeout         => $self->{timeout} || 90,
906            );
907    
908            if (! $sock) {
909                    carp "can't open socket to $host:$port";
910                    return -1;
911            }
912    
913            warn $headers if ($self->{debug});
914    
915            print $sock $headers or
916                    carp "can't send headers to network:\n$headers\n" and return -1;
917    
918            if ($reqbody) {
919                    warn "$reqbody\n" if ($self->{debug});
920                    print $sock $reqbody or
921                            carp "can't send request body to network:\n$$reqbody\n" and return -1;
922            }
923    
924            my $line = <$sock>;
925            chomp($line);
926            my ($schema, $res_status, undef) = split(/  */, $line, 3);
927            return if ($schema !~ /^HTTP/ || ! $res_status);
928    
929            $self->{status} = $res_status;
930            warn "## response status: $res_status\n" if ($self->{debug});
931    
932            # skip rest of headers
933            $line = <$sock>;
934            while ($line) {
935                    $line = <$sock>;
936                    $line =~ s/[\r\n]+$//;
937                    warn "## ", $line || 'NULL', " ##\n" if ($self->{debug});
938            };
939    
940            # read body
941            $len = 0;
942            do {
943                    $len = read($sock, my $buf, 8192);
944                    $$resbody .= $buf if ($resbody);
945            } while ($len);
946    
947            warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
948    
949            return $self->{status};
950    }
951    
952  ###  ###
953    
Legend:
Removed from v.30  
changed lines
  Added in v.41
  ViewVC Help
Powered by ViewVC 1.1.26