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   101935 use warnings;
  4         9  
  4         144  
15 4     4   18 use strict;
  4         6  
  4         123  
16 4     4   2403 use IO::Socket;
  4         89890  
  4         16  
17 4     4   4359 use Net::Cmd;
  4         16229  
  4         282  
18 4     4   24 use Carp;
  4         7  
  4         186  
19              
20 4     4   15 use vars qw(@ISA $debug);
  4         4  
  4         8641  
21             our $VERSION = '2.19';
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 5313 @_ > 1 or croak 'usage: Net::Dict->new() takes at least a HOST name';
49 8         13 my $class = shift;
50 8         13 my $host = shift;
51 8 100       161 int(@_) % 2 == 0 or croak 'Net::Dict->new(): odd number of arguments';
52 7         18 my %inargs = @_;
53              
54 7         10 my $self;
55             my $argref;
56              
57              
58 7 100       24 return undef unless defined $host;
59              
60             #-------------------------------------------------------------------
61             # Process arguments, setting defaults if needed
62             #-------------------------------------------------------------------
63 6         11 $argref = {};
64 6         29 foreach my $arg (keys %ARG_DEFAULT) {
65 24 100       58 $argref->{$arg} = exists $inargs{$arg}
66             ? $inargs{$arg}
67             : $ARG_DEFAULT{$arg};
68 24         35 delete $inargs{$arg};
69             }
70              
71 6 100       22 if (keys(%inargs) > 0) {
72 1         160 croak "Net::Dict->new(): unknown argument - ",
73             join(', ', keys %inargs);
74             }
75              
76             #-------------------------------------------------------------------
77             # Make the connection
78             #-------------------------------------------------------------------
79 5         73 $self = $class->SUPER::new(PeerAddr => $host,
80             PeerPort => $argref->{Port},
81             Proto => 'tcp',
82             Timeout => $argref->{Timeout}
83             );
84              
85 5 100       607843 return undef unless defined $self;
86              
87 4         9 ${*$self}{'net_dict_host'} = $host;
  4         25  
88              
89 4         27 $self->autoflush(1);
90 4         247 $self->debug($argref->{Debug});
91              
92 4 50       96 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         63 $self->_parse_banner($self->message);
99              
100             #-------------------------------------------------------------------
101             # Send the CLIENT command which identifies the connecting client
102             #-------------------------------------------------------------------
103 4         22 $self->_CLIENT($argref->{Client});
104              
105             #-------------------------------------------------------------------
106             # The default - search ALL dictionaries
107             #-------------------------------------------------------------------
108 4         42 $self->setDicts('*');
109              
110 4         37 return $self;
111             }
112              
113             sub dbs
114             {
115 2 100   2 1 1293 @_ == 1 or croak 'usage: $dict->dbs() - takes no arguments';
116 1         1 my $self = shift;
117              
118 1         4 $self->_get_database_list();
119 1         7 return %{${*$self}{'net_dict_dbs'}};
  1         2  
  1         70  
120             }
121              
122             sub setDicts
123             {
124 8     8 1 3856 my $self = shift;
125              
126 8         20 @{${*$self}{'net_dict_userdbs'}} = @_;
  8         16  
  8         44  
127             }
128              
129             sub serverInfo
130             {
131 1 50   1 1 792 @_ == 1 or croak 'usage: $dict->serverInfo()';
132 1         3 my $self = shift;
133              
134 1 50       4 return 0 unless $self->_SHOW_SERVER();
135              
136 1         8 my $info = join('', @{$self->read_until_dot});
  1         11  
137 1         146577 $self->getline();
138 1         11 $info;
139             }
140              
141             sub dbInfo
142             {
143 4 100   4 1 3612 @_ == 2 or croak 'usage: $dict->dbInfo($dbname) - one argument only';
144 2         4 my $self = shift;
145              
146 2 100       9 if ($self->_SHOW_INFO(@_)) {
147 1         9 return join('', @{$self->read_until_dot()});
  1         12  
148             }
149             else {
150 1         17 return undef;
151             }
152             }
153              
154             sub dbTitle
155             {
156 5 100   5 1 149848 @_ == 2 or croak 'dbTitle() method expects one argument - DB name';
157 3         4 my $self = shift;
158 3         4 my $dbname = shift;
159              
160              
161 3         7 $self->_get_database_list();
162 3 100       3 if (exists ${${*$self}{'net_dict_dbs'}}{$dbname}) {
  3         3  
  3         9  
163 1         3 return ${${*$self}{'net_dict_dbs'}}{$dbname};
  1         1  
  1         4  
164             }
165             else {
166 2 100       7 carp 'dbTitle(): unknown database name' if $self->debug;
167 2         179 return undef;
168             }
169             }
170              
171             sub strategies
172             {
173 2 50   2 1 1373 @_ == 1 or croak 'usage: $dict->strategies()';
174 2         4 my $self = shift;
175              
176 2 50       7 return 0 unless $self->_SHOW_STRAT();
177              
178 2         20 my (%strats, $name, $desc);
179 2         5 foreach (@{$self->read_until_dot()}) {
  2         19  
180 24         370807 ($name, $desc) = (split /\s/, $_, 2);
181 24         33 chomp $desc;
182 24         31 $strats{$name} = _unquote($desc);
183             }
184 2         14 $self->getline();
185 2         50 %strats;
186             }
187              
188             sub define
189             {
190 14 100   14 1 11296 @_ >= 2 or croak 'usage: $dict->define($word [, @dbs]) - takes at least one argument';
191 13         123 my $self = shift;
192 13         26 my $word = shift;
193 13 100       55 my @dbs = (@_ > 0) ? @_ : @{${*$self}{'net_dict_userdbs'}};
  3         6  
  3         12  
194 13 100       358 croak 'select some dictionaries with setDicts or supply as argument to define'
195             unless @dbs;
196 12         20 my($db, @defs);
197              
198              
199             #-------------------------------------------------------------------
200             # check whether we got an empty word
201             #-------------------------------------------------------------------
202 12 100 100     82 if (!defined($word) || $word eq '') {
203 2         471 carp "empty word passed to define() method";
204 2         126 return undef;
205             }
206              
207 10         24 foreach $db (@dbs) {
208 10 100       39 next unless $self->_DEFINE($db, $word);
209              
210 8         105 my ($defNum) = ($self->message =~ /^\d{3} (\d+) /);
211              
212 8         146 foreach (0..$defNum-1) {
213 15         122 my ($d) = ($self->getline =~ /^\d{3} ".*" ([-\w]+) /);
214 15         1112118 my ($def) = join '', @{$self->read_until_dot};
  15         96  
215 15         294592 push @defs, [$d, $def];
216             }
217 8         29 $self->getline();
218             }
219 10         160 \@defs;
220             }
221              
222             sub match
223             {
224 11 100   11 1 7951 @_ >= 3 or croak 'usage: $self->match($word, $strat [, @dbs]) - takes at least two arguments';
225 9         20 my $self = shift;
226 9         19 my $word = shift;
227 9         14 my $strat = shift;
228 9 100       41 my @dbs = (@_ > 0) ? @_ : @{${*$self}{'net_dict_userdbs'}};
  3         4  
  3         14  
229 9 50       31 croak 'define some dictionaries by setDicts or supply as argument to define'
230             unless @dbs;
231 9         18 my ($db, @matches);
232              
233             #-------------------------------------------------------------------
234             # check whether we got an empty pattern
235             #-------------------------------------------------------------------
236 9 100 100     74 if (!defined($word) || $word eq '') {
237 2         317 carp "empty pattern passed to match() method";
238 2         92 return undef;
239             }
240              
241 7         16 foreach $db (@dbs) {
242 7 50       29 next unless $self->_MATCH($db, $strat, $word);
243              
244 7         254 my ($db, $w);
245 7         16 foreach (@{$self->read_until_dot}) {
  7         38  
246 218         1265993 ($db, $w) = split /\s/, $_, 2;
247 218         345 chomp $w;
248 218         309 push @matches, [$db, _unquote($w)];
249             }
250 7         50 $self->getline();
251             }
252 7         249 \@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 1921 @_ == 1 or croak 'usage: $dict->status() - takes no arguments';
287 1         1 my $self = shift;
288 1         2 my $message;
289              
290              
291 1 50       4 $self->_STATUS() || return 0;
292 1         10 chomp($message = $self->message);
293 1         15 $message =~ s/^\d{3} //;
294 1         5 return $message;
295             }
296              
297             sub capabilities
298             {
299 5 100   5 1 1200 @_ == 1 or croak 'usage: $dict->capabilities() - takes no arguments';
300 4         5 my $self = shift;
301              
302              
303 4         4 return @{ ${*$self}{'net_dict_capabilities'} };
  4         3  
  4         21  
304             }
305              
306             sub has_capability
307             {
308 5 100   5 1 1742 @_ == 2 or croak 'usage: $dict->has_capability() - takes one argument';
309 3         4 my $self = shift;
310 3         4 my $cap = shift;
311              
312              
313 3         5 return grep(lc($cap) eq $_, $self->capabilities());
314             }
315              
316             sub msg_id
317             {
318 2 100   2 0 472 @_ == 1 or croak 'usage: $dict->msg_id() - takes no arguments';
319 1         2 my $self = shift;
320              
321              
322 1         1 return ${*$self}{'net_dict_msgid'};
  1         5  
323             }
324              
325              
326 10     10   25 sub _DEFINE { shift->command('DEFINE', map { '"'.$_.'"' } @_)->response() == CMD_INFO }
  20         88  
327 7     7   70 sub _MATCH { shift->command('MATCH', map { '"'.$_.'"' } @_)->response() == CMD_INFO }
  21         70  
328 1     1   8 sub _SHOW_DB { shift->command('SHOW DB')->response() == CMD_INFO }
329 2     2   10 sub _SHOW_STRAT { shift->command('SHOW STRAT')->response() == CMD_INFO }
330 2     2   11 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   47 sub _CLIENT { shift->command('CLIENT', @_)->response() == CMD_OK }
333 1     1   5 sub _STATUS { shift->command('STATUS')->response() == CMD_OK }
334 0     0   0 sub _HELP { shift->command('HELP')->response() == CMD_INFO }
335 1     1   5 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 2 my $self = shift;
344              
345 1         3 $self->_QUIT;
346 1         10 $self->close;
347             }
348              
349             sub DESTROY
350             {
351 2     2   757 my $self = shift;
352              
353 2 100       12 if (defined fileno($self)) {
354 1         4 $self->quit;
355             }
356             }
357              
358             sub response
359             {
360 33     33 1 4729 my $self = shift;
361 33   50     141 my $str = $self->getline() || return undef;
362              
363              
364 33 50       4881675 if ($self->debug) {
365 0         0 $self->debug_print(0,$str);
366             }
367              
368 33         902 my($code) = ($str =~ /^(\d+) /);
369              
370 33         105 ${*$self}{'net_cmd_resp'} = [ $str ];
  33         113  
371 33         64 ${*$self}{'net_cmd_code'} = $code;
  33         80  
372              
373 33         219 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   316 my $string = shift;
387              
388              
389 314 50       800 if ($string =~ /^"/) {
390 314         690 $string =~ s/^"//;
391 314         714 $string =~ s/"$//;
392             }
393 314         802 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   46 my $self = shift;
411 4         7 my $banner = shift;
412 4         9 my ($code, $capstring, $msgid);
413              
414              
415 4         6 ${*$self}{'net_dict_banner'} = $banner;
  4         11  
416 4         7 ${*$self}{'net_dict_capabilities'} = [];
  4         68  
417 4 50       44 if ($banner =~ /^(\d{3}) (.*) (<[^<>]*>)?\s+(<[^<>]+>)\s*$/) {
418 4         5 ${*$self}{'net_dict_msgid'} = $4;
  4         19  
419 4         25 ($capstring = $3) =~ s/[<>]//g;
420 4 50       16 if (length($capstring) > 0) {
421 4         26 ${*$self}{'net_dict_capabilities'} = [split(/\./, $capstring)];
  4         12  
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   6 my $self = shift;
446              
447              
448 4 100       3 return if exists ${*$self}{'net_dict_dbs'};
  4         16  
449              
450 1 50       11 if ($self->_SHOW_DB) {
451 1         21 my ($dbNum) = ($self->message =~ /^\d{3} (\d+)/);
452 1         20 my ($name, $descr);
453              
454 1         6 foreach (0..$dbNum-1) {
455 72         141 ($name, $descr) = (split /\s/, $self->getline, 2);
456 72         146289 chomp $descr;
457 72         95 ${${*$self}{'net_dict_dbs'}}{$name} = _unquote($descr);
  72         55  
  72         220  
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         3 $self->getline();
463 1         9 $self->getline();
464             }
465             }
466              
467             #-----------------------------------------------------------------------
468             # Method aliases for backwards compatibility
469             #-----------------------------------------------------------------------
470             *strats = \&strategies;
471              
472             1;
473