This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_12 to perl5.003_13]
[perl5.git] / lib / Net / FTP.pm
1 # Net::FTP.pm
2 #
3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
4 # reserved. This program is free software; you can redistribute it and/or
5 # modify it under the same terms as Perl itself.
6
7 package Net::FTP;
8
9 =head1 NAME
10
11 Net::FTP - FTP Client class
12
13 =head1 SYNOPSIS
14
15     use Net::FTP;
16     
17     $ftp = Net::FTP->new("some.host.name");
18     $ftp->login("anonymous","me@here.there");
19     $ftp->cwd("/pub");
20     $ftp->get("that.file");
21     $ftp->quit;
22
23 =head1 DESCRIPTION
24
25 C<Net::FTP> is a class implementing a simple FTP client in Perl as described
26 in RFC959
27
28 C<Net::FTP> provides methods that will perform various operations. These methods
29 could be split into groups depending the level of interface the user requires.
30
31 =head1 CONSTRUCTOR
32
33 =over 4
34
35 =item new (HOST [,OPTIONS])
36
37 This is the constructor for a new Net::SMTP object. C<HOST> is the
38 name of the remote host to which a FTP connection is required.
39
40 C<OPTIONS> are passed in a hash like fasion, using key and value pairs.
41 Possible options are:
42
43 B<Firewall> - The name of a machine which acts as a FTP firewall. This can be
44 overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
45 given host cannot be directly connected to, then the
46 connection is made to the firwall machine and the string C<@hostname> is
47 appended to the login identifier.
48
49 B<Port> - The port number to connect to on the remote machine for the
50 FTP connection
51
52 B<Timeout> - Set a timeout value (defaults to 120)
53
54 B<Debug> - Debug level
55
56 B<Passive> - If set to I<true> then all data transfers will be done using 
57 passive mode. This is required for some I<dumb> servers.
58
59 =back
60
61 =head1 METHODS
62
63 Unless otherwise stated all methods return either a I<true> or I<false>
64 value, with I<true> meaning that the operation was a success. When a method
65 states that it returns a value, falure will be returned as I<undef> or an
66 empty list.
67
68 =over 4
69
70 =item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
71
72 Log into the remote FTP server with the given login information. If
73 no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
74 package to lookup the login information for the connected host.
75 If no information is found then a login of I<anonymous> is used.
76 If no password is given and the login is I<anonymous> then the users
77 Email address will be used for a password.
78
79 If the connection is via a firewall then the C<authorize> method will
80 be called with no arguments.
81
82 =item authorize ( [AUTH [, RESP]])
83
84 This is a protocol used by some firewall ftp proxies. It is used
85 to authorise the user to send data out.  If both arguments are not specified
86 then C<authorize> uses C<Net::Netrc> to do a lookup.
87
88 =item type (TYPE [, ARGS])
89
90 This method will send the TYPE command to the remote FTP server
91 to change the type of data transfer. The return value is the previous
92 value.
93
94 =item ascii ([ARGS]) binary([ARGS]) ebcdic([ARGS]) byte([ARGS])
95
96 Synonyms for C<type> with the first arguments set correctly
97
98 B<NOTE> ebcdic and byte are not fully supported.
99
100 =item rename ( OLDNAME, NEWNAME )
101
102 Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
103 is done by sending the RNFR and RNTO commands.
104
105 =item delete ( FILENAME )
106
107 Send a request to the server to delete C<FILENAME>.
108
109 =item cwd ( [ DIR ] )
110
111 Change the current working directory to C<DIR>, or / if not given.
112
113 =item cdup ()
114
115 Change directory to the parent of the current directory.
116
117 =item pwd ()
118
119 Returns the full pathname of the current directory.
120
121 =item rmdir ( DIR )
122
123 Remove the directory with the name C<DIR>.
124
125 =item mkdir ( DIR [, RECURSE ])
126
127 Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
128 C<mkdir> will attempt to create all the directories in the given path.
129
130 Returns the full pathname to the new directory.
131
132 =item ls ( [ DIR ] )
133
134 Get a directory listing of C<DIR>, or the current directory.
135
136 Returns a reference to a list of lines returned from the server.
137
138 =item dir ( [ DIR ] )
139
140 Get a directory listing of C<DIR>, or the current directory in long format.
141
142 Returns a reference to a list of lines returned from the server.
143
144 =item get ( REMOTE_FILE [, LOCAL_FILE ] )
145
146 Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
147 a filename or a filehandle. If not specified the the file will be stored in
148 the current directory with the same leafname as the remote file.
149
150 Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
151 is not given.
152
153 =item put ( LOCAL_FILE [, REMOTE_FILE ] )
154
155 Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
156 If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
157 C<REMOTE_FILE> is not specified then the file will be stored in the current
158 directory with the same leafname as C<LOCAL_FILE>.
159
160 Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
161 is not given.
162
163 =item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
164
165 Same as put but uses the C<STOU> command.
166
167 Returns the name of the file on the server.
168
169 =item append ( LOCAL_FILE [, REMOTE_FILE ] )
170
171 Same as put but appends to the file on the remote server.
172
173 Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
174 is not given.
175
176 =item unique_name ()
177
178 Returns the name of the last file stored on the server using the
179 C<STOU> command.
180
181 =item mdtm ( FILE )
182
183 Returns the I<modification time> of the given file
184
185 =item size ( FILE )
186
187 Returns the size in bytes for the given file.
188
189 =back
190
191 The following methods can return different results depending on
192 how they are called. If the user explicitly calls either
193 of the C<pasv> or C<port> methods then these methods will
194 return a I<true> or I<false> value. If the user does not
195 call either of these methods then the result will be a
196 reference to a C<Net::FTP::dataconn> based object.
197
198 =over 4
199
200 =item nlst ( [ DIR ] )
201
202 Send a C<NLST> command to the server, with an optional parameter.
203
204 =item list ( [ DIR ] )
205
206 Same as C<nlst> but using the C<LIST> command
207
208 =item retr ( FILE )
209
210 Begin the retrieval of a file called C<FILE> from the remote server.
211
212 =item stor ( FILE )
213
214 Tell the server that you wish to store a file. C<FILE> is the
215 name of the new file that should be created.
216
217 =item stou ( FILE )
218
219 Same as C<stor> but using the C<STOU> command. The name of the unique
220 file which was created on the server will be avalaliable via the C<unique_name>
221 method after the data connection has been closed.
222
223 =item appe ( FILE )
224
225 Tell the server that we want to append some data to the end of a file
226 called C<FILE>. If this file does not exist then create it.
227
228 =back
229
230 If for some reason you want to have complete control over the data connection,
231 this includes generating it and calling the C<response> method when required,
232 then the user can use these methods to do so.
233
234 However calling these methods only affects the use of the methods above that
235 can return a data connection. They have no effect on methods C<get>, C<put>,
236 C<put_unique> and those that do not require data connections.
237
238 =over 4
239
240 =item port ( [ PORT ] )
241
242 Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
243 to the server. If not the a listen socket is created and the correct information
244 sent to the server.
245
246 =item pasv ()
247
248 Tell the server to go into passive mode. Returns the text that represents the
249 port on which the server is listening, this text is in a suitable form to
250 sent to another ftp server using the C<port> method.
251
252 =back
253
254 The following methods can be used to transfer files between two remote
255 servers, providing that these two servers can connect directly to each other.
256
257 =over 4
258
259 =item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
260
261 This method will do a file transfer between two remote ftp servers. If
262 C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
263
264 =item pasv_wait ( NON_PASV_SERVER )
265
266 This method can be used to wait for a transfer to complete between a passive
267 server and a non-passive server. The method should be called on the passive
268 server with the C<Net::FTP> object for the non-passive server passed as an
269 argument.
270
271 =item abort ()
272
273 Abort the current data transfer.
274
275 =item quit ()
276
277 Send the QUIT command to the remote FTP server and close the socket connection.
278
279 =back
280
281 =head2 Methods for the adventurous
282
283 C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
284 be used to send commands to the remote FTP server.
285
286 =over 4
287
288 =item quot (CMD [,ARGS])
289
290 Send a command, that Net::FTP does not directly support, to the remote
291 server and wait for a response.
292
293 Returns most significant digit of the response code.
294
295 B<WARNING> This call should only be used on commands that do not require
296 data connections. Misuse of this method can hang the connection.
297
298 =back
299
300 =head1 THE dataconn CLASS
301
302 Some of the methods defined in C<Net::FTP> return an object which will
303 be derived from this class.The dataconn class itself is derived from
304 the C<IO::Socket::INET> class, so any normal IO operations can be performed.
305 However the following methods are defined in the dataconn class and IO should
306 be performed using these.
307
308 =over 4
309
310 =item read ( BUFFER, SIZE [, TIMEOUT ] )
311
312 Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
313 performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
314 given the the timeout value from the command connection will be used.
315
316 Returns the number of bytes read before any <CRLF> translation.
317
318 =item write ( BUFFER, SIZE [, TIMEOUT ] )
319
320 Write C<SIZE> bytes of data from C<BUFFER> to the server, also
321 performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
322 given the the timeout value from the command connection will be used.
323
324 Returns the number of bytes written before any <CRLF> translation.
325
326 =item abort ()
327
328 Abort the current data transfer.
329
330 =item close ()
331
332 Close the data connection and get a response from the FTP server. Returns
333 I<true> if the connection was closed sucessfully and the first digit of
334 the response from the server was a '2'.
335
336 =back
337
338 =head1 AUTHOR
339
340 Graham Barr <Graham.Barr@tiuk.ti.com>
341
342 =head1 REVISION
343
344 $Revision: 2.8 $
345 $Date: 1996/09/05 06:53:58 $
346
347 The VERSION is derived from the revision by changing each number after the
348 first dot into a 2 digit number so
349
350         Revision 1.8   => VERSION 1.08
351         Revision 1.2.3 => VERSION 1.0203
352
353 =head1 SEE ALSO
354
355 L<Net::Netrc>
356 L<Net::Cmd>
357
358 =head1 CREDITS
359
360 Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
361 recursively.
362
363 =head1 COPYRIGHT
364
365 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
366 software; you can redistribute it and/or modify it under the same terms
367 as Perl itself.
368
369 =cut
370
371 require 5.001;
372
373 use strict;
374 use vars qw(@ISA $VERSION);
375 use Carp;
376
377 use Socket 1.3;
378 use IO::Socket;
379 use Time::Local;
380 use Net::Cmd;
381 use Net::Telnet qw(TELNET_IAC TELNET_IP TELNET_DM);
382
383 $VERSION = do{my @r=(q$Revision: 2.8 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
384 @ISA     = qw(Exporter Net::Cmd IO::Socket::INET);
385
386 sub new
387 {
388  my $pkg  = shift;
389  my $peer = shift;
390  my %arg  = @_; 
391
392  my $host = $peer;
393  my $fire = undef;
394
395  unless(defined inet_aton($peer))
396   {
397    $fire = $ENV{FTP_FIREWALL} || $arg{Firewall} || undef;
398    if(defined $fire)
399     {
400      $peer = $fire;
401      delete $arg{Port};
402     }
403   }
404
405  my $ftp = $pkg->SUPER::new(PeerAddr => $peer, 
406                             PeerPort => $arg{Port} || 'ftp(21)',
407                             Proto    => 'tcp',
408                             Timeout  => defined $arg{Timeout}
409                                                 ? $arg{Timeout}
410                                                 : 120
411                            ) or return undef;
412
413  ${*$ftp}{'net_ftp_passive'} = $arg{Passive} || 0;  # Always use pasv mode
414  ${*$ftp}{'net_ftp_host'}    = $host;               # Remote hostname
415  ${*$ftp}{'net_ftp_type'}    = 'A';                 # ASCII/binary/etc mode
416
417  ${*$ftp}{'net_ftp_firewall'} = $fire
418     if defined $fire;
419
420  $ftp->autoflush(1);
421
422  $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
423
424  unless ($ftp->response() == CMD_OK)
425   {
426    $ftp->SUPER::close();
427    undef $ftp;
428   }
429
430  $ftp;
431 }
432
433 ##
434 ## User interface methods
435 ##
436
437 sub quit
438 {
439  my $ftp = shift;
440
441  $ftp->_QUIT
442     && $ftp->SUPER::close;
443 }
444
445 sub close
446 {
447  my $ftp = shift;
448
449  ref($ftp) 
450     && defined fileno($ftp)
451     && $ftp->quit;
452 }
453
454 sub DESTROY { shift->close }
455
456 sub ascii  { shift->type('A',@_); }
457 sub binary { shift->type('I',@_); }
458
459 sub ebcdic
460 {
461  carp "TYPE E is unsupported, shall default to I";
462  shift->type('E',@_);
463 }
464
465 sub byte
466 {
467  carp "TYPE L is unsupported, shall default to I";
468  shift->type('L',@_);
469 }
470
471 # Allow the user to send a command directly, BE CAREFUL !!
472
473 sub quot
474
475  my $ftp = shift;
476  my $cmd = shift;
477
478  $ftp->command( uc $cmd, @_);
479  $ftp->response();
480 }
481
482 sub mdtm
483 {
484  my $ftp  = shift;
485  my $file = shift;
486
487  return undef
488         unless $ftp->_MDTM($file);
489
490  my @gt = reverse ($ftp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/);
491  $gt[5] -= 1;
492  timegm(@gt);
493 }
494
495 sub size
496 {
497  my $ftp  = shift;
498  my $file = shift;
499
500  $ftp->_SIZE($file)
501         ? ($ftp->message =~ /(\d+)/)[0]
502         : undef;
503 }
504
505 sub login
506 {
507  my($ftp,$user,$pass,$acct) = @_;
508  my($ok,$ruser);
509
510  unless (defined $user)
511   {
512    require Net::Netrc;
513
514    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
515
516    ($user,$pass,$acct) = $rc->lpa()
517         if ($rc);
518   }
519
520  $user ||= "anonymous";
521  $ruser = $user;
522
523  if(defined ${*$ftp}{'net_ftp_firewall'})
524   {
525    $user .= "@" . ${*$ftp}{'net_ftp_host'};
526   }
527
528  $ok = $ftp->_USER($user);
529
530  # Some dumb firewall's don't prefix the connection messages
531  $ok = $ftp->response()
532         if($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
533
534  if ($ok == CMD_MORE)
535   {
536    unless(defined $pass)
537     {
538      require Net::Netrc;
539
540      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
541
542      ($ruser,$pass,$acct) = $rc->lpa()
543         if ($rc);
544
545      $pass = "-" . (getpwuid($>))[0] . "@" 
546         if (!defined $pass && $ruser =~ /^anonymous/o);
547     }
548
549    $ok = $ftp->_PASS($pass || "");
550   }
551
552  $ok = $ftp->_ACCT($acct || "")
553         if ($ok == CMD_MORE);
554
555  $ftp->authorize()
556     if($ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'});
557
558  $ok == CMD_OK;
559 }
560
561 sub authorize
562 {
563  @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
564
565  my($ftp,$auth,$resp) = @_;
566
567  unless(defined $resp)
568   {
569    require Net::Netrc;
570
571    $auth ||= (getpwuid($>))[0];
572
573    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
574         || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
575
576    ($auth,$resp) = $rc->lpa()
577      if($rc);
578   }
579
580  my $ok = $ftp->_AUTH($auth || "");
581
582  $ok = $ftp->_RESP($resp || "")
583         if ($ok == CMD_MORE);
584
585  $ok == CMD_OK;
586 }
587
588 sub rename
589 {
590  @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
591
592  my($ftp,$from,$to) = @_;
593
594  $ftp->_RNFR($from)
595     && $ftp->_RNTO($to);
596 }
597
598 sub type
599 {
600  my $ftp = shift;
601  my $type = shift;
602  my $oldval = ${*$ftp}{'net_ftp_type'};
603
604  return $oldval
605         unless (defined $type);
606
607  return undef
608         unless ($ftp->_TYPE($type,@_));
609
610  ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
611
612  $oldval;
613 }
614
615 sub abort
616 {
617  my $ftp = shift;
618
619  send($ftp,pack("CC",TELNET_IAC,TELNET_IP),0);
620  send($ftp,pack("C", TELNET_IAC),MSG_OOB);
621  send($ftp,pack("C", TELNET_DM),0);
622
623  $ftp->command("ABOR");
624
625  defined ${*$ftp}{'net_ftp_dataconn'}
626     ? ${*$ftp}{'net_ftp_dataconn'}->close()
627     : $ftp->response();
628
629  $ftp->response()
630     if $ftp->status == CMD_REJECT;
631
632  $ftp->status == CMD_OK;
633 }
634
635 sub get
636 {
637  my($ftp,$remote,$local,$where) = @_;
638
639  my($loc,$len,$buf,$resp,$localfd,$data);
640  local *FD;
641
642  $localfd = ref($local) ? fileno($local)
643                         : undef;
644
645  ($local = $remote) =~ s#^.*/##
646         unless(defined $local);
647
648  ${*$ftp}{'net_ftp_rest'} = $where
649         if ($where);
650
651  delete ${*$ftp}{'net_ftp_port'};
652  delete ${*$ftp}{'net_ftp_pasv'};
653
654  $data = $ftp->retr($remote) or
655         return undef;
656
657  if(defined $localfd)
658   {
659    $loc = $local;
660   }
661  else
662   {
663    $loc = \*FD;
664
665    unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
666     {
667      carp "Cannot open Local file $local: $!\n";
668      $data->abort;
669      return undef;
670     }
671   }
672   if ($ftp->binary && !binmode($loc))
673    {
674     carp "Cannot binmode Local file $local: $!\n";
675     return undef;
676    }
677
678  $buf = '';
679
680  do
681   {
682    $len = $data->read($buf,1024);
683   }
684  while($len > 0 && syswrite($loc,$buf,$len) == $len);
685
686  close($loc)
687         unless defined $localfd;
688  
689  $data->close(); # implied $ftp->response
690
691  return $local;
692 }
693
694 sub cwd
695 {
696  @_ == 2 || @_ == 3 or croak 'usage: $ftp->cwd( [ DIR ] )';
697
698  my($ftp,$dir) = @_;
699
700  $dir ||= "/";
701
702  $dir eq ".."
703     ? $ftp->_CDUP()
704     : $ftp->_CWD($dir);
705 }
706
707 sub cdup
708 {
709  @_ == 1 or croak 'usage: $ftp->cdup()';
710  $_[0]->_CDUP;
711 }
712
713 sub pwd
714 {
715  @_ == 1 || croak 'usage: $ftp->pwd()';
716  my $ftp = shift;
717
718  $ftp->_PWD();
719  $ftp->_extract_path;
720 }
721
722 sub rmdir
723 {
724  @_ == 2 || croak 'usage: $ftp->rmdir( DIR )';
725
726  $_[0]->_RMD($_[1]);
727 }
728
729 sub mkdir
730 {
731  @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
732
733  my($ftp,$dir,$recurse) = @_;
734
735  $ftp->_MKD($dir) || $recurse or
736     return undef;
737
738  my $path = undef;
739  unless($ftp->ok)
740   {
741    my @path = split(m#(?=/+)#, $dir);
742
743    $path = "";
744
745    while(@path)
746     {
747      $path .= shift @path;
748
749      $ftp->_MKD($path);
750      $path = $ftp->_extract_path($path);
751
752      # 521 means directory already exists
753      last
754         unless $ftp->ok || $ftp->code == 521;
755     }
756   }
757
758  $ftp->_extract_path($path);
759 }
760
761 sub delete
762 {
763  @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
764
765  $_[0]->_DELE($_[1]);
766 }
767
768 sub put        { shift->_store_cmd("stor",@_) }
769 sub put_unique { shift->_store_cmd("stou",@_) }
770 sub append     { shift->_store_cmd("appe",@_) }
771
772 sub nlst { shift->_data_cmd("NLST",@_) }
773 sub list { shift->_data_cmd("LIST",@_) }
774 sub retr { shift->_data_cmd("RETR",@_) }
775 sub stor { shift->_data_cmd("STOR",@_) }
776 sub stou { shift->_data_cmd("STOU",@_) }
777 sub appe { shift->_data_cmd("APPE",@_) }
778
779 sub _store_cmd 
780 {
781  my($ftp,$cmd,$local,$remote) = @_;
782  my($loc,$sock,$len,$buf,$localfd);
783  local *FD;
784
785  $localfd = ref($local) ? fileno($local)
786                         : undef;
787
788  unless(defined $remote)
789   {
790    croak 'Must specify remote filename with stream input'
791         if defined $localfd;
792
793    ($remote = $local) =~ s%.*/%%;
794   }
795
796  if(defined $localfd)
797   {
798    $loc = $local;
799   }
800  else
801   {
802    $loc = \*FD;
803
804    unless(open($loc,"<$local"))
805     {
806      carp "Cannot open Local file $local: $!\n";
807      return undef;
808     }
809    if ($ftp->binary && !binmode($loc))
810     {
811      carp "Cannot binmode Local file $local: $!\n";
812      return undef;
813     }
814   }
815
816  delete ${*$ftp}{'net_ftp_port'};
817  delete ${*$ftp}{'net_ftp_pasv'};
818
819  $sock = $ftp->_data_cmd($cmd, $remote) or 
820         return undef;
821
822  do
823   {
824    $len = sysread($loc,$buf="",1024);
825   }
826  while($len && $sock->write($buf,$len) == $len);
827
828  close($loc)
829         unless defined $localfd;
830
831  $sock->close();
832
833  ($remote) = $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
834         if ('STOU' eq uc $cmd);
835
836  return $remote;
837 }
838
839 sub port
840 {
841  @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
842
843  my($ftp,$port) = @_;
844  my $ok;
845
846  delete ${*$ftp}{'net_ftp_intern_port'};
847
848  unless(defined $port)
849   {
850    # create a Listen socket at same address as the command socket
851
852    ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen    => 5,
853                                                         Proto     => 'tcp',
854                                                         LocalAddr => $ftp->sockhost, 
855                                                        );
856   
857    my $listen = ${*$ftp}{'net_ftp_listen'};
858
859    my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
860
861    $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
862
863    ${*$ftp}{'net_ftp_intern_port'} = 1;
864   }
865
866  $ok = $ftp->_PORT($port);
867
868  ${*$ftp}{'net_ftp_port'} = $port;
869
870  $ok;
871 }
872
873 sub ls  { shift->_list_cmd("NLST",@_); }
874 sub dir { shift->_list_cmd("LIST",@_); }
875
876 sub pasv
877 {
878  @_ == 1 or croak 'usage: $ftp->pasv()';
879
880  my $ftp = shift;
881
882  delete ${*$ftp}{'net_ftp_intern_port'};
883
884  $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
885     ? ${*$ftp}{'net_ftp_pasv'} = $1
886     : undef;    
887 }
888
889 sub unique_name
890 {
891  my $ftp = shift;
892  ${*$ftp}{'net_ftp_unique'} || undef;
893 }
894
895 ##
896 ## Depreciated methods
897 ##
898
899 sub lsl
900 {
901  carp "Use of Net::FTP::lsl depreciated, use 'dir'"
902     if $^W;
903  goto &dir;
904 }
905
906 sub authorise
907 {
908  carp "Use of Net::FTP::authorise depreciated, use 'authorize'"
909     if $^W;
910  goto &authorize;
911 }
912
913
914 ##
915 ## Private methods
916 ##
917
918 sub _extract_path
919 {
920  my($ftp, $path) = @_;
921
922  $ftp->ok &&
923     $ftp->message =~ /\s\"(.*)\"\s/o &&
924     ($path = $1) =~ s/\"\"/\"/g;
925
926  $path;
927 }
928
929 ##
930 ## Communication methods
931 ##
932
933 sub _dataconn
934 {
935  my $ftp = shift;
936  my $data = undef;
937  my $pkg = "Net::FTP::" . $ftp->type;
938
939  $pkg =~ s/ /_/g;
940
941  delete ${*$ftp}{'net_ftp_dataconn'};
942
943  if(defined ${*$ftp}{'net_ftp_pasv'})
944   {
945    my @port = split(/,/,${*$ftp}{'net_ftp_pasv'});
946
947    $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
948                      PeerPort => $port[4] * 256 + $port[5],
949                      Proto    => 'tcp'
950                     );
951   }
952  elsif(defined ${*$ftp}{'net_ftp_listen'})
953   {
954    $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
955    close(delete ${*$ftp}{'net_ftp_listen'});
956   }
957
958  if($data)
959   {
960    ${*$data} = "";
961    $data->timeout($ftp->timeout);
962    ${*$ftp}{'net_ftp_dataconn'} = $data;
963    ${*$data}{'net_ftp_cmd'} = $ftp;
964   }
965
966  $data;
967 }
968
969 sub _list_cmd
970 {
971  my $ftp = shift;
972  my $cmd = uc shift;
973
974  delete ${*$ftp}{'net_ftp_port'};
975  delete ${*$ftp}{'net_ftp_pasv'};
976
977  my $data = $ftp->_data_cmd($cmd,@_);
978
979  return undef
980         unless(defined $data);
981
982  bless $data, "Net::FTP::A"; # Force ASCII mode
983
984  my $databuf = '';
985  my $buf = '';
986
987  while($data->read($databuf,1024))
988   {
989    $buf .= $databuf;
990   }
991
992  my $list = [ split(/\n/,$buf) ];
993
994  $data->close();
995
996  wantarray ? @{$list}
997            : $list;
998 }
999
1000 sub _data_cmd
1001 {
1002  my $ftp = shift;
1003  my $cmd = uc shift;
1004  my $ok = 1;
1005  my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
1006
1007  if(${*$ftp}{'net_ftp_passive'} &&
1008      !defined ${*$ftp}{'net_ftp_pasv'} &&
1009      !defined ${*$ftp}{'net_ftp_port'})
1010   {
1011    my $data = undef;
1012
1013    $ok = defined $ftp->pasv;
1014    $ok = $ftp->_REST($where)
1015         if $ok && $where;
1016
1017    if($ok)
1018     {
1019      $ftp->command($cmd,@_);
1020      $data = $ftp->_dataconn();
1021      $ok = CMD_INFO == $ftp->response();
1022     }
1023    return $ok ? $data
1024               : undef;
1025   }
1026
1027  $ok = $ftp->port
1028     unless (defined ${*$ftp}{'net_ftp_port'} ||
1029             defined ${*$ftp}{'net_ftp_pasv'});
1030
1031  $ok = $ftp->_REST($where)
1032     if $ok && $where;
1033
1034  return undef
1035     unless $ok;
1036
1037  $ftp->command($cmd,@_);
1038
1039  return 1
1040     if(defined ${*$ftp}{'net_ftp_pasv'});
1041
1042  $ok = CMD_INFO == $ftp->response();
1043
1044  return $ok 
1045     unless exists ${*$ftp}{'net_ftp_intern_port'};
1046
1047  $ok ? $ftp->_dataconn()
1048      : undef;
1049 }
1050
1051 ##
1052 ## Over-ride methods (Net::Cmd)
1053 ##
1054
1055 sub debug_text { $_[2] =~ /^(pass|resp)/i ? "$1 ....\n" : $_[2]; }
1056
1057 sub command
1058 {
1059  my $ftp = shift;
1060
1061  delete ${*$ftp}{'net_ftp_port'};
1062  $ftp->SUPER::command(@_);
1063 }
1064
1065 sub response
1066 {
1067  my $ftp = shift;
1068  my $code = $ftp->SUPER::response();
1069
1070  delete ${*$ftp}{'net_ftp_pasv'}
1071     if ($code != CMD_MORE && $code != CMD_INFO);
1072
1073  $code;
1074 }
1075
1076 ##
1077 ## Allow 2 servers to talk directly
1078 ##
1079
1080 sub pasv_xfer
1081 {
1082  my($sftp,$sfile,$dftp,$dfile) = @_;
1083
1084  ($dfile = $sfile) =~ s#.*/##
1085     unless(defined $dfile);
1086
1087  my $port = $sftp->pasv or
1088     return undef;
1089
1090  unless($dftp->port($port) && $sftp->retr($sfile) && $dftp->stou($dfile))
1091   {
1092    $sftp->abort;
1093    $dftp->abort;
1094    return undef;
1095   }
1096
1097  $dftp->pasv_wait($sftp);
1098 }
1099
1100 sub pasv_wait
1101 {
1102  @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
1103
1104  my($ftp, $non_pasv) = @_;
1105  my($file,$rin,$rout);
1106
1107  vec($rin,fileno($ftp),1) = 1;
1108  select($rout=$rin, undef, undef, undef);
1109
1110  $ftp->response();
1111  $non_pasv->response();
1112
1113  return undef
1114         unless $ftp->ok() && $non_pasv->ok();
1115
1116  return $1
1117         if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
1118
1119  return $1
1120         if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
1121
1122  return 1;
1123 }
1124
1125 sub cmd { shift->command(@_)->responce() }
1126
1127 ########################################
1128 #
1129 # RFC959 commands
1130 #
1131
1132 sub _ABOR { shift->command("ABOR")->response()   == CMD_OK }
1133 sub _CDUP { shift->command("CDUP")->response()   == CMD_OK }
1134 sub _NOOP { shift->command("NOOP")->response()   == CMD_OK }
1135 sub _PASV { shift->command("PASV")->response()   == CMD_OK }
1136 sub _QUIT { shift->command("QUIT")->response()   == CMD_OK }
1137 sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
1138 sub _CWD  { shift->command("CWD", @_)->response() == CMD_OK }
1139 sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
1140 sub _RMD  { shift->command("RMD", @_)->response() == CMD_OK }
1141 sub _MKD  { shift->command("MKD", @_)->response() == CMD_OK }
1142 sub _PWD  { shift->command("PWD", @_)->response() == CMD_OK }
1143 sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
1144 sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
1145 sub _ACCT { shift->command("ACCT",@_)->response() == CMD_OK }
1146 sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
1147 sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
1148 sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
1149 sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
1150 sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
1151 sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
1152 sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
1153 sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
1154 sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
1155 sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
1156 sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
1157 sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
1158 sub _PASS { shift->command("PASS",@_)->response() }
1159 sub _AUTH { shift->command("AUTH",@_)->response() }
1160
1161 sub _ALLO { shift->unsupported(@_) }
1162 sub _SMNT { shift->unsupported(@_) }
1163 sub _HELP { shift->unsupported(@_) }
1164 sub _MODE { shift->unsupported(@_) }
1165 sub _SITE { shift->unsupported(@_) }
1166 sub _SYST { shift->unsupported(@_) }
1167 sub _STAT { shift->unsupported(@_) }
1168 sub _STRU { shift->unsupported(@_) }
1169 sub _REIN { shift->unsupported(@_) }
1170
1171 ##
1172 ## Generic data connection package
1173 ##
1174
1175 package Net::FTP::dataconn;
1176
1177 use Carp;
1178 use vars qw(@ISA $timeout);
1179 use Net::Cmd;
1180
1181 @ISA = qw(IO::Socket::INET);
1182
1183 sub abort
1184 {
1185  my $data = shift;
1186  my $ftp  = ${*$data}{'net_ftp_cmd'};
1187
1188  $ftp->abort; # this will close me
1189 }
1190
1191 sub close
1192 {
1193  my $data = shift;
1194  my $ftp  = ${*$data}{'net_ftp_cmd'};
1195
1196  $data->SUPER::close();
1197
1198  delete ${*$ftp}{'net_ftp_dataconn'}
1199     if exists ${*$ftp}{'net_ftp_dataconn'} &&
1200         $data == ${*$ftp}{'net_ftp_dataconn'};
1201
1202  $ftp->response() == CMD_OK &&
1203     $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
1204     (${*$ftp}{'net_ftp_unique'} = $1);
1205
1206  $ftp->status == CMD_OK;
1207 }
1208
1209 sub _select
1210 {
1211  my    $data    = shift;
1212  local *timeout = \$_[0]; shift;
1213  my    $rw      = shift;
1214
1215  my($rin,$win);
1216
1217  return 1 unless $timeout;
1218
1219  $rin = '';
1220  vec($rin,fileno($data),1) = 1;
1221
1222  $win = $rw ? undef : $rin;
1223  $rin = undef unless $rw;
1224
1225  my $nfound = select($rin, $win, undef, $timeout);
1226
1227  croak "select: $!"
1228         if $nfound < 0;
1229
1230  return $nfound;
1231 }
1232
1233 sub can_read
1234 {
1235  my    $data    = shift;
1236  local *timeout = \$_[0];
1237
1238  $data->_select($timeout,1);
1239 }
1240
1241 sub can_write
1242 {
1243  my    $data    = shift;
1244  local *timeout = \$_[0];
1245
1246  $data->_select($timeout,0);
1247 }
1248
1249 sub cmd
1250 {
1251  my $ftp = shift;
1252
1253  ${*$ftp}{'net_ftp_cmd'};
1254 }
1255
1256
1257 @Net::FTP::L::ISA = qw(Net::FTP::I);
1258 @Net::FTP::E::ISA = qw(Net::FTP::I);
1259
1260 ##
1261 ## Package to read/write on ASCII data connections
1262 ##
1263
1264 package Net::FTP::A;
1265
1266 use vars qw(@ISA $buf);
1267 use Carp;
1268
1269 @ISA = qw(Net::FTP::dataconn);
1270
1271 sub read
1272 {
1273  my    $data    = shift;
1274  local *buf     = \$_[0]; shift;
1275  my    $size    = shift || croak 'read($buf,$size,[$offset])';
1276  my    $offset  = shift || 0;
1277  my    $timeout = $data->timeout;
1278
1279  croak "Bad offset"
1280         if($offset < 0);
1281
1282  $offset = length $buf
1283         if($offset > length $buf);
1284
1285  ${*$data} ||= "";
1286  my $l = 0;
1287
1288  READ:
1289   {
1290    $data->can_read($timeout) or
1291         croak "Timeout";
1292
1293    my $n = sysread($data, ${*$data}, $size, length ${*$data});
1294
1295    return $n
1296         unless($n >= 0);
1297
1298    ${*$data} =~ s/(\015)?(?!\012)\Z//so;
1299    my $lf = $1 || "";
1300
1301    ${*$data} =~ s/\015\012/\n/sgo;
1302
1303    substr($buf,$offset) = ${*$data};
1304
1305    $l += length(${*$data});
1306    $offset += length(${*$data});
1307
1308    ${*$data} = $lf;
1309    
1310    redo READ
1311      if($l == 0 && $n > 0);
1312
1313    if($n == 0 && $l == 0)
1314     {
1315      substr($buf,$offset) = ${*$data};
1316      ${*$data} = "";
1317     }
1318   }
1319
1320  return $l;
1321 }
1322
1323 sub write
1324 {
1325  my    $data    = shift;
1326  local *buf     = \$_[0]; shift;
1327  my    $size    = shift || croak 'write($buf,$size,[$timeout])';
1328  my    $timeout = @_ ? shift : $data->timeout;
1329
1330  $data->can_write($timeout) or
1331         croak "Timeout";
1332
1333  # What is previous pkt ended in \015 or not ??
1334
1335  my $tmp;
1336  ($tmp = $buf) =~ s/(?!\015)\012/\015\012/sg;
1337
1338  my $len = $size + length($tmp) - length($buf);
1339  my $wrote = syswrite($data, $tmp, $len);
1340
1341  if($wrote >= 0)
1342   {
1343    $wrote = $wrote == $len ? $size
1344                            : $len - $wrote
1345   }
1346
1347  return $wrote;
1348 }
1349
1350 ##
1351 ## Package to read/write on BINARY data connections
1352 ##
1353
1354 package Net::FTP::I;
1355
1356 use vars qw(@ISA $buf);
1357 use Carp;
1358
1359 @ISA = qw(Net::FTP::dataconn);
1360
1361 sub read
1362 {
1363  my    $data    = shift;
1364  local *buf     = \$_[0]; shift;
1365  my    $size    = shift || croak 'read($buf,$size,[$timeout])';
1366  my    $timeout = @_ ? shift : $data->timeout;
1367
1368  $data->can_read($timeout) or
1369         croak "Timeout";
1370
1371  my $n = sysread($data, $buf, $size);
1372
1373  $n;
1374 }
1375
1376 sub write
1377 {
1378  my    $data    = shift;
1379  local *buf     = \$_[0]; shift;
1380  my    $size    = shift || croak 'write($buf,$size,[$timeout])';
1381  my    $timeout = @_ ? shift : $data->timeout;
1382
1383  $data->can_write($timeout) or
1384         croak "Timeout";
1385
1386  syswrite($data, $buf, $size);
1387 }
1388
1389
1390 1;
1391