File Coverage

blib/lib/WAIT/Client.pm
Criterion Covered Total %
statement 27 109 24.7
branch 0 48 0.0
condition 0 5 0.0
subroutine 9 29 31.0
pod 0 6 0.0
total 36 197 18.2


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             # -*- Mode: Perl -*-
3             # $Basename: Client.pm $
4             # $Revision: 1.3 $
5             # Author : Ulrich Pfeifer
6             # Created On : Fri Jan 31 10:49:37 1997
7             # Last Modified By: Ulrich Pfeifer
8             # Last Modified On: Mon Aug 11 17:06:51 1997
9             # Language : CPerl
10             # Update Count : 88
11             # Status : Unknown, Use with caution!
12             #
13             # (C) Copyright 1997, Ulrich Pfeifer, all rights reserved.
14             #
15             #
16              
17             package WAIT::Client;
18 1     1   1063 use Net::NNTP ();
  1         67103  
  1         30  
19 1     1   11 use Net::Cmd qw(CMD_OK);
  1         1  
  1         74  
20 1     1   5 use Carp;
  1         2  
  1         47  
21 1     1   5 use strict;
  1         2  
  1         29  
22 1     1   4 use vars qw(@ISA);
  1         2  
  1         504  
23              
24             @ISA = qw(Net::NNTP);
25              
26             sub search
27             {
28 0     0 0   my $wait = shift;
29            
30 0 0         $wait->_SEARCH(@_)
31             ? $wait->read_until_dot()
32             : undef;
33             }
34              
35             sub info
36             {
37 0 0   0 0   @_ == 2 or croak 'usage: $wait->info( HIT-NUMBER )';
38 0           my $wait = shift;
39            
40 0 0         $wait->_INFO(@_)
41             ? $wait->read_until_dot()
42             : undef;
43             }
44              
45             sub get
46             {
47 0 0   0 0   @_ == 2 or croak 'usage: $wait->info( HIT-NUMBER )';
48 0           my $wait = shift;
49            
50 0 0         $wait->_GET(@_)
51             ? $wait->read_until_dot()
52             : undef;
53             }
54              
55             sub database
56             {
57 0 0   0 0   @_ == 2 or croak 'usage: $wait->database( DBNAME )';
58 0           my $wait = shift;
59            
60 0           $wait->_DATABASE(@_);
61             }
62              
63             sub table
64             {
65 0 0   0 0   @_ == 2 or croak 'usage: $wait->table( TABLE )';
66 0           my $wait = shift;
67            
68 0           $wait->_TABLE(@_);
69             }
70              
71             sub hits
72             {
73 0 0   0 0   @_ == 2 or croak 'usage: $wait->hits( NUM-MAX-HITS )';
74 0           my $wait = shift;
75            
76 0           $wait->_HITS(@_);
77             }
78              
79 0     0     sub _SEARCH { shift->command('SEARCH', @_)->response == CMD_OK }
80 0     0     sub _INFO { shift->command('INFO', @_)->response == CMD_OK }
81 0     0     sub _GET { shift->command('GET', @_)->response == CMD_OK }
82 0     0     sub _DATABASE { shift->command('DATABASE', @_)->response == CMD_OK }
83 0     0     sub _TABLE { shift->command('TABLE', @_)->response == CMD_OK }
84 0     0     sub _HITS { shift->command('HITS', @_)->response == CMD_OK }
85              
86             # The following is a real hack. Don't look at it ;-) It tries to
87             # emulate a stateful protocol over HTTP which is weird and slow.
88             package WAIT::Client::HTTP;
89 1     1   5 use Net::Cmd;
  1         2  
  1         56  
90 1     1   5 use vars qw(@ISA);
  1         2  
  1         34  
91 1     1   4 use Carp;
  1         1  
  1         752  
92              
93             @ISA = qw(WAIT::Client);
94              
95             sub new {
96 0     0     my $type = shift;
97 0           my $host = shift;
98 0           my %parm = @_;
99 0           my ($proxy, $port) = ($parm{Proxy} =~ m{^(?:http://)(\S+)(?::(\d+))});
100 0 0         $port = 80 unless $port;
101            
102 0   0       my $self = {
103             proxy_host => $proxy,
104             proxy_port => $port,
105             wais_host => $host,
106             wais_port => $parm{Port},
107             timeout => $parm{Timeout}||120,
108             };
109 0           bless $self, $type;
110              
111 0           my $con;
112 0 0 0       if ($con = $self->command('HELP') and $con->response == CMD_INFO) {
113 0           return $self;
114             } else {
115 0           return;
116             }
117             }
118              
119             sub command {
120 0     0     my $self = shift;
121 0           my $con = # Constructor inherited from IO::Socket::INET
122             WAIT::Client::HTTP::Handle->new
123             (
124             PeerAddr => $self->{proxy_host},
125             PeerPort => $self->{proxy_port},
126             Proto => 'tcp',
127             );
128 0 0         return unless $con;
129              
130 0 0         $con->timeout($self->{timeout}) if defined $self->{timeout};
131 0           my $cmd = join ' ', @_;
132            
133 0 0         if ($self->{hits}) {
134 0           $cmd = "HITS $self->{hits}:$cmd";
135             }
136 0           $cmd = "Command: $cmd";
137 0           $con->autoflush(1);
138            
139 0           $con->printf("POST http://$self->{wais_host}:$self->{wais_port} ".
140             "HTTP/1.0\nContent-Length: %d\n\n$cmd",
141             length($cmd));
142            
143 0 0         unless ($con->response == CMD_OK) {
144 0           warn "No greeting from server\n";
145             }
146 0 0         if ($self->{hits}) {
147 0 0         unless ($con->response == CMD_OK) {
148 0           warn "Hits not aknowledged\n";
149             }
150             }
151 0           $self->{con} = $con;
152 0           $con;
153             }
154              
155             # We map here raw document id's to rank numbers and back for
156             # convenience. Besides that the following search(), info(), and get()
157             # are obsolete.
158              
159             sub search
160             {
161 0     0     my $wait = shift;
162            
163 0 0         if ($wait->_SEARCH(@_)) {
164 0           my $r = $wait->read_until_dot();
165 0           my $i = 1;
166            
167 0           delete $wait->{'map'};
168 0           for (@$r) {
169 0 0         if (s/^(\d+)/sprintf("%4d",$i)/e) {
  0            
170 0           $wait->{'map'}->[$i++] = $1;
171             }
172             }
173 0           return $r;
174             }
175 0           return undef;
176             }
177              
178             sub info
179             {
180 0 0   0     @_ == 2 or croak 'usage: $wait->info( HIT-NUMBER )';
181 0           my $wait = shift;
182 0           my $num = shift;
183              
184 0 0         unless ($wait->{'map'}->[$num]) {
185 0           print "No such hit: $num\n";
186 0           return;
187             }
188 0 0         $wait->_INFO($wait->{'map'}->[$num])
189             ? $wait->read_until_dot()
190             : undef;
191             }
192              
193             sub get
194             {
195 0 0   0     @_ == 2 or croak 'usage: $wait->info( HIT-NUMBER )';
196 0           my $wait = shift;
197 0           my $num = shift;
198              
199 0 0         unless ($wait->{'map'}->[$num]) {
200 0           print "No such hit: $num\n";
201 0           return;
202             }
203 0 0         $wait->_GET($wait->{'map'}->[$num])
204             ? $wait->read_until_dot()
205             : undef;
206             }
207              
208             # We must store the hit count locally
209             sub _HITS {
210 0     0     my $self = shift;
211 0           my $hits = shift;
212              
213 0           $self->{hits} = $hits;
214 0           ["Setting maximum hit count to $hits"];
215             }
216              
217             # We should use AUTOLOAD here. I know ;-)
218 0     0     sub read_until_dot {shift->{con}->read_until_dot(@_)}
219 0     0     sub message {shift->{con}->message(@_)}
220              
221             package WAIT::Client::HTTP::Handle;
222 1     1   5 use vars qw(@ISA);
  1         1  
  1         52  
223              
224             @ISA = qw(Net::Cmd IO::Socket::INET);
225              
226              
227             1;