File Coverage

blib/lib/Net/Dict.pm
Criterion Covered Total %
statement 210 233 90.1
branch 65 86 75.5
condition 7 8 87.5
subroutine 34 40 85.0
pod 14 16 87.5
total 330 383 86.1


line stmt bran cond sub pod time code
1             #
2             # Net::Dict.pm
3             #
4             # Copyright (C) 2001-2003 Neil Bowers
5             # Copyright (c) 1998 Dmitry Rubinstein .
6             #
7             # All rights reserved. This program is free software; you can
8             # redistribute it and/or modify it under the same terms as Perl
9             # itself.
10             #
11              
12             package Net::Dict;
13              
14 4     4   110558 use warnings;
  4         11  
  4         157  
15 4     4   23 use strict;
  4         10  
  4         129  
16 4     4   4048 use IO::Socket;
  4         182444  
  4         20  
17 4     4   7311 use Net::Cmd;
  4         25704  
  4         378  
18 4     4   37 use Carp;
  4         10  
  4         234  
19              
20 4     4   21 use vars qw(@ISA $debug);
  4         7  
  4         16760  
21             our $VERSION = '2.18';
22              
23             #-----------------------------------------------------------------------
24             # Default values for arguments to new(). We also use this to
25             # determine valid argument names - if it's not a key of this hash,
26             # then it's not a valid argument.
27             #-----------------------------------------------------------------------
28             my %ARG_DEFAULT =
29             (
30             Port => 2628,
31             Timeout => 120,
32             Debug => 0,
33             Client => "Net::Dict v$VERSION",
34             );
35              
36             @ISA = qw(Net::Cmd IO::Socket::INET);
37              
38             #=======================================================================
39             #
40             # new()
41             #
42             # constructor - open connection to host, get a list of databases,
43             # and send CLIENT identification command.
44             #
45             #=======================================================================
46             sub new
47             {
48 9 100   9 1 7386 @_ > 1 or croak 'usage: Net::Dict->new() takes at least a HOST name';
49 8         17 my $class = shift;
50 8         13 my $host = shift;
51 8 100       227 int(@_) % 2 == 0 or croak 'Net::Dict->new(): odd number of arguments';
52 7         20 my %inargs = @_;
53              
54 7         12 my $self;
55             my $argref;
56              
57              
58 7 100       32 return undef unless defined $host;
59              
60             #-------------------------------------------------------------------
61             # Process arguments, setting defaults if needed
62             #-------------------------------------------------------------------
63 6         15 $argref = {};
64 6         28 foreach my $arg (keys %ARG_DEFAULT) {
65 24 100       76 $argref->{$arg} = exists $inargs{$arg}
66             ? $inargs{$arg}
67             : $ARG_DEFAULT{$arg};
68 24         41 delete $inargs{$arg};
69             }
70              
71 6 100       30 if (keys(%inargs) > 0) {
72 1         241 croak "Net::Dict->new(): unknown argument - ",
73             join(', ', keys %inargs);
74             }
75              
76             #-------------------------------------------------------------------
77             # Make the connection
78             #-------------------------------------------------------------------
79 5         83 $self = $class->SUPER::new(PeerAddr => $host,
80             PeerPort => $argref->{Port},
81             Proto => 'tcp',
82             Timeout => $argref->{Timeout}
83             );
84              
85 5 100       598594 return undef unless defined $self;
86              
87 4         17 ${*$self}{'net_dict_host'} = $host;
  4         33  
88              
89 4         42 $self->autoflush(1);
90 4         294 $self->debug($argref->{Debug});
91              
92 4 50       133 if ($self->response() != CMD_OK) {
93 0         0 $self->close();
94 0         0 return undef;
95             }
96              
97             # parse the initial 220 response
98 4         92 $self->_parse_banner($self->message);
99              
100             #-------------------------------------------------------------------
101             # Send the CLIENT command which identifies the connecting client
102             #-------------------------------------------------------------------
103 4         212 $self->_CLIENT($argref->{Client});
104              
105             #-------------------------------------------------------------------
106             # The default - search ALL dictionaries
107             #-------------------------------------------------------------------
108 4         76 $self->setDicts('*');
109              
110 4         46 return $self;
111             }
112              
113             sub dbs
114             {
115 2 100   2 1 1448 @_ == 1 or croak 'usage: $dict->dbs() - takes no arguments';
116 1         2 my $self = shift;
117              
118 1         4 $self->_get_database_list();
119 1         195 return %{${*$self}{'net_dict_dbs'}};
  1         3  
  1         58  
120             }
121              
122             sub setDicts
123             {
124 8     8 1 5552 my $self = shift;
125              
126 8         19 @{${*$self}{'net_dict_userdbs'}} = @_;
  8         15  
  8         49  
127             }
128              
129             sub serverInfo
130             {
131 1 50   1 1 471 @_ == 1 or croak 'usage: $dict->serverInfo()';
132 1         2 my $self = shift;
133              
134 1 50       6 return 0 unless $self->_SHOW_SERVER();
135              
136 1         22 my $info = join('', @{$self->read_until_dot});
  1         16  
137 1         146518 $self->getline();
138 1         15 $info;
139             }
140              
141             sub dbInfo
142             {
143 4 100   4 1 26487 @_ == 2 or croak 'usage: $dict->dbInfo($dbname) - one argument only';
144 2         4 my $self = shift;
145              
146 2 100       10 if ($self->_SHOW_INFO(@_)) {
147 1         12 return join('', @{$self->read_until_dot()});
  1         18  
148             }
149             else {
150 1         15 return undef;
151             }
152             }
153              
154             sub dbTitle
155             {
156 5 100   5 1 153455 @_ == 2 or croak 'dbTitle() method expects one argument - DB name';
157 3         5 my $self = shift;
158 3         5 my $dbname = shift;
159              
160              
161 3         11 $self->_get_database_list();
162 3 100       7 if (exists ${${*$self}{'net_dict_dbs'}}{$dbname}) {
  3         3  
  3         15  
163 1         3 return ${${*$self}{'net_dict_dbs'}}{$dbname};
  1         2  
  1         5  
164             }
165             else {
166 2 100       7 carp 'dbTitle(): unknown database name' if $self->debug;
167 2         243 return undef;
168             }
169             }
170              
171             sub strategies
172             {
173 2 50   2 1 1477 @_ == 1 or croak 'usage: $dict->strategies()';
174 2         5 my $self = shift;
175              
176 2 50       8 return 0 unless $self->_SHOW_STRAT();
177              
178 2         452 my (%strats, $name, $desc);
179 2         6 foreach (@{$self->read_until_dot()}) {
  2         19  
180 24         368115 ($name, $desc) = (split /\s/, $_, 2);
181 24         69 chomp $desc;
182 24         43 $strats{$name} = _unquote($desc);
183             }
184 2         13 $self->getline();
185 2         63 %strats;
186             }
187              
188             sub define
189             {
190 14 100   14 1 13393 @_ >= 2 or croak 'usage: $dict->define($word [, @dbs]) - takes at least one argument';
191 13         35 my $self = shift;
192 13         47 my $word = shift;
193 13 100       67 my @dbs = (@_ > 0) ? @_ : @{${*$self}{'net_dict_userdbs'}};
  3         4  
  3         18  
194 13 100       378 croak 'select some dictionaries with setDicts or supply as argument to define'
195             unless @dbs;
196 12         25 my($db, @defs);
197              
198              
199             #-------------------------------------------------------------------
200             # check whether we got an empty word
201             #-------------------------------------------------------------------
202 12 100 100     89 if (!defined($word) || $word eq '') {
203 2         770 carp "empty word passed to define() method";
204 2         120 return undef;
205             }
206              
207 10         27 foreach $db (@dbs) {
208 10 100       43 next unless $self->_DEFINE($db, $word);
209              
210 8         121 my ($defNum) = ($self->message =~ /^\d{3} (\d+) /);
211              
212 8         177 foreach (0..$defNum-1) {
213 15         641 my ($d) = ($self->getline =~ /^\d{3} ".*" ([-\w]+) /);
214 15         1135986 my ($def) = join '', @{$self->read_until_dot};
  15         184  
215 15         300387 push @defs, [$d, $def];
216             }
217 8         46 $self->getline();
218             }
219 10         449 \@defs;
220             }
221              
222             sub match
223             {
224 11 100   11 1 20690 @_ >= 3 or croak 'usage: $self->match($word, $strat [, @dbs]) - takes at least two arguments';
225 9         18 my $self = shift;
226 9         22 my $word = shift;
227 9         12 my $strat = shift;
228 9 100       41 my @dbs = (@_ > 0) ? @_ : @{${*$self}{'net_dict_userdbs'}};
  3         5  
  3         16  
229 9 50       32 croak 'define some dictionaries by setDicts or supply as argument to define'
230             unless @dbs;
231 9         19 my ($db, @matches);
232              
233             #-------------------------------------------------------------------
234             # check whether we got an empty pattern
235             #-------------------------------------------------------------------
236 9 100 100     72 if (!defined($word) || $word eq '') {
237 2         10636 carp "empty pattern passed to match() method";
238 2         225 return undef;
239             }
240              
241 7         15 foreach $db (@dbs) {
242 7 50       29 next unless $self->_MATCH($db, $strat, $word);
243              
244 7         81 my ($db, $w);
245 7         16 foreach (@{$self->read_until_dot}) {
  7         39  
246 218         1283076 ($db, $w) = split /\s/, $_, 2;
247 218         351 chomp $w;
248 218         1067 push @matches, [$db, _unquote($w)];
249             }
250 7         65 $self->getline();
251             }
252 7         295 \@matches;
253             }
254              
255             sub auth
256             {
257 0 0   0 1 0 @_ == 3 or croak 'usage: $dict->auth() - takes two arguments';
258 0         0 my $self = shift;
259 0         0 my $user = shift;
260 0         0 my $pass_phrase = shift;
261 0         0 my $auth_string;
262             my $string;
263 0         0 my $ctx;
264              
265              
266 0         0 require Digest::MD5;
267 0         0 $string = $self->msg_id().$pass_phrase;
268 0         0 $auth_string = Digest::MD5::md5_hex($string);
269              
270 0 0       0 if ($self->_AUTH($user, $auth_string)) {
271             #---------------------------------------------------------------
272             # clear the cache of database names
273             # next time a method needs them, this will cause us to go
274             # back to the server, and thus pick up any AUTH-restricted DBs
275             #---------------------------------------------------------------
276 0         0 delete ${*$self}{'net_dict_dbs'};
  0         0  
277             }
278             else {
279 0 0       0 carp "auth() failed with error code ".$self->code() if $self->debug();
280 0         0 return;
281             }
282             }
283              
284             sub status
285             {
286 2 100   2 1 28475 @_ == 1 or croak 'usage: $dict->status() - takes no arguments';
287 1         1 my $self = shift;
288 1         3 my $message;
289              
290              
291 1 50       5 $self->_STATUS() || return 0;
292 1         27 chomp($message = $self->message);
293 1         32 $message =~ s/^\d{3} //;
294 1         9 return $message;
295             }
296              
297             sub capabilities
298             {
299 5 100   5 1 2370 @_ == 1 or croak 'usage: $dict->capabilities() - takes no arguments';
300 4         8 my $self = shift;
301              
302              
303 4         7 return @{ ${*$self}{'net_dict_capabilities'} };
  4         8  
  4         59  
304             }
305              
306             sub has_capability
307             {
308 5 100   5 1 3105 @_ == 2 or croak 'usage: $dict->has_capability() - takes one argument';
309 3         8 my $self = shift;
310 3         8 my $cap = shift;
311              
312              
313 3         11 return grep(lc($cap) eq $_, $self->capabilities());
314             }
315              
316             sub msg_id
317             {
318 2 100   2 0 1026 @_ == 1 or croak 'usage: $dict->msg_id() - takes no arguments';
319 1         4 my $self = shift;
320              
321              
322 1         3 return ${*$self}{'net_dict_msgid'};
  1         10  
323             }
324              
325              
326 10     10   27 sub _DEFINE { shift->command('DEFINE', map { '"'.$_.'"' } @_)->response() == CMD_INFO }
  20         108  
327 7     7   16 sub _MATCH { shift->command('MATCH', map { '"'.$_.'"' } @_)->response() == CMD_INFO }
  21         185  
328 1     1   6 sub _SHOW_DB { shift->command('SHOW DB')->response() == CMD_INFO }
329 2     2   13 sub _SHOW_STRAT { shift->command('SHOW STRAT')->response() == CMD_INFO }
330 2     2   14 sub _SHOW_INFO { shift->command('SHOW INFO', @_)->response() == CMD_INFO }
331 1     1   5 sub _SHOW_SERVER { shift->command('SHOW SERVER')->response() == CMD_INFO }
332 4     4   76 sub _CLIENT { shift->command('CLIENT', @_)->response() == CMD_OK }
333 1     1   7 sub _STATUS { shift->command('STATUS')->response() == CMD_OK }
334 0     0   0 sub _HELP { shift->command('HELP')->response() == CMD_INFO }
335 1     1   8 sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
336 0     0   0 sub _OPTION_MIME { shift->command('OPTION MIME')->response() == CMD_OK }
337 0     0   0 sub _AUTH { shift->command('AUTH', @_)->response() == CMD_OK }
338 0     0   0 sub _SASLAUTH { shift->command('SASLAUTH', @_)->response() == CMD_OK }
339 0     0   0 sub _SASLRESP { shift->command('SASLRESP', @_)->response() == CMD_OK }
340              
341             sub quit
342             {
343 1     1 0 3 my $self = shift;
344              
345 1         6 $self->_QUIT;
346 1         12 $self->close;
347             }
348              
349             sub DESTROY
350             {
351 2     2   1073 my $self = shift;
352              
353 2 100       16 if (defined fileno($self)) {
354 1         7 $self->quit;
355             }
356             }
357              
358             sub response
359             {
360 33     33 1 17712 my $self = shift;
361 33   50     180 my $str = $self->getline() || return undef;
362              
363              
364 33 50       7653620 if ($self->debug) {
365 0         0 $self->debug_print(0,$str);
366             }
367              
368 33         2227 my($code) = ($str =~ /^(\d+) /);
369              
370 33         113 ${*$self}{'net_cmd_resp'} = [ $str ];
  33         138  
371 33         85 ${*$self}{'net_cmd_code'} = $code;
  33         126  
372              
373 33         259 substr($code,0,1);
374             }
375              
376             #=======================================================================
377             #
378             # _unquote
379             #
380             # Private function used to remove quotation marks from around
381             # a string.
382             #
383             #=======================================================================
384             sub _unquote
385             {
386 314     314   698 my $string = shift;
387              
388              
389 314 50       1315 if ($string =~ /^"/) {
390 314         2111 $string =~ s/^"//;
391 314         1113 $string =~ s/"$//;
392             }
393 314         1299 return $string;
394             }
395              
396             #=======================================================================
397             #
398             # _parse_banner
399             #
400             # Parse the initial response banner the server sends when we connect.
401             # Hoping for:
402             # 220 blah blah
403             # The string gives a list of supported extensions.
404             # The last bit is a msg-id, which identifies this connection,
405             # and is used in authentication, for example.
406             #
407             #=======================================================================
408             sub _parse_banner
409             {
410 4     4   56 my $self = shift;
411 4         14 my $banner = shift;
412 4         8 my ($code, $capstring, $msgid);
413              
414              
415 4         12 ${*$self}{'net_dict_banner'} = $banner;
  4         15  
416 4         20 ${*$self}{'net_dict_capabilities'} = [];
  4         90  
417 4 50       68 if ($banner =~ /^(\d{3}) (.*) (<[^<>]*>)?\s+(<[^<>]+>)\s*$/) {
418 4         11 ${*$self}{'net_dict_msgid'} = $4;
  4         28  
419 4         40 ($capstring = $3) =~ s/[<>]//g;
420 4 50       22 if (length($capstring) > 0) {
421 4         53 ${*$self}{'net_dict_capabilities'} = [split(/\./, $capstring)];
  4         18  
422             }
423             }
424             else {
425 0 0       0 carp "unexpected format for welcome banner on connection:\n",
426             $banner if $self->debug;
427             }
428             }
429              
430             #=======================================================================
431             #
432             # _get_database_list
433             #
434             # Get the list of databases on the remote server.
435             # We cache them in the instance data object, so that dbTitle()
436             # and databases() don't have to go to the server every time.
437             #
438             # We check to see whether we've already got the databases first,
439             # and do nothing if so. This means that this private method
440             # can just be invoked in the public methods.
441             #
442             #=======================================================================
443             sub _get_database_list
444             {
445 4     4   69 my $self = shift;
446              
447              
448 4 100       6 return if exists ${*$self}{'net_dict_dbs'};
  4         23  
449              
450 1 50       5 if ($self->_SHOW_DB) {
451 1         15 my ($dbNum) = ($self->message =~ /^\d{3} (\d+)/);
452 1         15 my ($name, $descr);
453              
454 1         6 foreach (0..$dbNum-1) {
455 72         180 ($name, $descr) = (split /\s/, $self->getline, 2);
456 72         146079 chomp $descr;
457 72         165 ${${*$self}{'net_dict_dbs'}}{$name} = _unquote($descr);
  72         61  
  72         308  
458             }
459              
460             # Is there a way to do it right? Reading the dot line and the
461             # status line afterwards? Maybe I should use read_until_dot?
462 1         4 $self->getline();
463 1         11 $self->getline();
464             }
465             }
466              
467             #-----------------------------------------------------------------------
468             # Method aliases for backwards compatibility
469             #-----------------------------------------------------------------------
470             *strats = \&strategies;
471              
472             1;
473