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
|
|
|
|
|
|
|
|