line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::Lite::FTP; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
|
4
|
1
|
|
|
1
|
|
21072
|
use 5.006000; |
|
1
|
|
|
|
|
4
|
|
5
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
23
|
|
6
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
38
|
|
7
|
1
|
|
|
1
|
|
894
|
use IO::Handle; |
|
1
|
|
|
|
|
7092
|
|
|
1
|
|
|
|
|
50
|
|
8
|
|
|
|
|
|
|
#use IO::Compress::Deflate qw(deflate $DeflateError); |
9
|
|
|
|
|
|
|
#use IO::Uncompress::Inflate qw(inflate $InflateError); |
10
|
1
|
|
|
1
|
|
22423
|
use Compress::Raw::Zlib; |
|
1
|
|
|
|
|
10170
|
|
|
1
|
|
|
|
|
360
|
|
11
|
1
|
|
|
1
|
|
985
|
use Errno; |
|
1
|
|
|
|
|
1535
|
|
|
1
|
|
|
|
|
125
|
|
12
|
1
|
|
|
|
|
304
|
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET IPPROTO_IP SO_ERROR IPPROTO_IP IP_TOS IP_TTL |
13
|
1
|
|
|
1
|
|
1044
|
inet_aton sockaddr_in SO_SNDTIMEO SO_RCVTIMEO SO_KEEPALIVE); |
|
1
|
|
|
|
|
6100
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
require Exporter; |
17
|
1
|
|
|
1
|
|
5068
|
use AutoLoader qw(AUTOLOAD); |
|
1
|
|
|
|
|
1625
|
|
|
1
|
|
|
|
|
6
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
20
|
|
|
|
|
|
|
# Items to export into callers namespace by default. Note: do not export |
21
|
|
|
|
|
|
|
# names by default without a very good reason. Use EXPORT_OK instead. |
22
|
|
|
|
|
|
|
# Do not simply export all your public functions/methods/constants. |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# This allows declaration use Net::Lite::FTP ':all'; |
25
|
|
|
|
|
|
|
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK |
26
|
|
|
|
|
|
|
# will save memory. |
27
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw( |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
) ] ); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
our @EXPORT = qw( |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
our $VERSION = '0.84'; |
38
|
|
|
|
|
|
|
# Preloaded methods go here. |
39
|
|
|
|
|
|
|
# Autoload methods go after =cut, and are processed by the autosplit program. |
40
|
1
|
|
|
1
|
|
129
|
use constant BUFSIZE => 4096; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
77
|
|
41
|
|
|
|
|
|
|
BEGIN { |
42
|
1
|
|
|
1
|
|
896
|
use Net::SSLeay::Handle qw/shutdown/; |
|
1
|
|
|
|
|
10813
|
|
|
1
|
|
|
|
|
5415
|
|
43
|
|
|
|
|
|
|
# You only need this if your FTP server requires client certs: |
44
|
|
|
|
|
|
|
#Net::SSLeay::Handle::_set_cert("/home/eyck/my.pem"); |
45
|
|
|
|
|
|
|
#Net::SSLeay::Handle::_set_key("/home/eyck/my.pem"); |
46
|
|
|
|
|
|
|
# but if you want this, you need to patch your Net::SSLeay, |
47
|
|
|
|
|
|
|
}; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub new($$) { |
50
|
1
|
|
|
1
|
0
|
11
|
my $class=shift; |
51
|
1
|
|
|
|
|
2
|
my $self={}; |
52
|
1
|
|
|
|
|
3
|
bless $self,$class; |
53
|
|
|
|
|
|
|
# $self->{'DBHandle'}=$dbh; |
54
|
1
|
|
|
|
|
11
|
$self->{"CreationTime"}=time; |
55
|
1
|
|
|
|
|
3
|
$self->{"Connected"}=0; |
56
|
1
|
|
|
|
|
3
|
$self->{"EncryptData"}=1; |
57
|
1
|
|
|
|
|
1
|
$self->{"Encrypt"}=1; |
58
|
1
|
|
|
|
|
3
|
$self->{"Debug"}=0; |
59
|
1
|
|
|
|
|
2
|
$self->{"ErrMSG"}=undef; |
60
|
|
|
|
|
|
|
#$self->{"ForcePASSVIP"}=undef; |
61
|
1
|
|
|
|
|
1
|
$self->{"GetUpdateCallback"} = undef; |
62
|
1
|
|
|
|
|
4
|
$self->{"GetDoneCallback"} = undef; |
63
|
1
|
|
|
|
|
2
|
$self->{"PutUpdateCallback"} = undef; |
64
|
1
|
|
|
|
|
3
|
$self->{"PutDoneCallback"} = undef; |
65
|
1
|
|
|
|
|
1
|
$self->{"CompressionLevel"}=1; |
66
|
1
|
|
|
|
|
2
|
$self->{"CompressionWindowBits"}=8; |
67
|
1
|
|
|
|
|
3
|
$self->{"CompressionBufsize"}=8192; |
68
|
1
|
|
|
|
|
3
|
$self->{"CompressionStrategy"}=4; |
69
|
|
|
|
|
|
|
#define Z_FILTERED 1 |
70
|
|
|
|
|
|
|
#define Z_HUFFMAN_ONLY 2 |
71
|
|
|
|
|
|
|
#define Z_RLE 3 |
72
|
|
|
|
|
|
|
#define Z_FIXED 4 |
73
|
|
|
|
|
|
|
#define Z_DEFAULT_STRATEGY 0 |
74
|
1
|
|
|
|
|
3
|
return $self; |
75
|
|
|
|
|
|
|
}; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub user($$) { |
78
|
0
|
|
|
0
|
0
|
0
|
my ($self,$user)=@_; |
79
|
0
|
|
|
|
|
0
|
$self->command("USER $user"); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
sub pass($$) { |
82
|
0
|
|
|
0
|
0
|
0
|
my ($self,$pass)=@_; |
83
|
0
|
|
|
|
|
0
|
$self->command("PASS $pass"); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
sub login($$$) { |
86
|
0
|
|
|
0
|
0
|
0
|
my ($self,$user,$pass)=@_; |
87
|
0
|
|
|
|
|
0
|
$self->command("USER $user"); |
88
|
0
|
|
|
|
|
0
|
$self->command("PASS $pass"); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub cwd ($$) { |
92
|
0
|
|
|
0
|
0
|
0
|
my ($self,$data)=@_; |
93
|
0
|
|
|
|
|
0
|
$self->command("CWD $data"); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
sub mkdir ($$) { |
96
|
0
|
|
|
0
|
0
|
0
|
my ($self,$data)=@_; |
97
|
0
|
|
|
|
|
0
|
$self->command("MKD $data"); |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
sub rmdir ($$) { |
100
|
0
|
|
|
0
|
0
|
0
|
my ($self,$data)=@_; |
101
|
0
|
|
|
|
|
0
|
$self->command("RMD $data"); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub bin ($) { |
105
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
106
|
0
|
|
|
|
|
0
|
$self->command("TYPE I"); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
sub ascii ($) { |
109
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
110
|
0
|
|
|
|
|
0
|
$self->command("TYPE A"); |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub size ($$) { |
114
|
0
|
|
|
0
|
0
|
0
|
my ($self,$filename)=@_; |
115
|
0
|
0
|
|
|
|
0
|
my $size=$self->command("SIZE $filename");chop $size if defined($size); |
|
0
|
|
|
|
|
0
|
|
116
|
0
|
|
|
|
|
0
|
return $size; |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
sub cdup ($$) { |
119
|
0
|
|
|
0
|
0
|
0
|
my ($self,$data)=@_; |
120
|
0
|
|
|
|
|
0
|
$self->command("CDUP"); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
sub dele { |
123
|
0
|
|
|
0
|
0
|
0
|
my ($self,$pathname)=@_; |
124
|
0
|
0
|
|
|
|
0
|
return undef unless defined($pathname); |
125
|
0
|
|
|
|
|
0
|
$self->command("DELE $pathname"); |
126
|
|
|
|
|
|
|
} |
127
|
0
|
|
|
0
|
0
|
0
|
sub rm {dele(@_);}; |
128
|
0
|
|
|
0
|
0
|
0
|
sub delete {dele(@_);}; |
129
|
0
|
|
|
0
|
0
|
0
|
sub del { shift->del(@_) }; |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub rawmessage ($) { |
132
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
133
|
0
|
|
|
|
|
0
|
return $self->{'FTPRAWMSG'}; |
134
|
|
|
|
|
|
|
}; |
135
|
|
|
|
|
|
|
sub message ($) { |
136
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
137
|
0
|
|
|
|
|
0
|
return $self->{'FTPMSG'}; |
138
|
|
|
|
|
|
|
}; |
139
|
|
|
|
|
|
|
sub msgcode ($) { |
140
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
141
|
0
|
|
|
|
|
0
|
return $self->{'FTPCODE'}; |
142
|
|
|
|
|
|
|
}; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
sub readln { |
145
|
0
|
|
|
0
|
0
|
0
|
my ($sock)=@_; |
146
|
0
|
|
|
|
|
0
|
my ($data,$ln); |
147
|
0
|
0
|
|
|
|
0
|
if (sysread($sock,$data,BUFSIZE)) { |
148
|
0
|
|
|
|
|
0
|
$ln=$data; |
149
|
0
|
|
|
|
|
0
|
while ($data!~/\n/) { |
150
|
0
|
0
|
|
|
|
0
|
if (sysread($sock,$data,BUFSIZE)) { |
151
|
|
|
|
|
|
|
#print "OPEN..Received: {$data}\n";# if $self->{Debug}; |
152
|
0
|
|
|
|
|
0
|
$ln.=$data; |
153
|
|
|
|
|
|
|
}; |
154
|
|
|
|
|
|
|
}; |
155
|
|
|
|
|
|
|
}; |
156
|
0
|
|
|
|
|
0
|
return $ln; |
157
|
|
|
|
|
|
|
}; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
#sub SOL_IP { 0; }; |
160
|
|
|
|
|
|
|
#sub IP_TOS { 1; }; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub open($$$) { |
163
|
0
|
|
|
0
|
0
|
0
|
my ($self,$host,$port)=@_; |
164
|
0
|
|
|
|
|
0
|
my ($data); |
165
|
|
|
|
|
|
|
my $sock; |
166
|
0
|
|
|
|
|
0
|
$sock = Net::SSLeay::Handle->make_socket($host, $port); |
167
|
0
|
|
|
|
|
0
|
$self->{'Sock'}=$sock; |
168
|
0
|
|
|
|
|
0
|
$self->{'Host'}=$host; |
169
|
0
|
|
|
|
|
0
|
$self->{'Port'}=$port; |
170
|
|
|
|
|
|
|
#tmp |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
#setsockopt($sock,&SOL_SOCKET,&SO_KEEPALIVE,undef,undef) || warn "setsockopt: $!"; |
173
|
0
|
0
|
|
|
|
0
|
setsockopt($sock, SOL_SOCKET, SO_SNDTIMEO, pack('L!L!', 15, 0) ) or warn "setsockopt SNDTIMEO unset: ".$!; |
174
|
0
|
0
|
|
|
|
0
|
setsockopt($sock, SOL_SOCKET, SO_RCVTIMEO, pack('L!L!', 15, 0) ) or warn "setsockopt RCVTIMEO unset: ".$!; |
175
|
0
|
0
|
|
|
|
0
|
setsockopt($sock, SOL_SOCKET, SO_KEEPALIVE, 1 ) or warn "setsockopt KEEPALIVE unset: ".$!; |
176
|
|
|
|
|
|
|
#setsockopt($sock, SOL_SOCKET, IP_TOS, IPTOS_LOWDELAY ) or die "setsockopt".$!; |
177
|
|
|
|
|
|
|
#/usr/share/perl/5.8.4/Net/Ping.pm: setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) |
178
|
|
|
|
|
|
|
#setsockopt($sock, SOL_IP, IP_TOS(), pack("I*",0x10 )); |
179
|
|
|
|
|
|
|
#LOWLATENCY |
180
|
0
|
0
|
|
|
|
0
|
setsockopt($sock, IPPROTO_IP, IP_TOS, pack("I*", 0x10)) |
181
|
|
|
|
|
|
|
or warn "error configuring tos LOW LATENCY to $self->{'fh'} $!"; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
#/usr/include/linux/ip.h:#define IPTOS_LOWDELAY 0x10 |
185
|
|
|
|
|
|
|
##define IPTOS_THROUGHPUT 0x08 |
186
|
|
|
|
|
|
|
#define IPTOS_MINCOST 0x02 |
187
|
|
|
|
|
|
|
#/usr/share/perl/5.8.4/Net/Ping.pm: setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'})) |
188
|
|
|
|
|
|
|
#end tmp 2008-11-04 |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
#FTPS EXPLICIT: |
191
|
0
|
0
|
|
|
|
0
|
if ($self->{'FTPS'}) { |
192
|
|
|
|
|
|
|
#{tie(*S, "Net::SSLeay::Handle", $sock);$sock = \*S;}; |
193
|
|
|
|
|
|
|
# Unique glob? |
194
|
0
|
|
|
|
|
0
|
{my $io=new IO::Handle; tie(*$io, "Net::SSLeay::Handle", $sock);$sock = \*$io;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
|
199
|
0
|
0
|
|
|
|
0
|
if ($data=readln($sock)) { |
200
|
0
|
0
|
|
|
|
0
|
print STDERR "OPEN.Received: $data" if $self->{Debug}; |
201
|
0
|
|
|
|
|
0
|
$data=$self->responserest($data); |
202
|
0
|
0
|
|
|
|
0
|
print STDERR "OPEN..Received: $data" if $self->{Debug}; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
0
|
0
|
0
|
|
|
0
|
if ($self->{'Encrypt'} && (! $self->{'FTPS'} )) { |
206
|
0
|
|
|
|
|
0
|
$data="AUTH TLS\r\n"; |
207
|
0
|
|
|
|
|
0
|
syswrite($sock,$data); |
208
|
0
|
0
|
|
|
|
0
|
if ($data=readln($sock)) { |
209
|
0
|
0
|
|
|
|
0
|
print STDERR "Received: $data" if $self->{Debug}; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
0
|
0
|
|
|
|
0
|
if ($self->{'Integrity'}) { |
214
|
0
|
|
|
|
|
0
|
$self->command("INTEGRITY H");# TODO |
215
|
|
|
|
|
|
|
}; |
216
|
|
|
|
|
|
|
|
217
|
0
|
0
|
|
|
|
0
|
if ($self->{'Compress'}) { |
218
|
0
|
|
|
|
|
0
|
$self->command("MODE Z");# TODO |
219
|
|
|
|
|
|
|
}; |
220
|
0
|
|
|
|
|
0
|
$self->{'RAWSock'}=$sock; |
221
|
|
|
|
|
|
|
|
222
|
0
|
0
|
|
|
|
0
|
if ($self->{'Compress'}) { |
223
|
|
|
|
|
|
|
# IO::Compress::Deflate |
224
|
|
|
|
|
|
|
# IO::Uncompress::Inflate |
225
|
|
|
|
|
|
|
}; |
226
|
|
|
|
|
|
|
|
227
|
0
|
0
|
0
|
|
|
0
|
if ($self->{'Encrypt'} && (! $self->{'FTPS'} )) { |
228
|
|
|
|
|
|
|
#{tie(*S, "Net::SSLeay::Handle", $sock);$sock = \*S;}; |
229
|
|
|
|
|
|
|
# Unique glob? |
230
|
0
|
|
|
|
|
0
|
{my $io=new IO::Handle; tie(*$io, "Net::SSLeay::Handle", $sock);$sock = \*$io;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
0
|
|
|
|
|
0
|
$self->{'Sock'}=$sock; |
234
|
0
|
|
|
|
|
0
|
{select($sock);$|=1;select(STDOUT);};#unbuffer socket |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
235
|
|
|
|
|
|
|
|
236
|
0
|
|
|
|
|
0
|
$self->setup_protection(); |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# |
239
|
0
|
|
|
|
|
0
|
return 1; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub quit { |
243
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
244
|
0
|
|
|
|
|
0
|
return $self->command("QUIT"); |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
sub noop { |
247
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
248
|
0
|
|
|
|
|
0
|
return $self->command("NOOP"); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
sub rename ($$$) { |
251
|
0
|
|
|
0
|
0
|
0
|
my ($self,$from,$to)=@_; |
252
|
|
|
|
|
|
|
#"RNFR plik1" |
253
|
|
|
|
|
|
|
#"RNTO plik2" |
254
|
0
|
0
|
|
|
|
0
|
if ($self->command("RNFR $from")) { |
255
|
0
|
|
|
|
|
0
|
return $self->command("RNTO $to"); |
256
|
0
|
|
|
|
|
0
|
} else {return 0;}; |
257
|
|
|
|
|
|
|
}; |
258
|
|
|
|
|
|
|
sub mdtm ($$) { |
259
|
0
|
|
|
0
|
0
|
0
|
my ($self,$file)=@_; |
260
|
0
|
|
|
|
|
0
|
return $self->command("MDTM $file"); |
261
|
|
|
|
|
|
|
}; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub command ($$){ |
264
|
0
|
|
|
0
|
0
|
0
|
my ($self,$data)=@_; |
265
|
0
|
0
|
|
|
|
0
|
print STDERR "Sending: ",$data."\n" if $self->{Debug}; |
266
|
0
|
|
|
|
|
0
|
my $sock=$self->{'Sock'}; |
267
|
|
|
|
|
|
|
# print $sock $data."\r\n"; |
268
|
0
|
|
|
|
|
0
|
syswrite( $sock ,$data."\r\n"); |
269
|
0
|
|
|
|
|
0
|
return $self->response(); |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
sub response ($) { |
273
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
274
|
0
|
|
|
|
|
0
|
my $sock=$self->{'Sock'}; |
275
|
0
|
|
|
|
|
0
|
my ($read,$resp,$code,$cont); |
276
|
0
|
|
|
|
|
0
|
my $start=time; |
277
|
0
|
|
|
|
|
0
|
$read=($resp=<$sock>);#, redo if (Errno::EAGAIN && (!defined($read))); |
278
|
|
|
|
|
|
|
#my $recvbytes=$sock->recv($read,1024);#, redo if Errno::EAGAIN; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
#TODO skip this, if RAWSock is disconnected... otherwise there's no sense in waiting for data.. |
281
|
|
|
|
|
|
|
|
282
|
0
|
|
0
|
|
|
0
|
while (!defined($read) && Errno::EAGAIN && (time-$start<190)) { |
|
|
|
0
|
|
|
|
|
283
|
0
|
|
|
|
|
0
|
$read=($resp=<$sock>); |
284
|
|
|
|
|
|
|
#, redo until timeout or sth |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
0
|
0
|
|
|
|
0
|
if (!defined($read)) { |
288
|
0
|
|
|
|
|
0
|
warn "EAGAIN again 190s! $!" if Errno::EAGAIN; |
289
|
0
|
|
|
|
|
0
|
warn "Damn! undefined response (err:$!) {H: ".$self->{'Host'}." P:".$self->{'Port'}."}\n";# unless defined($read); |
290
|
0
|
|
|
|
|
0
|
$self->{'FTPCODE'}=undef; |
291
|
0
|
|
|
|
|
0
|
$self->{'FTPMSG'}=undef; |
292
|
0
|
|
|
|
|
0
|
$self->{'FTPRAWMSG'}=undef; |
293
|
0
|
|
|
|
|
0
|
return undef;# unless defined($read); |
294
|
|
|
|
|
|
|
}; |
295
|
0
|
|
|
|
|
0
|
return $self->responserest($read); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub responserest ($$) { |
299
|
0
|
|
|
0
|
0
|
0
|
my ($self,$read)=@_; |
300
|
0
|
|
|
|
|
0
|
my $sock=$self->{'Sock'}; |
301
|
0
|
|
|
|
|
0
|
my ($resp,$code,$cont,$msg); |
302
|
0
|
|
|
|
|
0
|
$resp=$read; |
303
|
|
|
|
|
|
|
#UWAGA! |
304
|
|
|
|
|
|
|
# wcale nieprawda to co nizej pisze. Jesli pierwsza linijka to \d\d\d- |
305
|
|
|
|
|
|
|
# to odbierac linijki az do napotkania \d\d\d\s |
306
|
|
|
|
|
|
|
# np: |
307
|
|
|
|
|
|
|
# 226-EDI processing started |
308
|
|
|
|
|
|
|
# 01 costam... |
309
|
|
|
|
|
|
|
# 02 costam.. |
310
|
|
|
|
|
|
|
# 226 ...EDI processing complete |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# Responsy maja format \d\d\d |
314
|
|
|
|
|
|
|
# lub wielolinijkowe: \d\d\d- |
315
|
0
|
0
|
|
|
|
0
|
print STDERR "SRV Response: $read" if $self->{Debug}; |
316
|
0
|
0
|
|
|
|
0
|
$read=~/^(\d\d\d)\s(.*)/ && do { |
317
|
0
|
|
|
|
|
0
|
$code=$1;$msg=$2;chomp($msg); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
318
|
|
|
|
|
|
|
}; |
319
|
0
|
0
|
|
|
|
0
|
$read=~/^(\d\d\d)-(.*)/ && do { |
320
|
0
|
|
|
|
|
0
|
$cont=1;$code=$1;$msg.=$2; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
321
|
0
|
0
|
|
|
|
0
|
print STDERR "wielolinijkowa odpowiedz z servera.." if $self->{Debug}; |
322
|
|
|
|
|
|
|
}; |
323
|
0
|
0
|
|
|
|
0
|
if ($read=~/^(\d\d\d)\s(.*)/m) {$cont=0;}; # wyjatek na wielolinijkowe na dziendobry |
|
0
|
|
|
|
|
0
|
|
324
|
0
|
0
|
|
|
|
0
|
if ($cont) { |
325
|
0
|
|
|
|
|
0
|
do { |
326
|
0
|
|
|
|
|
0
|
$read=<$sock>; |
327
|
0
|
|
|
|
|
0
|
$resp.=$read; |
328
|
0
|
0
|
|
|
|
0
|
$read=~/^(\d\d\d)-(.*)/ && do {$cont=1;$code=$1;$msg.=$2;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
329
|
0
|
0
|
|
|
|
0
|
$read=~/^(\d\d\d)\s(.*)/ && do {$cont=0;$code=$1;$msg.=$2;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
330
|
0
|
0
|
|
|
|
0
|
print " ----> $read\n" if $self->{Debug}; |
331
|
|
|
|
|
|
|
} until ($cont==0); |
332
|
|
|
|
|
|
|
}; |
333
|
0
|
|
|
|
|
0
|
$self->{'FTPCODE'}=$code; |
334
|
0
|
|
|
|
|
0
|
$self->{'FTPMSG'}=$msg; |
335
|
|
|
|
|
|
|
#$resp=~s/^\d\d\d\s/; |
336
|
0
|
|
|
|
|
0
|
$self->{'FTPRAWMSG'}=$resp; |
337
|
|
|
|
|
|
|
|
338
|
0
|
0
|
|
|
|
0
|
if ($code>399) { |
339
|
|
|
|
|
|
|
#warn "Jaki¶ problem, chyba najlepiej sie wycofac\n"; |
340
|
|
|
|
|
|
|
#warn $resp; |
341
|
|
|
|
|
|
|
# print STDERR "ERR: $resp\n"; |
342
|
|
|
|
|
|
|
#warn "Server said we're bad."; |
343
|
0
|
|
|
|
|
0
|
$self->{'ErrMSG'}=$resp; |
344
|
0
|
|
|
|
|
0
|
return undef; |
345
|
|
|
|
|
|
|
}; |
346
|
0
|
0
|
|
|
|
0
|
print STDERR "RECV: ",$resp if $self->{Debug}; |
347
|
0
|
|
|
|
|
0
|
return $msg; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
0
|
|
|
0
|
0
|
0
|
sub list {return nlst(@_);}; |
351
|
|
|
|
|
|
|
sub nlst { |
352
|
0
|
|
|
0
|
0
|
0
|
my ($self,$mask)=@_; |
353
|
0
|
|
|
|
|
0
|
my $sock=$self->{'Sock'}; |
354
|
0
|
|
|
|
|
0
|
my $socket; |
355
|
0
|
|
|
|
|
0
|
my (@files)=(); |
356
|
0
|
|
|
|
|
0
|
$socket=$self->datasocket(); |
357
|
0
|
0
|
|
|
|
0
|
if (defined($socket)) { |
358
|
0
|
|
|
|
|
0
|
my $response; |
359
|
0
|
0
|
|
|
|
0
|
if (defined($mask)) { |
360
|
0
|
|
|
|
|
0
|
$response=$self->command("NLST $mask"); |
361
|
|
|
|
|
|
|
} else { |
362
|
0
|
|
|
|
|
0
|
$response=$self->command("NLST"); |
363
|
|
|
|
|
|
|
}; |
364
|
|
|
|
|
|
|
#print STDERR "ReSPONSE: -> : $response\n"; |
365
|
|
|
|
|
|
|
#print "KOD : ",$self->{'FTPCODE'},"\n"; |
366
|
|
|
|
|
|
|
# 1xx - cos jeszcze bedzie |
367
|
|
|
|
|
|
|
# 2xx - to juz koniec |
368
|
0
|
0
|
0
|
|
|
0
|
if ($response && ($self->{'FTPCODE'}<200) ) { |
369
|
|
|
|
|
|
|
|
370
|
0
|
0
|
|
|
|
0
|
if ($self->{"EncryptData"}==1) { |
371
|
0
|
|
|
|
|
0
|
{my $io=new IO::Handle; tie(*$io, "Net::SSLeay::Handle", $socket);$socket = \*$io;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
372
|
0
|
0
|
|
|
|
0
|
print STDERR "SSL for data connection enabled...\n" if $self->{Debug}; |
373
|
|
|
|
|
|
|
}; |
374
|
0
|
|
|
|
|
0
|
my $tmp; |
375
|
0
|
0
|
|
|
|
0
|
if ( $self->{'Compress'} ) { |
376
|
0
|
0
|
|
|
|
0
|
my $x = new Compress::Raw::Zlib::Inflate() |
377
|
|
|
|
|
|
|
or die "Cannot create a inflation stream\n" ; |
378
|
0
|
|
|
|
|
0
|
my $buf;my $read; |
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
|
|
0
|
my ($output, $status) ; |
381
|
0
|
|
|
|
|
0
|
while (sysread($socket,$buf,BUFSIZE)) |
382
|
|
|
|
|
|
|
{ |
383
|
0
|
|
|
|
|
0
|
$status = $x->inflate($buf, $output) ; |
384
|
0
|
|
|
|
|
0
|
$read+=length($output); |
385
|
|
|
|
|
|
|
#print $output ; |
386
|
0
|
0
|
|
|
|
0
|
print STDERR "LST: $output\n" if $self->{Debug}; |
387
|
0
|
|
|
|
|
0
|
$output=~s/\r\n$//; |
388
|
0
|
|
|
|
|
0
|
push @files,$output; |
389
|
|
|
|
|
|
|
|
390
|
0
|
0
|
|
|
|
0
|
last if $status != Z_OK ; |
391
|
|
|
|
|
|
|
}; |
392
|
0
|
0
|
|
|
|
0
|
die "inflation failed\n" |
393
|
|
|
|
|
|
|
unless $status == Z_STREAM_END ; |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# print STDERR "===> READ: $read\n"; |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
} else { |
398
|
|
|
|
|
|
|
#TODO: if {'Compress'} |
399
|
0
|
|
|
|
|
0
|
while ($tmp=<$socket>) { |
400
|
|
|
|
|
|
|
#print STDERR "G: $q"; |
401
|
|
|
|
|
|
|
#chop($tmp);chop($tmp);#\r\n -> remove. |
402
|
0
|
|
|
|
|
0
|
$tmp=~s/\r\n$//; |
403
|
0
|
|
|
|
|
0
|
push @files,$tmp; |
404
|
|
|
|
|
|
|
}; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
}; |
407
|
0
|
|
|
|
|
0
|
close $socket; |
408
|
0
|
0
|
0
|
|
|
0
|
if ($response && ($self->{'FTPCODE'}<200) ) {if ($response) {$response=$self->response();};} |
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
409
|
0
|
0
|
|
|
|
0
|
print STDERR "resp(end LIST) ",$response if $self->{Debug}; |
410
|
0
|
0
|
|
|
|
0
|
return \@files if $response; |
411
|
|
|
|
|
|
|
}; |
412
|
0
|
|
|
|
|
0
|
return 0; |
413
|
|
|
|
|
|
|
}; |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
sub putblat { |
416
|
0
|
|
|
0
|
0
|
0
|
my ($putorblat,$stororappe,$self,$remote,$local)=@_; |
417
|
0
|
|
|
|
|
0
|
my $socket; |
418
|
0
|
|
|
|
|
0
|
my $sock=$self->{'Sock'}; |
419
|
0
|
0
|
|
|
|
0
|
$local=$remote unless defined($local); |
420
|
0
|
0
|
|
|
|
0
|
$self->command("TYPE I") unless ($self->{'DontDoType'}); |
421
|
0
|
|
|
|
|
0
|
$socket=$self->datasocket(); |
422
|
0
|
0
|
|
|
|
0
|
warn "SOCKET NOT CONNECTED! $!\n" unless defined($socket); |
423
|
0
|
0
|
|
|
|
0
|
if ($self->{"EncryptData"}!=0) {$self->command("PROT P"); }; |
|
0
|
|
|
|
|
0
|
|
424
|
0
|
|
|
|
|
0
|
my $r=$self->command("$stororappe $remote"); |
425
|
0
|
0
|
|
|
|
0
|
if (!$r) { |
426
|
0
|
0
|
|
|
|
0
|
print STDERR "Problem trying to put file" if $self->{Debug}; |
427
|
0
|
|
|
|
|
0
|
return $r; |
428
|
|
|
|
|
|
|
}; |
429
|
|
|
|
|
|
|
|
430
|
0
|
0
|
|
|
|
0
|
if ($self->{"EncryptData"}==1) { |
431
|
0
|
|
|
|
|
0
|
{my $io=new IO::Handle; tie(*$io, "Net::SSLeay::Handle", $socket);$socket = \*$io;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
432
|
0
|
0
|
|
|
|
0
|
print STDERR "SSL for data connection enabled...\n" if $self->{Debug}; |
433
|
|
|
|
|
|
|
}; |
434
|
|
|
|
|
|
|
|
435
|
0
|
0
|
|
|
|
0
|
print STDERR "$stororappe connection opened.\n" if $self->{Debug}; |
436
|
0
|
|
|
|
|
0
|
select($socket); |
437
|
|
|
|
|
|
|
#print "selected.\n"; |
438
|
0
|
0
|
|
|
|
0
|
if ($putorblat=~/put/) { |
439
|
|
|
|
|
|
|
# |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
|
442
|
0
|
0
|
|
|
|
0
|
CORE::open(L,"$local") or die "Can't open file $local, $!"; |
443
|
0
|
|
|
|
|
0
|
binmode L; |
444
|
0
|
|
|
|
|
0
|
my $buf; |
445
|
|
|
|
|
|
|
|
446
|
0
|
0
|
|
|
|
0
|
if ($self->{'Compress'}) { |
447
|
|
|
|
|
|
|
#my $x = new Compress::Raw::Zlib::Deflate ( -Bufsize => 8192, -Level=> 1,-Strategy=>Z_DEFAULT_STRATEGY,-WindowBits=>15) |
448
|
0
|
0
|
|
|
|
0
|
my $x = new Compress::Raw::Zlib::Deflate ( -Bufsize => $self->{"CompressionBufsize"}, -Level=> $self->{"CompressionLevel"},-Strategy=>$self->{"CompressionStrategy"},-WindowBits=>$self->{"CompressionWindowBits"}) |
449
|
|
|
|
|
|
|
or die "Cannot create compression stream $!"; |
450
|
|
|
|
|
|
|
#deflate $local => $socket,AutoClose=>1,BinModeIn=>1 |
451
|
|
|
|
|
|
|
# or die "Cannot compress to $socket $DeflateError $!"; |
452
|
|
|
|
|
|
|
# |
453
|
0
|
|
|
|
|
0
|
my $read=0;my $circular=0; |
|
0
|
|
|
|
|
0
|
|
454
|
0
|
|
|
|
|
0
|
my ($output, $status) ; |
455
|
|
|
|
|
|
|
#while ($buf=) |
456
|
0
|
|
|
|
|
0
|
while ( sysread(L,$buf,BUFSIZE)) |
457
|
|
|
|
|
|
|
{ |
458
|
0
|
|
|
|
|
0
|
$status = $x->deflate($buf, $output) ; |
459
|
0
|
0
|
|
|
|
0
|
$status == Z_OK |
460
|
|
|
|
|
|
|
or die "deflation failed $!\n" ; |
461
|
0
|
|
|
|
|
0
|
print $output ; |
462
|
|
|
|
|
|
|
#print STDERR "GOT ".length($output)." bytes from deflation\n"; |
463
|
0
|
|
|
|
|
0
|
$read+=length($buf); |
464
|
|
|
|
|
|
|
#$circular+=length($buf); |
465
|
|
|
|
|
|
|
#if ($circular>8192) { |
466
|
|
|
|
|
|
|
# $circular=0; |
467
|
|
|
|
|
|
|
# print STDERR "trying part-flush\n"; |
468
|
|
|
|
|
|
|
# $status = $x->flush($output,Z_SYNC_FLUSH) ; |
469
|
|
|
|
|
|
|
# $status == Z_OK |
470
|
|
|
|
|
|
|
# or die "deflation failed $!\n" ; |
471
|
|
|
|
|
|
|
# print $output ; |
472
|
|
|
|
|
|
|
# print STDERR "GOT ".length($output)." bytes from no-flush-deflation\n"; |
473
|
|
|
|
|
|
|
#}; |
474
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'PutUpdateCallback'})) {$self->{'PutUpdateCallback'}->( length($buf) ); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
} |
477
|
0
|
0
|
|
|
|
0
|
print STDERR "out of buf LOOP\n" if $self->{Debug}; |
478
|
0
|
|
|
|
|
0
|
$status = $x->flush($output) ; |
479
|
0
|
0
|
|
|
|
0
|
$status == Z_OK |
480
|
|
|
|
|
|
|
or die "deflation failed $!\n" ; |
481
|
|
|
|
|
|
|
#print $output ; |
482
|
0
|
|
|
|
|
0
|
syswrite($socket, $output) ; |
483
|
0
|
0
|
|
|
|
0
|
print STDERR "GOT ".length($output)." bytes from flush-deflation\n" if $self->{Debug}; |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
else { |
487
|
0
|
|
|
|
|
0
|
while ($buf=) { |
488
|
0
|
|
|
|
|
0
|
print $buf; |
489
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'PutUpdateCallback'})) {$self->{'PutUpdateCallback'}->( length($buf) ); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
490
|
|
|
|
|
|
|
};#Probably syswrite/sysread would be smarter.. |
491
|
|
|
|
|
|
|
} |
492
|
0
|
|
|
|
|
0
|
close L; |
493
|
|
|
|
|
|
|
} else { |
494
|
0
|
0
|
|
|
|
0
|
if ($self->{'Compress'}) { |
495
|
0
|
0
|
|
|
|
0
|
my $x = new Compress::Raw::Zlib::Deflate ( -Bufsize => 8192) |
496
|
|
|
|
|
|
|
or die "Cannot create compression stream $!"; |
497
|
0
|
|
|
|
|
0
|
my $output; |
498
|
0
|
|
|
|
|
0
|
my $status = $x->deflate($local, $output) ; |
499
|
0
|
0
|
|
|
|
0
|
$status == Z_OK |
500
|
|
|
|
|
|
|
or die "deflation failed\n" ; |
501
|
|
|
|
|
|
|
#print $output ; |
502
|
0
|
|
|
|
|
0
|
syswrite($socket, $output) ; |
503
|
0
|
|
|
|
|
0
|
$status = $x->flush($output) ; |
504
|
0
|
0
|
|
|
|
0
|
$status == Z_OK |
505
|
|
|
|
|
|
|
or die "deflation failed\n" ; |
506
|
|
|
|
|
|
|
#print $output ; |
507
|
0
|
|
|
|
|
0
|
syswrite($socket, $output) ; |
508
|
|
|
|
|
|
|
} else { |
509
|
|
|
|
|
|
|
#print $local; |
510
|
0
|
|
|
|
|
0
|
syswrite($socket, $local) ; |
511
|
|
|
|
|
|
|
}; |
512
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'PutUpdateCallback'})) {$self->{'PutUpdateCallback'}->( length($local) ); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
#print "after write...\n"; |
515
|
0
|
|
|
|
|
0
|
select(STDOUT); |
516
|
0
|
|
|
|
|
0
|
$socket->flush(); |
517
|
0
|
|
|
|
|
0
|
close $socket; |
518
|
0
|
|
|
|
|
0
|
my $response=$self->response(); |
519
|
0
|
0
|
|
|
|
0
|
print STDERR "resp(after$stororappe) ",$response if $self->{Debug}; |
520
|
0
|
0
|
|
|
|
0
|
if (defined $self->{'PutDoneCallBack'}) {$self->{'PutDoneCallBack'}->($response);}; |
|
0
|
|
|
|
|
0
|
|
521
|
0
|
|
|
|
|
0
|
return $self->{'FTPRAWMSG'}; |
522
|
|
|
|
|
|
|
}; |
523
|
|
|
|
|
|
|
sub put { |
524
|
0
|
|
|
0
|
0
|
0
|
putblat('put','STOR',@_); |
525
|
|
|
|
|
|
|
}; |
526
|
|
|
|
|
|
|
sub blat { |
527
|
0
|
|
|
0
|
0
|
0
|
putblat('blat','STOR',@_); |
528
|
|
|
|
|
|
|
}; |
529
|
|
|
|
|
|
|
sub appe { |
530
|
0
|
|
|
0
|
0
|
0
|
putblat('put','APPE',@_); |
531
|
|
|
|
|
|
|
}; |
532
|
|
|
|
|
|
|
sub blatappe { |
533
|
0
|
|
|
0
|
0
|
0
|
putblat('blat','APPE',@_); |
534
|
|
|
|
|
|
|
}; |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
sub get { |
537
|
0
|
|
|
0
|
0
|
0
|
getslurp('get',@_); |
538
|
|
|
|
|
|
|
}; |
539
|
|
|
|
|
|
|
sub slurp { |
540
|
0
|
|
|
0
|
0
|
0
|
getslurp('slurp',@_); |
541
|
|
|
|
|
|
|
}; |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub getslurp { |
544
|
0
|
|
|
0
|
0
|
0
|
my ($getorslurp,$self,$remote,$local)=@_; |
545
|
0
|
|
|
|
|
0
|
my $socket; |
546
|
0
|
|
|
|
|
0
|
my $sock=$self->{'Sock'}; |
547
|
0
|
0
|
|
|
|
0
|
$local=$remote unless defined($local); |
548
|
0
|
|
|
|
|
0
|
$self->command("TYPE I"); |
549
|
0
|
|
|
|
|
0
|
$socket=$self->datasocket(); |
550
|
|
|
|
|
|
|
#tmp |
551
|
|
|
|
|
|
|
#setsockopt($sock,&SOL_SOCKET,&SO_KEEPALIVE,undef,undef) || warn "setsockopt: $!"; |
552
|
0
|
0
|
|
|
|
0
|
setsockopt($socket, SOL_SOCKET, SO_SNDTIMEO, pack('L!L!', 15, 0) ) or warn "setsockopt SNDTIMEO: ".$!; |
553
|
0
|
0
|
|
|
|
0
|
setsockopt($socket, SOL_SOCKET, SO_RCVTIMEO, pack('L!L!', 15, 0) ) or warn "setsockopt RCVTIMEO: ".$!; |
554
|
0
|
0
|
|
|
|
0
|
setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE, 1 ) or warn "setsockopt KEEPALIVE: ".$!; |
555
|
0
|
0
|
|
|
|
0
|
setsockopt($socket, IPPROTO_IP, IP_TOS(), pack("I*",0x08 )) or warn "setsockopt TOS THROUGPHUT problem: $!";#THROUGHPUT |
556
|
|
|
|
|
|
|
#end tmp 2008-11-04 |
557
|
|
|
|
|
|
|
|
558
|
0
|
0
|
|
|
|
0
|
if ($self->{"EncryptData"}!=0) {$self->command("PROT P"); }; |
|
0
|
|
|
|
|
0
|
|
559
|
0
|
|
|
|
|
0
|
my $r=$self->command("RETR $remote"); |
560
|
0
|
0
|
|
|
|
0
|
if (!$r) { |
561
|
0
|
0
|
|
|
|
0
|
print STDERR "Problem trying to get file($remote)" if $self->{Debug}; |
562
|
0
|
|
|
|
|
0
|
return $r; |
563
|
|
|
|
|
|
|
}; |
564
|
|
|
|
|
|
|
|
565
|
0
|
0
|
|
|
|
0
|
if ($self->{"EncryptData"}==1) { |
566
|
0
|
|
|
|
|
0
|
{my $io=new IO::Handle; tie(*$io, "Net::SSLeay::Handle", $socket);$socket = \*$io;}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
567
|
0
|
0
|
|
|
|
0
|
print STDERR "SSL for data connection(RETR) enabled...\n" if $self->{Debug}; |
568
|
|
|
|
|
|
|
}; |
569
|
0
|
|
|
|
|
0
|
my $slurped=""; |
570
|
0
|
0
|
|
|
|
0
|
if ($getorslurp=~/get/) { |
571
|
0
|
0
|
|
|
|
0
|
print STDERR "getorslurp: get\n" if $self->{Debug}; |
572
|
0
|
0
|
|
|
|
0
|
CORE::open(L,">$local") or die("Can't open file for writing $local, $!"); |
573
|
0
|
|
|
|
|
0
|
binmode L; |
574
|
0
|
|
|
|
|
0
|
my $tmp;my $cntr=0; |
|
0
|
|
|
|
|
0
|
|
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
|
577
|
0
|
0
|
|
|
|
0
|
if ($self->{'Compress'}) { |
578
|
|
|
|
|
|
|
#my $z = new IO::Uncompress::Inflate $socket, AutoClose=>1,Strict=>1 |
579
|
|
|
|
|
|
|
# or die "IO::Uncompress::Inflate failed: $InflateError\n"; |
580
|
|
|
|
|
|
|
#inflate $socket => "ftp.".$local, AutoClose=>1 |
581
|
|
|
|
|
|
|
# or die "Cannot decompress from $socket to $local $InflateError $!"; |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
|
584
|
0
|
0
|
|
|
|
0
|
my $x = new Compress::Raw::Zlib::Inflate() |
585
|
|
|
|
|
|
|
or die "Cannot create a inflation stream\n" ; |
586
|
0
|
|
|
|
|
0
|
my $buf;my $read; |
587
|
|
|
|
|
|
|
|
588
|
0
|
|
|
|
|
0
|
my ($output, $status) ; |
589
|
0
|
|
|
|
|
0
|
while (sysread($socket,$buf,BUFSIZE)) |
590
|
|
|
|
|
|
|
{ |
591
|
0
|
|
|
|
|
0
|
$status = $x->inflate($buf, $output) ; |
592
|
0
|
|
|
|
|
0
|
$read+=length($output); |
593
|
|
|
|
|
|
|
#print $output ; |
594
|
0
|
|
|
|
|
0
|
print L $output; |
595
|
0
|
0
|
|
|
|
0
|
print STDERR length($output),":;".++$cntr."\n" if $self->{Debug}; |
596
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'GetUpdateCallback'})) {$self->{'GetUpdateCallback'}->(length($output)); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
597
|
0
|
0
|
|
|
|
0
|
last if $status != Z_OK ; |
598
|
|
|
|
|
|
|
}; |
599
|
0
|
0
|
|
|
|
0
|
die "inflation failed\n" |
600
|
|
|
|
|
|
|
unless $status == Z_STREAM_END ; |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
# print STDERR "===> READ: $read\n"; |
603
|
|
|
|
|
|
|
} else |
604
|
|
|
|
|
|
|
{ |
605
|
|
|
|
|
|
|
# TODO replace while <$socket> with |
606
|
|
|
|
|
|
|
# TODO while sysread($sock,$tmp,BUFSIZE); |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
0
|
while (sysread($socket,$tmp,BUFSIZE)) { |
609
|
0
|
|
|
|
|
0
|
print L $tmp; |
610
|
0
|
0
|
|
|
|
0
|
print STDERR length($tmp),":;".++$cntr."\n" if $self->{Debug}; |
611
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'GetUpdateCallback'})) {$self->{'GetUpdateCallback'}->(length($tmp)); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
612
|
|
|
|
|
|
|
}; |
613
|
|
|
|
|
|
|
#tmp-2008-10-22# while ($tmp=<$socket>) { |
614
|
|
|
|
|
|
|
#tmp-2008-10-22# print L $tmp; |
615
|
|
|
|
|
|
|
#tmp-2008-10-22# print STDERR length($tmp),":;\n" if $self->{Debug}; |
616
|
|
|
|
|
|
|
#tmp-2008-10-22# if (defined ($self->{'GetUpdateCallback'})) {$self->{'GetUpdateCallback'}->();print STDERR "GUC defined, and has been called\n"; };#TODO send sth.. |
617
|
|
|
|
|
|
|
#tmp-2008-10-22# }; |
618
|
0
|
|
|
|
|
0
|
close L; |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
} else { |
621
|
|
|
|
|
|
|
|
622
|
0
|
0
|
|
|
|
0
|
print STDERR "getorslurp: slurp($getorslurp)\n" if $self->{Debug}; |
623
|
0
|
|
|
|
|
0
|
my $tmp; |
624
|
|
|
|
|
|
|
|
625
|
0
|
0
|
|
|
|
0
|
if ($self->{'Compress'}) { |
626
|
0
|
0
|
|
|
|
0
|
my $x = new Compress::Raw::Zlib::Inflate() |
627
|
|
|
|
|
|
|
or die "Cannot create a inflation stream\n" ; |
628
|
0
|
|
|
|
|
0
|
my $buf;my $read; |
629
|
|
|
|
|
|
|
|
630
|
0
|
|
|
|
|
0
|
my ($output, $status) ; |
631
|
0
|
|
|
|
|
0
|
while (sysread($socket,$buf,BUFSIZE)) |
632
|
|
|
|
|
|
|
{ |
633
|
0
|
|
|
|
|
0
|
$status = $x->inflate($buf, $output) ; |
634
|
0
|
|
|
|
|
0
|
$read+=length($output); |
635
|
|
|
|
|
|
|
#print $output ; |
636
|
0
|
|
|
|
|
0
|
$slurped.=$output; |
637
|
0
|
0
|
|
|
|
0
|
print STDERR length($output),":slurpZ;" if $self->{Debug}; |
638
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'GetUpdateCallback'})) {$self->{'GetUpdateCallback'}->(length($output)); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
639
|
0
|
0
|
|
|
|
0
|
last if $status != Z_OK ; |
640
|
|
|
|
|
|
|
}; |
641
|
0
|
0
|
|
|
|
0
|
die "inflation failed\n" |
642
|
|
|
|
|
|
|
unless $status == Z_STREAM_END ; |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
} else { |
646
|
0
|
|
|
|
|
0
|
while ($tmp=<$socket>) { |
647
|
0
|
0
|
|
|
|
0
|
$slurped.=$tmp;print STDERR ":slurp." if $self->{Debug}; |
|
0
|
|
|
|
|
0
|
|
648
|
0
|
0
|
|
|
|
0
|
if (defined ($self->{'GetUpdateCallback'})) {$self->{'GetUpdateCallback'}->( length($tmp) ); };#TODO send sth.. |
|
0
|
|
|
|
|
0
|
|
649
|
|
|
|
|
|
|
}; |
650
|
|
|
|
|
|
|
}; |
651
|
|
|
|
|
|
|
}; |
652
|
0
|
|
|
|
|
0
|
close $socket; |
653
|
0
|
|
|
|
|
0
|
my $response=$self->response(); |
654
|
0
|
0
|
|
|
|
0
|
print STDERR "resp(afterRETR) ",$response if $self->{Debug}; |
655
|
0
|
0
|
|
|
|
0
|
if (defined $self->{'GetDoneCallBack'}) {$self->{'GetDoneCallBack'}->($response);}; |
|
0
|
|
|
|
|
0
|
|
656
|
0
|
|
|
|
|
0
|
return $slurped; |
657
|
|
|
|
|
|
|
}; |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
sub datasocket { |
660
|
0
|
|
|
0
|
0
|
0
|
my ($self)=@_; |
661
|
0
|
|
|
|
|
0
|
my ($tmp,$socket); |
662
|
0
|
0
|
|
|
|
0
|
if ($tmp=$self->command("PASV")) { |
663
|
0
|
0
|
0
|
|
|
0
|
if ($self->msgcode()==227 && $tmp=~/[^\d]*(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) { |
664
|
0
|
|
|
|
|
0
|
my $port=$5*256+$6; |
665
|
0
|
|
|
|
|
0
|
my $host="$1.$2.$3.$4"; |
666
|
0
|
0
|
|
|
|
0
|
print STDERR "PASV port is $port ( $host )\n" if $self->{Debug}; |
667
|
0
|
0
|
|
|
|
0
|
if (defined($self->{'ForcePASVIP'})) {$host=$self->{'ForcePASVIP'};print STDERR "Forcing PASV IP to $host\n" if $self->{Debug}}; |
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
668
|
0
|
|
|
|
|
0
|
$socket = Net::SSLeay::Handle->make_socket($host, $port); |
669
|
0
|
|
|
|
|
0
|
setsockopt($socket, IPPROTO_IP, IP_TOS(), pack("I*",0x08 ));#THROUGHPUT |
670
|
0
|
0
|
|
|
|
0
|
if (defined($socket)) { |
671
|
0
|
0
|
|
|
|
0
|
print STDERR "Data link connected.. to $host at $port\n" if $self->{Debug}; |
672
|
|
|
|
|
|
|
} else { |
673
|
0
|
|
|
|
|
0
|
warn "Data link NOT connected ($host,$port) $!"; |
674
|
0
|
|
|
|
|
0
|
die "Data link NOT connected ($host,$port) $!"; |
675
|
|
|
|
|
|
|
}; |
676
|
|
|
|
|
|
|
} else { |
677
|
0
|
|
|
|
|
0
|
die "Problem parsing PASV response($tmp)"; |
678
|
|
|
|
|
|
|
}; |
679
|
|
|
|
|
|
|
} else { |
680
|
0
|
|
|
|
|
0
|
warn "undefined response to PASV cmd (err:$!) {H: ".$self->{'Host'}." P:".$self->{'Port'}."}\n";# unless defined($read); |
681
|
0
|
|
|
|
|
0
|
die "Problem sending PASV request, $tmp"; |
682
|
|
|
|
|
|
|
};# end if self -> command PASV |
683
|
0
|
|
|
|
|
0
|
return $socket |
684
|
|
|
|
|
|
|
}; |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
sub trivialm { |
687
|
1
|
|
|
1
|
0
|
650
|
my ($self)=@_; |
688
|
1
|
|
|
|
|
5
|
return 1; |
689
|
|
|
|
|
|
|
}; |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
# extras... |
692
|
|
|
|
|
|
|
# |
693
|
|
|
|
|
|
|
sub registerGetUpdateCallback { |
694
|
0
|
|
|
0
|
0
|
|
my ($self,$callback_ref)=@_; |
695
|
|
|
|
|
|
|
|
696
|
0
|
|
|
|
|
|
$self->{'GetUpdateCallback'} = $callback_ref; |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
sub registerGetDoneCallback { |
699
|
0
|
|
|
0
|
0
|
|
my ($self,$callback_ref)=@_; |
700
|
|
|
|
|
|
|
|
701
|
0
|
|
|
|
|
|
$self->{'GetDoneCallback'} = $callback_ref; |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
sub registerPutUpdateCallback { |
704
|
0
|
|
|
0
|
0
|
|
my ($self,$callback_ref)=@_; |
705
|
|
|
|
|
|
|
|
706
|
0
|
|
|
|
|
|
$self->{'PutUpdateCallback'} = $callback_ref; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
sub registerPutDoneCallback { |
709
|
0
|
|
|
0
|
0
|
|
my ($self,$callback_ref)=@_; |
710
|
|
|
|
|
|
|
|
711
|
0
|
|
|
|
|
|
$self->{'PutDoneCallback'} = $callback_ref; |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub setup_protection { |
715
|
0
|
|
|
0
|
0
|
|
my ($self)=@_; |
716
|
0
|
0
|
|
|
|
|
if ($self->{'Encrypt'}) { |
717
|
0
|
|
|
|
|
|
$self->command("PBSZ 0");# TODO |
718
|
0
|
0
|
|
|
|
|
if ($self->{"EncryptData"}!=0) {$self->command("PROT P"); }; |
|
0
|
|
|
|
|
|
|
719
|
0
|
|
|
|
|
|
} else {return 1;}; |
720
|
|
|
|
|
|
|
}; |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
sub check_raw_socket { |
724
|
0
|
|
|
0
|
0
|
|
my ($self)=@_; |
725
|
1
|
|
|
1
|
|
10
|
use Socket; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
768
|
|
726
|
0
|
|
|
|
|
|
my $s=$self->{'RAWSock'}; |
727
|
0
|
|
|
|
|
|
my $hersockaddr = getpeername($s); |
728
|
0
|
|
|
|
|
|
my ($port, $iaddr) = sockaddr_in($hersockaddr); |
729
|
0
|
|
|
|
|
|
return $s->eof."$hersockaddr $port $iaddr"; |
730
|
|
|
|
|
|
|
}; |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
1; |
735
|
|
|
|
|
|
|
__END__ |