home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / lib / perl5 / site_perl / 5.005 / i386-linux / Net / FTP.pm < prev    next >
Encoding:
Perl POD Document  |  2000-01-12  |  18.1 KB  |  969 lines
  1. # Net::FTP.pm
  2. #
  3. # Copyright (c) 1995-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6. #
  7. # Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
  8.  
  9. package Net::FTP;
  10.  
  11. require 5.001;
  12.  
  13. use strict;
  14. use vars qw(@ISA $VERSION);
  15. use Carp;
  16.  
  17. use Socket 1.3;
  18. use IO::Socket;
  19. use Time::Local;
  20. use Net::Cmd;
  21. use Net::Config;
  22. # use AutoLoader qw(AUTOLOAD);
  23.  
  24. $VERSION = "2.40"; # $Id: //depot/libnet/Net/FTP.pm#25$
  25. @ISA     = qw(Exporter Net::Cmd IO::Socket::INET);
  26.  
  27. # Someday I will "use constant", when I am not bothered to much about
  28. # compatability with older releases of perl
  29.  
  30. use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
  31. ($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);
  32.  
  33. # Name is too long for AutoLoad, it clashes with pasv_xfer
  34. sub pasv_xfer_unique {
  35.     my($sftp,$sfile,$dftp,$dfile) = @_;
  36.     $sftp->pasv_xfer($sfile,$dftp,$dfile,1);
  37. }
  38.  
  39. 1;
  40. # Having problems with AutoLoader
  41. #__END__
  42.  
  43. sub new
  44. {
  45.  my $pkg  = shift;
  46.  my $peer = shift;
  47.  my %arg  = @_; 
  48.  
  49.  my $host = $peer;
  50.  my $fire = undef;
  51.  
  52.  # Should I use Net::Ping here ?? --GMB
  53.  if(exists($arg{Firewall}) || !defined(inet_aton($peer)))
  54.   {
  55.    $fire = $arg{Firewall}
  56.     || $ENV{FTP_FIREWALL}
  57.     || $NetConfig{ftp_firewall}
  58.     || undef;
  59.  
  60.    if(defined $fire)
  61.     {
  62.      $peer = $fire;
  63.      delete $arg{Port};
  64.     }
  65.   }
  66.  
  67.  my $ftp = $pkg->SUPER::new(PeerAddr => $peer, 
  68.                 PeerPort => $arg{Port} || 'ftp(21)',
  69.                 Proto    => 'tcp',
  70.                 Timeout  => defined $arg{Timeout}
  71.                         ? $arg{Timeout}
  72.                         : 120
  73.                ) or return undef;
  74.  
  75.  ${*$ftp}{'net_ftp_host'}     = $host;        # Remote hostname
  76.  ${*$ftp}{'net_ftp_type'}     = 'A';        # ASCII/binary/etc mode
  77.  
  78.  ${*$ftp}{'net_ftp_firewall'} = $fire
  79.     if(defined $fire);
  80.  
  81.  ${*$ftp}{'net_ftp_passive'} = int
  82.     exists $arg{Passive}
  83.         ? $arg{Passive}
  84.         : exists $ENV{FTP_PASSIVE}
  85.         ? $ENV{FTP_PASSIVE}
  86.         : defined $fire
  87.             ? $NetConfig{ftp_ext_passive}
  88.             : $NetConfig{ftp_int_passive};    # Whew! :-)
  89.  
  90.  $ftp->autoflush(1);
  91.  
  92.  $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
  93.  
  94.  unless ($ftp->response() == CMD_OK)
  95.   {
  96.    $ftp->close();
  97.    $@ = $ftp->message;
  98.    undef $ftp;
  99.   }
  100.  
  101.  $ftp;
  102. }
  103.  
  104. ##
  105. ## User interface methods
  106. ##
  107.  
  108. sub quit
  109. {
  110.  my $ftp = shift;
  111.  
  112.  $ftp->_QUIT;
  113.  $ftp->close;
  114. }
  115.  
  116. sub DESTROY
  117. {
  118.  my $ftp = shift;
  119.  defined(fileno($ftp)) && $ftp->quit
  120. }
  121.  
  122. sub ascii  { shift->type('A',@_); }
  123. sub binary { shift->type('I',@_); }
  124.  
  125. sub ebcdic
  126. {
  127.  carp "TYPE E is unsupported, shall default to I";
  128.  shift->type('E',@_);
  129. }
  130.  
  131. sub byte
  132. {
  133.  carp "TYPE L is unsupported, shall default to I";
  134.  shift->type('L',@_);
  135. }
  136.  
  137. # Allow the user to send a command directly, BE CAREFUL !!
  138.  
  139. sub quot
  140. { 
  141.  my $ftp = shift;
  142.  my $cmd = shift;
  143.  
  144.  $ftp->command( uc $cmd, @_);
  145.  $ftp->response();
  146. }
  147.  
  148. sub site
  149. {
  150.  my $ftp = shift;
  151.  
  152.  $ftp->command("SITE", @_);
  153.  $ftp->response();
  154. }
  155.  
  156. sub mdtm
  157. {
  158.  my $ftp  = shift;
  159.  my $file = shift;
  160.  
  161.  $ftp->_MDTM($file) && $ftp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
  162.     ? timegm($6,$5,$4,$3,$2-1,$1 - 1900)
  163.     : undef;
  164. }
  165.  
  166. sub size
  167. {
  168.  my $ftp  = shift;
  169.  my $file = shift;
  170.  my $io;
  171.  if($ftp->supported("SIZE")) {
  172.     return $ftp->_SIZE($file)
  173.         ? ($ftp->message =~ /(\d+)/)[0]
  174.         : undef;
  175.  }
  176.  elsif($ftp->supported("STAT")) {
  177.     my @msg;
  178.     return undef
  179.         unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
  180.     my $line;
  181.     foreach $line (@msg) {
  182.         return (split(/\s+/,$line))[4]
  183.         if $line =~ /^[-rw]{10}/
  184.     }
  185.  }
  186.  elsif($io = $ftp->list($file)) {
  187.     my $line;
  188.     $io->read($line,1024);
  189.     $io->close;
  190.     return (split(/\s+/,$1))[4]
  191.         if $line =~ /^([-rw]{10}.*)\n/s;
  192.  }
  193.  undef;
  194. }
  195.  
  196. sub login
  197. {
  198.  my($ftp,$user,$pass,$acct) = @_;
  199.  my($ok,$ruser);
  200.  
  201.  unless (defined $user)
  202.   {
  203.    require Net::Netrc;
  204.  
  205.    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
  206.  
  207.    ($user,$pass,$acct) = $rc->lpa()
  208.     if ($rc);
  209.   }
  210.  
  211.  $user ||= "anonymous";
  212.  $ruser = $user;
  213.  
  214.  if(defined ${*$ftp}{'net_ftp_firewall'})
  215.   {
  216.    $user .= "@" . ${*$ftp}{'net_ftp_host'};
  217.   }
  218.  
  219.  $ok = $ftp->_USER($user);
  220.  
  221.  # Some dumb firewalls don't prefix the connection messages
  222.  $ok = $ftp->response()
  223.     if($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
  224.  
  225.  if ($ok == CMD_MORE)
  226.   {
  227.    unless(defined $pass)
  228.     {
  229.      require Net::Netrc;
  230.  
  231.      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
  232.  
  233.      ($ruser,$pass,$acct) = $rc->lpa()
  234.     if ($rc);
  235.  
  236.      $pass = "-" . (eval { (getpwuid($>))[0] } || $ENV{NAME} ) . '@'
  237.         if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
  238.     }
  239.  
  240.    $ok = $ftp->_PASS($pass || "");
  241.   }
  242.  
  243.  $ok = $ftp->_ACCT($acct || "")
  244.     if ($ok == CMD_MORE);
  245.  
  246.  $ftp->authorize()
  247.     if($ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'});
  248.  
  249.  $ok == CMD_OK;
  250. }
  251.  
  252. sub account
  253. {
  254.  @_ == 2 or croak 'usage: $ftp->account( ACCT )';
  255.  my $ftp = shift;
  256.  my $acct = shift;
  257.  $ftp->_ACCT($acct) == CMD_OK;
  258. }
  259.  
  260. sub authorize
  261. {
  262.  @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
  263.  
  264.  my($ftp,$auth,$resp) = @_;
  265.  
  266.  unless(defined $resp)
  267.   {
  268.    require Net::Netrc;
  269.  
  270.    $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
  271.  
  272.    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
  273.         || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
  274.  
  275.    ($auth,$resp) = $rc->lpa()
  276.      if($rc);
  277.   }
  278.  
  279.  my $ok = $ftp->_AUTH($auth || "");
  280.  
  281.  $ok = $ftp->_RESP($resp || "")
  282.     if ($ok == CMD_MORE);
  283.  
  284.  $ok == CMD_OK;
  285. }
  286.  
  287. sub rename
  288. {
  289.  @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
  290.  
  291.  my($ftp,$from,$to) = @_;
  292.  
  293.  $ftp->_RNFR($from)
  294.     && $ftp->_RNTO($to);
  295. }
  296.  
  297. sub type
  298. {
  299.  my $ftp = shift;
  300.  my $type = shift;
  301.  my $oldval = ${*$ftp}{'net_ftp_type'};
  302.  
  303.  return $oldval
  304.     unless (defined $type);
  305.  
  306.  return undef
  307.     unless ($ftp->_TYPE($type,@_));
  308.  
  309.  ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
  310.  
  311.  $oldval;
  312. }
  313.  
  314. sub abort
  315. {
  316.  my $ftp = shift;
  317.  
  318.  send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);
  319.  
  320.  $ftp->command(pack("C",$TELNET_DM) . "ABOR");
  321.  
  322.  ${*$ftp}{'net_ftp_dataconn'}->close()
  323.     if defined ${*$ftp}{'net_ftp_dataconn'};
  324.  
  325.  $ftp->response();
  326.  
  327.  $ftp->status == CMD_OK;
  328. }
  329.  
  330. sub get
  331. {
  332.  my($ftp,$remote,$local,$where) = @_;
  333.  
  334.  my($loc,$len,$buf,$resp,$localfd,$data);
  335.  local *FD;
  336.  
  337.  $localfd = ref($local) ? fileno($local)
  338.             : undef;
  339.  
  340.  ($local = $remote) =~ s#^.*/##
  341.     unless(defined $local);
  342.  
  343.  croak("Bad remote filename '$remote'\n")
  344.     if $remote =~ /[\s\r\n]/s;
  345.  
  346.  ${*$ftp}{'net_ftp_rest'} = $where
  347.     if ($where);
  348.  
  349.  delete ${*$ftp}{'net_ftp_port'};
  350.  delete ${*$ftp}{'net_ftp_pasv'};
  351.  
  352.  $data = $ftp->retr($remote) or
  353.     return undef;
  354.  
  355.  if(defined $localfd)
  356.   {
  357.    $loc = $local;
  358.   }
  359.  else
  360.   {
  361.    $loc = \*FD;
  362.  
  363.    unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
  364.     {
  365.      carp "Cannot open Local file $local: $!\n";
  366.      $data->abort;
  367.      return undef;
  368.     }
  369.   }
  370.  
  371.  if($ftp->type eq 'I' && !binmode($loc))
  372.   {
  373.    carp "Cannot binmode Local file $local: $!\n";
  374.    $data->abort;
  375.    return undef;
  376.   }
  377.  
  378.  $buf = '';
  379.  my $swlen;
  380.  
  381.  do
  382.   {
  383.    $len = $data->read($buf,1024);
  384.   }
  385.  while($len && defined($swlen = syswrite($loc,$buf,$len)) && $swlen == $len);
  386.  
  387.  close($loc)
  388.     unless defined $localfd;
  389.  
  390.  $data->close(); # implied $ftp->response
  391.  
  392.  return $local;
  393. }
  394.  
  395. sub cwd
  396. {
  397.  @_ == 2 || @_ == 3 or croak 'usage: $ftp->cwd( [ DIR ] )';
  398.  
  399.  my($ftp,$dir) = @_;
  400.  
  401.  $dir ||= "/";
  402.  
  403.  $dir eq ".."
  404.     ? $ftp->_CDUP()
  405.     : $ftp->_CWD($dir);
  406. }
  407.  
  408. sub cdup
  409. {
  410.  @_ == 1 or croak 'usage: $ftp->cdup()';
  411.  $_[0]->_CDUP;
  412. }
  413.  
  414. sub pwd
  415. {
  416.  @_ == 1 || croak 'usage: $ftp->pwd()';
  417.  my $ftp = shift;
  418.  
  419.  $ftp->_PWD();
  420.  $ftp->_extract_path;
  421. }
  422.  
  423. sub rmdir
  424. {
  425.  @_ == 2 || croak 'usage: $ftp->rmdir( DIR )';
  426.  
  427.  $_[0]->_RMD($_[1]);
  428. }
  429.  
  430. sub mkdir
  431. {
  432.  @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
  433.  
  434.  my($ftp,$dir,$recurse) = @_;
  435.  
  436.  $ftp->_MKD($dir) || $recurse or
  437.     return undef;
  438.  
  439.  my $path = $dir;
  440.  
  441.  unless($ftp->ok)
  442.   {
  443.    my @path = split(m#(?=/+)#, $dir);
  444.  
  445.    $path = "";
  446.  
  447.    while(@path)
  448.     {
  449.      $path .= shift @path;
  450.  
  451.      $ftp->_MKD($path);
  452.  
  453.      $path = $ftp->_extract_path($path);
  454.     }
  455.  
  456.    # If the creation of the last element was not sucessful, see if we
  457.    # can cd to it, if so then return path
  458.  
  459.    unless($ftp->ok)
  460.     {
  461.      my($status,$message) = ($ftp->status,$ftp->message);
  462.      my $pwd = $ftp->pwd;
  463.      
  464.      if($pwd && $ftp->cd($dir))
  465.       {
  466.        $path = $dir;
  467.        $ftp->cd($pwd);
  468.       }
  469.      else
  470.       {
  471.        undef $path;
  472.       }
  473.      $ftp->set_status($status,$message);
  474.     }
  475.   }
  476.  
  477.  $path;
  478. }
  479.  
  480. sub delete
  481. {
  482.  @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
  483.  
  484.  $_[0]->_DELE($_[1]);
  485. }
  486.  
  487. sub put        { shift->_store_cmd("stor",@_) }
  488. sub put_unique { shift->_store_cmd("stou",@_) }
  489. sub append     { shift->_store_cmd("appe",@_) }
  490.  
  491. sub nlst { shift->_data_cmd("NLST",@_) }
  492. sub list { shift->_data_cmd("LIST",@_) }
  493. sub retr { shift->_data_cmd("RETR",@_) }
  494. sub stor { shift->_data_cmd("STOR",@_) }
  495. sub stou { shift->_data_cmd("STOU",@_) }
  496. sub appe { shift->_data_cmd("APPE",@_) }
  497.  
  498. sub _store_cmd 
  499. {
  500.  my($ftp,$cmd,$local,$remote) = @_;
  501.  my($loc,$sock,$len,$buf,$localfd);
  502.  local *FD;
  503.  
  504.  $localfd = ref($local) ? fileno($local)
  505.             : undef;
  506.  
  507.  unless(defined $remote)
  508.   {
  509.    croak 'Must specify remote filename with stream input'
  510.     if defined $localfd;
  511.  
  512.    require File::Basename;
  513.    $remote = File::Basename::basename($local);
  514.   }
  515.  
  516.  croak("Bad remote filename '$remote'\n")
  517.     if $remote =~ /[\s\r\n]/s;
  518.  
  519.  if(defined $localfd)
  520.   {
  521.    $loc = $local;
  522.   }
  523.  else
  524.   {
  525.    $loc = \*FD;
  526.  
  527.    unless(open($loc,"<$local"))
  528.     {
  529.      carp "Cannot open Local file $local: $!\n";
  530.      return undef;
  531.     }
  532.   }
  533.  
  534.  if($ftp->type eq 'I' && !binmode($loc))
  535.   {
  536.    carp "Cannot binmode Local file $local: $!\n";
  537.    return undef;
  538.   }
  539.  
  540.  delete ${*$ftp}{'net_ftp_port'};
  541.  delete ${*$ftp}{'net_ftp_pasv'};
  542.  
  543.  $sock = $ftp->_data_cmd($cmd, $remote) or 
  544.     return undef;
  545.  
  546.  while(1)
  547.   {
  548.    last unless $len = sysread($loc,$buf="",1024);
  549.  
  550.    my $wlen;
  551.    unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len)
  552.     {
  553.      $sock->abort;
  554.      close($loc)
  555.     unless defined $localfd;
  556.      return undef;
  557.     }
  558.   }
  559.  
  560.  $sock->close();
  561.  
  562.  close($loc)
  563.     unless defined $localfd;
  564.  
  565.  ($remote) = $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
  566.     if ('STOU' eq uc $cmd);
  567.  
  568.  return $remote;
  569. }
  570.  
  571. sub port
  572. {
  573.  @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
  574.  
  575.  my($ftp,$port) = @_;
  576.  my $ok;
  577.  
  578.  delete ${*$ftp}{'net_ftp_intern_port'};
  579.  
  580.  unless(defined $port)
  581.   {
  582.    # create a Listen socket at same address as the command socket
  583.  
  584.    ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen    => 5,
  585.                                         Proto     => 'tcp',
  586.                                         LocalAddr => $ftp->sockhost, 
  587.                                        );
  588.   
  589.    my $listen = ${*$ftp}{'net_ftp_listen'};
  590.  
  591.    my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
  592.  
  593.    $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
  594.  
  595.    ${*$ftp}{'net_ftp_intern_port'} = 1;
  596.   }
  597.  
  598.  $ok = $ftp->_PORT($port);
  599.  
  600.  ${*$ftp}{'net_ftp_port'} = $port;
  601.  
  602.  $ok;
  603. }
  604.  
  605. sub ls  { shift->_list_cmd("NLST",@_); }
  606. sub dir { shift->_list_cmd("LIST",@_); }
  607.  
  608. sub pasv
  609. {
  610.  @_ == 1 or croak 'usage: $ftp->pasv()';
  611.  
  612.  my $ftp = shift;
  613.  
  614.  delete ${*$ftp}{'net_ftp_intern_port'};
  615.  
  616.  $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
  617.     ? ${*$ftp}{'net_ftp_pasv'} = $1
  618.     : undef;    
  619. }
  620.  
  621. sub unique_name
  622. {
  623.  my $ftp = shift;
  624.  ${*$ftp}{'net_ftp_unique'} || undef;
  625. }
  626.  
  627. sub supported {
  628.     @_ == 2 or croak 'usage: $ftp->supported( CMD )';
  629.     my $ftp = shift;
  630.     my $cmd = uc shift;
  631.     my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
  632.  
  633.     return $hash->{$cmd}
  634.         if exists $hash->{$cmd};
  635.  
  636.     my $ok = $ftp->_HELP($cmd) &&
  637.         $ftp->message !~ /unimplemented/i;
  638.  
  639.     $hash->{$cmd} = $ok;
  640. }
  641.  
  642. ##
  643. ## Depreciated methods
  644. ##
  645.  
  646. sub lsl
  647. {
  648.  carp "Use of Net::FTP::lsl depreciated, use 'dir'"
  649.     if $^W;
  650.  goto &dir;
  651. }
  652.  
  653. sub authorise
  654. {
  655.  carp "Use of Net::FTP::authorise depreciated, use 'authorize'"
  656.     if $^W;
  657.  goto &authorize;
  658. }
  659.  
  660.  
  661. ##
  662. ## Private methods
  663. ##
  664.  
  665. sub _extract_path
  666. {
  667.  my($ftp, $path) = @_;
  668.  
  669.  # This tries to work both with and without the quote doubling
  670.  # convention (RFC 959 requires it, but the first 3 servers I checked
  671.  # didn't implement it).  It will fail on a server which uses a quote in
  672.  # the message which isn't a part of or surrounding the path.
  673.  $ftp->ok &&
  674.     $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ &&
  675.     ($path = $1) =~ s/\"\"/\"/g;
  676.  
  677.  $path;
  678. }
  679.  
  680. ##
  681. ## Communication methods
  682. ##
  683.  
  684. sub _dataconn
  685. {
  686.  my $ftp = shift;
  687.  my $data = undef;
  688.  my $pkg = "Net::FTP::" . $ftp->type;
  689.  
  690.  eval "require " . $pkg;
  691.  
  692.  $pkg =~ s/ /_/g;
  693.  
  694.  delete ${*$ftp}{'net_ftp_dataconn'};
  695.  
  696.  if(defined ${*$ftp}{'net_ftp_pasv'})
  697.   {
  698.    my @port = split(/,/,${*$ftp}{'net_ftp_pasv'});
  699.  
  700.    $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
  701.                      PeerPort => $port[4] * 256 + $port[5],
  702.                      Proto    => 'tcp'
  703.                     );
  704.   }
  705.  elsif(defined ${*$ftp}{'net_ftp_listen'})
  706.   {
  707.    $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
  708.    close(delete ${*$ftp}{'net_ftp_listen'});
  709.   }
  710.  
  711.  if($data)
  712.   {
  713.    ${*$data} = "";
  714.    $data->timeout($ftp->timeout);
  715.    ${*$ftp}{'net_ftp_dataconn'} = $data;
  716.    ${*$data}{'net_ftp_cmd'} = $ftp;
  717.   }
  718.  
  719.  $data;
  720. }
  721.  
  722. sub _list_cmd
  723. {
  724.  my $ftp = shift;
  725.  my $cmd = uc shift;
  726.  
  727.  delete ${*$ftp}{'net_ftp_port'};
  728.  delete ${*$ftp}{'net_ftp_pasv'};
  729.  
  730.  my $data = $ftp->_data_cmd($cmd,@_);
  731.  
  732.  return undef
  733.     unless(defined $data);
  734.  
  735.  require Net::FTP::A;
  736.  bless $data, "Net::FTP::A"; # Force ASCII mode
  737.  
  738.  my $databuf = '';
  739.  my $buf = '';
  740.  
  741.  while($data->read($databuf,1024))
  742.   {
  743.    $buf .= $databuf;
  744.   }
  745.  
  746.  my $list = [ split(/\n/,$buf) ];
  747.  
  748.  $data->close();
  749.  
  750.  wantarray ? @{$list}
  751.            : $list;
  752. }
  753.  
  754. sub _data_cmd
  755. {
  756.  my $ftp = shift;
  757.  my $cmd = uc shift;
  758.  my $ok = 1;
  759.  my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
  760.  my $arg;
  761.  
  762.  for $arg (@_) {
  763.    croak("Bad argument '$arg'\n")
  764.     if $arg =~ /[\r\n]/s;
  765.  }
  766.  
  767.  if(${*$ftp}{'net_ftp_passive'} &&
  768.      !defined ${*$ftp}{'net_ftp_pasv'} &&
  769.      !defined ${*$ftp}{'net_ftp_port'})
  770.   {
  771.    my $data = undef;
  772.  
  773.    $ok = defined $ftp->pasv;
  774.    $ok = $ftp->_REST($where)
  775.     if $ok && $where;
  776.  
  777.    if($ok)
  778.     {
  779.      $ftp->command($cmd,@_);
  780.      $data = $ftp->_dataconn();
  781.      $ok = CMD_INFO == $ftp->response();
  782.      if($ok) 
  783.       {
  784.        $data->reading
  785.          if $data && $cmd =~ /RETR|LIST|NLST/;
  786.        return $data
  787.       }
  788.      $data->_close
  789.     if $data;
  790.     }
  791.    return undef;
  792.   }
  793.  
  794.  $ok = $ftp->port
  795.     unless (defined ${*$ftp}{'net_ftp_port'} ||
  796.             defined ${*$ftp}{'net_ftp_pasv'});
  797.  
  798.  $ok = $ftp->_REST($where)
  799.     if $ok && $where;
  800.  
  801.  return undef
  802.     unless $ok;
  803.  
  804.  $ftp->command($cmd,@_);
  805.  
  806.  return 1
  807.     if(defined ${*$ftp}{'net_ftp_pasv'});
  808.  
  809.  $ok = CMD_INFO == $ftp->response();
  810.  
  811.  return $ok 
  812.     unless exists ${*$ftp}{'net_ftp_intern_port'};
  813.  
  814.  if($ok) {
  815.    my $data = $ftp->_dataconn();
  816.  
  817.    $data->reading
  818.          if $data && $cmd =~ /RETR|LIST|NLST/;
  819.  
  820.    return $data;
  821.  }
  822.  
  823.  
  824.  close(delete ${*$ftp}{'net_ftp_listen'});
  825.  
  826.  return undef;
  827. }
  828.  
  829. ##
  830. ## Over-ride methods (Net::Cmd)
  831. ##
  832.  
  833. sub debug_text { $_[2] =~ /^(pass|resp)/i ? "$1 ....\n" : $_[2]; }
  834.  
  835. sub command
  836. {
  837.  my $ftp = shift;
  838.  
  839.  delete ${*$ftp}{'net_ftp_port'};
  840.  $ftp->SUPER::command(@_);
  841. }
  842.  
  843. sub response
  844. {
  845.  my $ftp = shift;
  846.  my $code = $ftp->SUPER::response();
  847.  
  848.  delete ${*$ftp}{'net_ftp_pasv'}
  849.     if ($code != CMD_MORE && $code != CMD_INFO);
  850.  
  851.  $code;
  852. }
  853.  
  854. sub parse_response
  855. {
  856.  return ($1, $2 eq "-")
  857.     if $_[1] =~ s/^(\d\d\d)(.?)//o;
  858.  
  859.  my $ftp = shift;
  860.  
  861.  # Darn MS FTP server is a load of CRAP !!!!
  862.  return ()
  863.     unless ${*$ftp}{'net_cmd_code'} + 0;
  864.  
  865.  (${*$ftp}{'net_cmd_code'},1);
  866. }
  867.  
  868. ##
  869. ## Allow 2 servers to talk directly
  870. ##
  871.  
  872. sub pasv_xfer {
  873.     my($sftp,$sfile,$dftp,$dfile,$unique) = @_;
  874.  
  875.     ($dfile = $sfile) =~ s#.*/##
  876.     unless(defined $dfile);
  877.  
  878.     my $port = $sftp->pasv or
  879.     return undef;
  880.  
  881.     $dftp->port($port) or
  882.     return undef;
  883.  
  884.     return undef
  885.     unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
  886.  
  887.     unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
  888.     $sftp->retr($sfile);
  889.     $dftp->abort;
  890.     $dftp->response();
  891.     return undef;
  892.     }
  893.  
  894.     $dftp->pasv_wait($sftp);
  895. }
  896.  
  897. sub pasv_wait
  898. {
  899.  @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
  900.  
  901.  my($ftp, $non_pasv) = @_;
  902.  my($file,$rin,$rout);
  903.  
  904.  vec($rin,fileno($ftp),1) = 1;
  905.  select($rout=$rin, undef, undef, undef);
  906.  
  907.  $ftp->response();
  908.  $non_pasv->response();
  909.  
  910.  return undef
  911.     unless $ftp->ok() && $non_pasv->ok();
  912.  
  913.  return $1
  914.     if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
  915.  
  916.  return $1
  917.     if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
  918.  
  919.  return 1;
  920. }
  921.  
  922. sub cmd { shift->command(@_)->response() }
  923.  
  924. ########################################
  925. #
  926. # RFC959 commands
  927. #
  928.  
  929. sub _ABOR { shift->command("ABOR")->response()     == CMD_OK }
  930. sub _CDUP { shift->command("CDUP")->response()     == CMD_OK }
  931. sub _NOOP { shift->command("NOOP")->response()     == CMD_OK }
  932. sub _PASV { shift->command("PASV")->response()     == CMD_OK }
  933. sub _QUIT { shift->command("QUIT")->response()     == CMD_OK }
  934. sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
  935. sub _CWD  { shift->command("CWD", @_)->response() == CMD_OK }
  936. sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
  937. sub _RMD  { shift->command("RMD", @_)->response() == CMD_OK }
  938. sub _MKD  { shift->command("MKD", @_)->response() == CMD_OK }
  939. sub _PWD  { shift->command("PWD", @_)->response() == CMD_OK }
  940. sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
  941. sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
  942. sub _ACCT { shift->command("ACCT",@_)->response() == CMD_OK }
  943. sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
  944. sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
  945. sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
  946. sub _HELP { shift->command("HELP",@_)->response() == CMD_OK }
  947. sub _STAT { shift->command("STAT",@_)->response() == CMD_OK }
  948. sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
  949. sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
  950. sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
  951. sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
  952. sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
  953. sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
  954. sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
  955. sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
  956. sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
  957. sub _PASS { shift->command("PASS",@_)->response() }
  958. sub _AUTH { shift->command("AUTH",@_)->response() }
  959.  
  960. sub _ALLO { shift->unsupported(@_) }
  961. sub _SMNT { shift->unsupported(@_) }
  962. sub _MODE { shift->unsupported(@_) }
  963. sub _SYST { shift->unsupported(@_) }
  964. sub _STRU { shift->unsupported(@_) }
  965. sub _REIN { shift->unsupported(@_) }
  966.  
  967. 1;
  968.  
  969.