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