line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#$Id: clicli.pm 919 2011-10-21 21:57:00Z pro $ $URL: svn://svn.setun.net/dcppp/trunk/lib/Net/DirectConnect/clicli.pm $ |
2
|
|
|
|
|
|
|
package #hide from cpan |
3
|
|
|
|
|
|
|
Net::DirectConnect::clicli; |
4
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
24
|
|
5
|
1
|
|
|
1
|
|
4
|
use Net::DirectConnect; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
15
|
|
6
|
1
|
|
|
1
|
|
4
|
use Data::Dumper; #dev only |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
43
|
|
7
|
|
|
|
|
|
|
$Data::Dumper::Sortkeys = 1; |
8
|
1
|
|
|
1
|
|
4
|
no warnings qw(uninitialized); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
48
|
|
9
|
|
|
|
|
|
|
our $VERSION = ( split( ' ', '$Revision: 919 $' ) )[1]; |
10
|
1
|
|
|
1
|
|
4
|
use base 'Net::DirectConnect'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1373
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub init { |
13
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
14
|
|
|
|
|
|
|
#$self->log($self, 'inited0',"MT:$self->{'message_type'}", ' with', Dumper \@_); |
15
|
0
|
|
|
|
|
|
local %_ = ( |
16
|
|
|
|
|
|
|
#http://www.dcpp.net/wiki/index.php/%24Supports |
17
|
|
|
|
|
|
|
'supports_avail' => [ qw( |
18
|
|
|
|
|
|
|
BZList |
19
|
|
|
|
|
|
|
MiniSlots |
20
|
|
|
|
|
|
|
GetZBlock |
21
|
|
|
|
|
|
|
XmlBZList |
22
|
|
|
|
|
|
|
ADCGet |
23
|
|
|
|
|
|
|
TTHL |
24
|
|
|
|
|
|
|
TTHF |
25
|
|
|
|
|
|
|
ZLIG |
26
|
|
|
|
|
|
|
ClientID |
27
|
|
|
|
|
|
|
CHUNK |
28
|
|
|
|
|
|
|
GetTestZBlock |
29
|
|
|
|
|
|
|
GetCID |
30
|
|
|
|
|
|
|
) |
31
|
|
|
|
|
|
|
], |
32
|
|
|
|
|
|
|
'XmlBZList' => 1, |
33
|
|
|
|
|
|
|
'ADCGet' => 1, |
34
|
|
|
|
|
|
|
'MiniSlots' => 1, |
35
|
|
|
|
|
|
|
'TTHF' => 1, |
36
|
|
|
|
|
|
|
#MiniSlots XmlBZList ADCGet TTHL TTHF |
37
|
|
|
|
|
|
|
#@_, |
38
|
|
|
|
|
|
|
'direction' => 'Download', |
39
|
|
|
|
|
|
|
#'Direction' => 'Upload', #rand here |
40
|
|
|
|
|
|
|
'incomingclass' => __PACKAGE__, 'reconnects' => 0, inactive_timeout => 60, |
41
|
|
|
|
|
|
|
#charset_protocol => 'cp1251', #'utf8' |
42
|
|
|
|
|
|
|
); |
43
|
|
|
|
|
|
|
#$self->{$_} ||= $_{$_} for keys %_; |
44
|
|
|
|
|
|
|
#!exists $self->{$_} ? $self->{$_} ||= $_{$_} : () for keys %_; |
45
|
0
|
|
0
|
|
|
|
$self->{$_} //= $_{$_} for keys %_; |
46
|
0
|
|
|
|
|
|
$self->{'modules'}{'nmdc'} = 1; |
47
|
0
|
0
|
0
|
|
|
|
$self->{'auto_connect'} = 1 if !$self->{'incoming'} and !defined $self->{'auto_connect'}; |
48
|
|
|
|
|
|
|
#$self->log($self, 'inited1',"MT:$self->{'message_type'}", ' with', Dumper \@_); |
49
|
|
|
|
|
|
|
#$self->log('dev', 'chPROTOcc:',$self->{'charset_protocol'}); |
50
|
|
|
|
|
|
|
#$self->baseinit(); |
51
|
|
|
|
|
|
|
#$self->log($self, 'inited2',"MT:$self->{'message_type'}", ' with', Dumper \@_); |
52
|
0
|
|
|
|
|
|
$self->get_peer_addr(); |
53
|
|
|
|
|
|
|
#$self->log('info', "[$self->{'number'}] Incoming client $self->{'peerip'}") if $self->{'peerip'}; |
54
|
|
|
|
|
|
|
#$self->{'share_tth'} ||=$self->{'parent'}{'share_tth'}; |
55
|
|
|
|
|
|
|
#$self->{'share_full'} ||=$self->{'parent'}{'share_tth'}; |
56
|
|
|
|
|
|
|
#share_full share_tth want |
57
|
0
|
|
0
|
|
|
|
$self->{$_} ||= $self->{'parent'}{$_} ||= {} for qw( NickList IpList PortList PortList_udp); #handler |
|
|
|
0
|
|
|
|
|
58
|
0
|
|
0
|
|
|
|
$self->{$_} ||= $self->{'parent'}{$_} for qw( Nick ); |
59
|
|
|
|
|
|
|
#$self->{'NickList'} ||= {}; |
60
|
|
|
|
|
|
|
#$self->{'IpList'} ||= {}; |
61
|
0
|
|
|
|
|
|
$self->module_load('filelist'); |
62
|
|
|
|
|
|
|
#$self->{'PortList'} ||= {}; |
63
|
|
|
|
|
|
|
#$self->log( 'info', "Incoming client $self->{'host'}:$self->{'port'} via ", ref $self ) if $self->{'incoming'}; |
64
|
|
|
|
|
|
|
#$self->{'parse'} = undef if $self->{'parse'} and !keys %{ $self->{'parse'} }; |
65
|
|
|
|
|
|
|
#$self->{'parse'} ||= { |
66
|
|
|
|
|
|
|
local %_ = ( |
67
|
|
|
|
|
|
|
'Lock' => sub { |
68
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
69
|
|
|
|
|
|
|
#$self->log('dev', 'LOCK:incoming', $self->{'incoming'}); |
70
|
0
|
0
|
|
|
|
|
if ( $self->{'incoming'} ) { |
71
|
0
|
|
|
|
|
|
$self->{'sendbuf'} = 1; |
72
|
0
|
|
|
|
|
|
$self->cmd('MyNick'); |
73
|
|
|
|
|
|
|
#$self->{'sendbuf'} = 0; |
74
|
0
|
|
|
|
|
|
$self->cmd('Lock'); |
75
|
|
|
|
|
|
|
#$self->{'sendbuf'} = 1; |
76
|
0
|
|
|
|
|
|
$self->cmd('Supports'); |
77
|
0
|
|
|
|
|
|
$self->cmd('Direction'); |
78
|
0
|
|
|
|
|
|
$self->{'sendbuf'} = 0; |
79
|
|
|
|
|
|
|
#} |
80
|
|
|
|
|
|
|
#my ($lock) = $_[0] =~ /^(.+?)(\s+Pk=.+)?\s*$/is; |
81
|
|
|
|
|
|
|
#$_[0] =~ /^(.+?)(\s+Pk=.+)?\s*$/is; |
82
|
|
|
|
|
|
|
#$self->cmd( 'Key', $self->lock2key($lock) ); |
83
|
|
|
|
|
|
|
} else { |
84
|
|
|
|
|
|
|
#$_[0] =~ /^(.+?)(\s+Pk=.+)?\s*$/is; |
85
|
|
|
|
|
|
|
#$self->{'key'} = $self->lock2key($1); |
86
|
|
|
|
|
|
|
#$self->log ( 'dev','lock2key', "[$1]=[$self->{'key'}]"); |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
#my ($lock) |
89
|
0
|
|
|
|
|
|
( $self->{'key'} ) = $_[0] =~ /^(.+?)(\s+Pk=.+)?\s*$/is; |
90
|
|
|
|
|
|
|
#$_[0] =~ /^(.+?)(\s+Pk=.+)?\s*$/is; |
91
|
|
|
|
|
|
|
#$self->log('dev', 'keycmd', $self->{'key'},$self->{'incoming'}); |
92
|
0
|
0
|
|
|
|
|
$self->cmd( 'Key', $self->{'key'} ) if ( $self->{'incoming'} ); |
93
|
|
|
|
|
|
|
}, |
94
|
|
|
|
|
|
|
'Direction' => sub { |
95
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
96
|
0
|
|
|
|
|
|
my $d = ( split /\s/, $_[0] )[0]; |
97
|
0
|
0
|
|
|
|
|
if ( $d eq 'Download' ) { $self->{'direction'} = 'Upload'; } |
|
0
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
else { |
99
|
0
|
|
|
|
|
|
$self->{'direction'} = 'Download'; |
100
|
|
|
|
|
|
|
#$self->log ( 'dev', "direction UNKNOWN [$d]", $self->{'direction'}, 'from', @_, ';'); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
#$self->log ( 'dev', "direction RECIEVED", $self->{'direction'}, 'from', @_, ';'); |
103
|
|
|
|
|
|
|
#2009/11/04-02:08:20 dev [2] direction RECIEVED Download from Download 28048 ; |
104
|
|
|
|
|
|
|
}, |
105
|
|
|
|
|
|
|
'Key' => sub { |
106
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
107
|
0
|
0
|
|
|
|
|
if ( $self->{'incoming'} ) { } |
108
|
|
|
|
|
|
|
else { |
109
|
|
|
|
|
|
|
#$self->log('dev', 'outk',); |
110
|
0
|
|
|
|
|
|
$self->{'sendbuf'} = 1; |
111
|
0
|
|
|
|
|
|
$self->cmd('Supports'); |
112
|
0
|
|
|
|
|
|
$self->cmd('Direction'); |
113
|
0
|
|
|
|
|
|
$self->{'sendbuf'} = 0; |
114
|
0
|
|
|
|
|
|
$self->cmd( 'Key', $self->{'key'} ); |
115
|
|
|
|
|
|
|
} |
116
|
0
|
0
|
|
|
|
|
$self->file_select(), $self->log( "get:[filename:", $self->{'filename'}, '; fileas:', $self->{'fileas'}, "]" ) |
117
|
|
|
|
|
|
|
if $self->{'direction'} eq 'Download'; |
118
|
0
|
0
|
0
|
|
|
|
$self->{'get'} = $self->{'filename'} . '$' . ( $self->{'file_recv_from'} || 1 ), |
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
119
|
|
|
|
|
|
|
$self->{'adcget'} = |
120
|
|
|
|
|
|
|
'file ' . $self->{'filename'} . ' ' . ( $self->{'file_recv_from'} || 0 ) . ' ' . ( $self->{'file_recv_to'} || '-1' ), |
121
|
|
|
|
|
|
|
$self->cmd( ( $self->{'NickList'}->{ $self->{'peernick'} }{'ADCGet'} ? 'ADCGET' : 'Get' ) ) |
122
|
|
|
|
|
|
|
if $self->{'filename'}; |
123
|
|
|
|
|
|
|
}, |
124
|
|
|
|
|
|
|
'Get' => sub { |
125
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
126
|
|
|
|
|
|
|
#TODO |
127
|
0
|
|
|
|
|
|
$self->cmd( 'FileLength', 0 ); |
128
|
|
|
|
|
|
|
}, |
129
|
|
|
|
|
|
|
'MyNick' => sub { |
130
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
131
|
0
|
|
|
|
|
|
$self->log( 'info', "peer is [", ( $self->{'peernick'} = $_[0] ), "]" ); |
132
|
0
|
|
|
|
|
|
$self->{'NickList'}->{ $self->{'peernick'} }{'ip'} = $self->{'host'}; |
133
|
0
|
|
|
|
|
|
$self->{'NickList'}->{ $self->{'peernick'} }{'port'} = $self->{'port'}; |
134
|
0
|
|
|
|
|
|
$self->{'IpList'}->{ $self->{'host'} } = \%{ $self->{'NickList'}->{ $self->{'peernick'} } }; |
|
0
|
|
|
|
|
|
|
135
|
0
|
|
|
|
|
|
$self->{'IpList'}->{ $self->{'host'} }->{'port'} = $self->{'PortList'}->{ $self->{'host'} }; |
136
|
0
|
|
|
|
|
|
$self->handler( 'user_ip', $self->{'peernick'}, $self->{'host'}, $self->{'port'} ); |
137
|
0
|
0
|
|
|
|
|
if ( keys %{ $self->{'want'}->{ $self->{'peernick'} } } ) { $self->{'direction'} = 'Download'; } |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
138
|
0
|
|
|
|
|
|
else { $self->{'direction'} = 'Upload'; } |
139
|
|
|
|
|
|
|
#$self->log ( 'dev', "direction", $self->{'direction'}, 'from', keys %{ $self->{'want'}->{ $self->{'peernick'} } }, ';'); |
140
|
|
|
|
|
|
|
}, |
141
|
|
|
|
|
|
|
'FileLength' => sub { |
142
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
143
|
0
|
|
|
|
|
|
$self->{'filetotal'} = $_[0]; |
144
|
0
|
0
|
|
|
|
|
return if $self->file_open(); |
145
|
0
|
|
|
|
|
|
$self->cmd('Send'); |
146
|
|
|
|
|
|
|
}, |
147
|
|
|
|
|
|
|
'ADCSND' => sub { |
148
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
149
|
|
|
|
|
|
|
#$self->log( 'dev', "ADCSND::", @_ ); |
150
|
|
|
|
|
|
|
#$_[0] =~ /(\d+?)$/is; |
151
|
0
|
|
|
|
|
|
local @_ = split /\s+/, $_[0]; |
152
|
0
|
|
|
|
|
|
$self->{'filetotal'} = $_[2] + $_[3]; |
153
|
0
|
|
|
|
|
|
return $self->file_open(); |
154
|
|
|
|
|
|
|
}, |
155
|
|
|
|
|
|
|
'CSND' => sub { |
156
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
157
|
0
|
|
|
|
|
|
$_[0] =~ /^file\s+\S+\s+(\d+)\s(\d+)$/is; |
158
|
0
|
|
|
|
|
|
$self->{'filetotal'} = $1 + $2; |
159
|
0
|
|
|
|
|
|
return $self->file_open(); |
160
|
|
|
|
|
|
|
}, |
161
|
|
|
|
|
|
|
'Supports' => sub { |
162
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
163
|
0
|
|
|
|
|
|
$self->supports_parse( $_[0], $self->{'NickList'}->{ $self->{'peernick'} } ); |
164
|
|
|
|
|
|
|
}, |
165
|
|
|
|
|
|
|
'MaxedOut' => sub { |
166
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
167
|
0
|
|
|
|
|
|
$self->disconnect(); |
168
|
|
|
|
|
|
|
}, |
169
|
|
|
|
|
|
|
'ADCGET' => sub { |
170
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
171
|
|
|
|
|
|
|
#$self->log('dev', 'ADCGET', @_); |
172
|
0
|
0
|
|
|
|
|
$self->cmd( 'Error', "File Not Available" ) if $self->file_send_parse( map { split /\s/, $_ } @_ ); |
|
0
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
}, |
174
|
|
|
|
|
|
|
#}; |
175
|
0
|
|
|
|
|
|
); |
176
|
0
|
|
0
|
|
|
|
$self->{'parse'}{$_} ||= $_{$_} for keys %_; |
177
|
|
|
|
|
|
|
#$self->log ( 'dev', "del empty cmd", ), |
178
|
|
|
|
|
|
|
#$self->{'cmd'} = undef if $self->{'cmd'} and !keys %{ $self->{'cmd'} }; |
179
|
|
|
|
|
|
|
#$self->log('PRECMD',Dumper $self->{'cmd'}); |
180
|
|
|
|
|
|
|
#$self->{'cmd'} ||= { |
181
|
|
|
|
|
|
|
local %_ = ( |
182
|
|
|
|
|
|
|
'connect_aft' => sub { |
183
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
184
|
|
|
|
|
|
|
#my $self = shift if ref $_[0]; |
185
|
0
|
|
|
|
|
|
$self->{'sendbuf'} = 1; |
186
|
0
|
|
|
|
|
|
$self->cmd('MyNick'); |
187
|
0
|
|
|
|
|
|
$self->{'sendbuf'} = 0; |
188
|
0
|
|
|
|
|
|
$self->cmd('Lock'); |
189
|
|
|
|
|
|
|
}, |
190
|
|
|
|
|
|
|
'MyNick' => sub { |
191
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
192
|
0
|
|
|
|
|
|
$self->sendcmd( |
193
|
|
|
|
|
|
|
'MyNick', $self->{'Nick'} #|| $self->{'parent'}{'Nick'} |
194
|
|
|
|
|
|
|
); |
195
|
|
|
|
|
|
|
}, |
196
|
|
|
|
|
|
|
'Lock' => sub { |
197
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
198
|
|
|
|
|
|
|
#$self->log('dev', 'cmdLOCK', $_[0],$self->{'lock'}); |
199
|
0
|
|
0
|
|
|
|
$self->sendcmd( 'Lock', $_[0] || $self->{'lock'} ); |
200
|
|
|
|
|
|
|
}, |
201
|
|
|
|
|
|
|
'Supports' => sub { |
202
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
203
|
0
|
|
0
|
|
|
|
$self->sendcmd( 'Supports', $self->supports() || 'MiniSlots XmlBZList ADCGet TTHF' ); #TTHL |
204
|
|
|
|
|
|
|
}, |
205
|
|
|
|
|
|
|
'Direction' => sub { |
206
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
207
|
0
|
|
|
|
|
|
$self->sendcmd( 'Direction', $self->{'direction'}, int( rand(0x7FFF) ) ); |
208
|
|
|
|
|
|
|
}, |
209
|
|
|
|
|
|
|
'Key' => sub { |
210
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
211
|
|
|
|
|
|
|
#$self->log('dev', 'cmdKEY', $_[0],$self->{'incoming'}); |
212
|
0
|
|
|
|
|
|
$self->sendcmd( 'Key', $_[0] ); |
213
|
|
|
|
|
|
|
}, |
214
|
|
|
|
|
|
|
'Get' => sub { |
215
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
216
|
0
|
|
|
|
|
|
$self->sendcmd( 'Get', $self->{'get'} ); |
217
|
|
|
|
|
|
|
}, |
218
|
|
|
|
|
|
|
'Send' => sub { |
219
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
220
|
0
|
|
|
|
|
|
$self->sendcmd('Send'); |
221
|
|
|
|
|
|
|
}, |
222
|
|
|
|
|
|
|
'FileLength' => sub { |
223
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
224
|
0
|
|
|
|
|
|
$self->sendcmd( 'FileLength', $_[0] ); |
225
|
|
|
|
|
|
|
}, |
226
|
|
|
|
|
|
|
'ADCGET' => sub { |
227
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
228
|
|
|
|
|
|
|
#$ADCGET file TTH/I2VAVWYGSVTBHSKN3BOA6EWTXSP4GAKJMRK2DJQ 730020132 2586332 |
229
|
0
|
|
|
|
|
|
$self->sendcmd( 'ADCGET', $self->{'adcget'} ); |
230
|
|
|
|
|
|
|
}, |
231
|
|
|
|
|
|
|
'ADCSND' => sub { |
232
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
233
|
0
|
|
|
|
|
|
$self->sendcmd( 'ADCSND', @_ ); |
234
|
|
|
|
|
|
|
}, |
235
|
|
|
|
|
|
|
'Error' => sub { |
236
|
0
|
0
|
|
0
|
|
|
my $self = shift if ref $_[0]; |
237
|
0
|
|
|
|
|
|
$self->sendcmd( 'Error', $_[0] ); |
238
|
|
|
|
|
|
|
}, |
239
|
0
|
|
|
|
|
|
); |
240
|
0
|
|
0
|
|
|
|
$self->{'cmd'}{$_} ||= $_{$_} for keys %_; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
1; |