File Coverage

blib/lib/Net/Lite/FTP.pm
Criterion Covered Total %
statement 52 431 12.0
branch 0 228 0.0
condition 0 20 0.0
subroutine 13 56 23.2
pod 0 45 0.0
total 65 780 8.3


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__