# Net::FTP.pm## Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.# This program is free software; you can redistribute it and/or# modify it under the same terms as Perl itself.## Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.package Net::FTP;require 5.001;use strict;use vars qw(@ISA $VERSION);use Carp;use Socket 1.3;use IO::Socket;use Time::Local;use Net::Cmd;use Net::Config;use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);$VERSION = '2.77';@ISA     = qw(Exporter Net::Cmd IO::Socket::INET);# Someday I will "use constant", when I am not bothered to much about# compatability with older releases of perluse vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242);BEGIN {  # make a constant so code is fast'ish  my $is_os390 = $^O eq 'os390';  *trEBCDIC = sub () {$is_os390}}sub new {  my $pkg = shift;  my ($peer, %arg);  if (@_ % 2) {    $peer = shift;    %arg  = @_;  }  else {    %arg  = @_;    $peer = delete $arg{Host};  }  my $host      = $peer;  my $fire      = undef;  my $fire_type = undef;  if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {         $fire = $arg{Firewall}      || $ENV{FTP_FIREWALL}      || $NetConfig{ftp_firewall}      || undef;    if (defined $fire) {      $peer = $fire;      delete $arg{Port};           $fire_type = $arg{FirewallType}        || $ENV{FTP_FIREWALL_TYPE}        || $NetConfig{firewall_type}        || undef;    }  }  my $ftp = $pkg->SUPER::new(    PeerAddr  => $peer,    PeerPort  => $arg{Port} || 'ftp(21)',    LocalAddr => $arg{'LocalAddr'},    Proto     => 'tcp',    Timeout   => defined $arg{Timeout}    ? $arg{Timeout}    : 120    )    or return undef;  ${*$ftp}{'net_ftp_host'}    = $host;                             # Remote hostname  ${*$ftp}{'net_ftp_type'}    = 'A';                               # ASCII/binary/etc mode  ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);  ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};  ${*$ftp}{'net_ftp_firewall'} = $fire    if (defined $fire);  ${*$ftp}{'net_ftp_firewall_type'} = $fire_type    if (defined $fire_type);  ${*$ftp}{'net_ftp_passive'} =      int exists $arg{Passive} ? $arg{Passive}    : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}    : defined $fire            ? $NetConfig{ftp_ext_passive}    : $NetConfig{ftp_int_passive};    # Whew! :-)  $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);  $ftp->autoflush(1);  $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);  unless ($ftp->response() == CMD_OK) {    $ftp->close();    $@ = $ftp->message;    undef $ftp;  }  $ftp;}#### User interface methods##sub host {  my $me = shift;  ${*$me}{'net_ftp_host'};}sub hash {  my $ftp = shift;    # self  my ($h, $b) = @_;  unless ($h) {    delete ${*$ftp}{'net_ftp_hash'};    return [\*STDERR, 0];  }  ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);  select((select($h), $| = 1)[0]);  $b = 512 if $b < 512;  ${*$ftp}{'net_ftp_hash'} = [$h, $b];}sub quit {  my $ftp = shift;  $ftp->_QUIT;  $ftp->close;}sub DESTROY { }sub ascii  { shift->type('A', @_); }sub binary { shift->type('I', @_); }sub ebcdic {  carp "TYPE E is unsupported, shall default to I";  shift->type('E', @_);}sub byte {  carp "TYPE L is unsupported, shall default to I";  shift->type('L', @_);}# Allow the user to send a command directly, BE CAREFUL !!sub quot {  my $ftp = shift;  my $cmd = shift;  $ftp->command(uc $cmd, @_);  $ftp->response();}sub site {  my $ftp = shift;  $ftp->command("SITE", @_);  $ftp->response();}sub mdtm {  my $ftp  = shift;  my $file = shift;  # Server Y2K bug workaround  #  # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of  # ("%d",tm.tm_year+1900).  This results in an extra digit in the  # string returned. To account for this we allow an optional extra  # digit in the year. Then if the first two digits are 19 we use the  # remainder, otherwise we subtract 1900 from the whole year.  $ftp->_MDTM($file)    && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/    ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))    : undef;}sub size {  my $ftp  = shift;  my $file = shift;  my $io;  if ($ftp->supported("SIZE")) {    return $ftp->_SIZE($file)      ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]      : undef;  }  elsif ($ftp->supported("STAT")) {    my @msg;    return undef      unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;    my $line;    foreach $line (@msg) {      return (split(/\s+/, $line))[4]        if $line =~ /^[-rwxSsTt]{10}/;    }  }  else {    my @files = $ftp->dir($file);    if (@files) {      return (split(/\s+/, $1))[4]        if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;    }  }  undef;}sub login {  my ($ftp, $user, $pass, $acct) = @_;  my ($ok, $ruser, $fwtype);  unless (defined $user) {    require Net::Netrc;    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});    ($user, $pass, $acct) = $rc->lpa()      if ($rc);  }  $user ||= "anonymous";  $ruser = $user;  $fwtype = ${*$ftp}{'net_ftp_firewall_type'}    || $NetConfig{'ftp_firewall_type'}    || 0;  if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {    if ($fwtype == 1 || $fwtype == 7) {      $user .= '@' . ${*$ftp}{'net_ftp_host'};    }    else {      require Net::Netrc;      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});      my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();      if ($fwtype == 5) {        $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});        $pass = $pass . '@' . $fwpass;      }      else {        if ($fwtype == 2) {          $user .= '@' . ${*$ftp}{'net_ftp_host'};        }        elsif ($fwtype == 6) {          $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};        }        $ok = $ftp->_USER($fwuser);        return 0 unless $ok == CMD_OK || $ok == CMD_MORE;        $ok = $ftp->_PASS($fwpass || "");        return 0 unless $ok == CMD_OK || $ok == CMD_MORE;        $ok = $ftp->_ACCT($fwacct)          if defined($fwacct);        if ($fwtype == 3) {          $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;        }        elsif ($fwtype == 4) {          $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;        }        return 0 unless $ok == CMD_OK || $ok == CMD_MORE;      }    }  }  $ok = $ftp->_USER($user);  # Some dumb firewalls don't prefix the connection messages  $ok = $ftp->response()    if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);  if ($ok == CMD_MORE) {    unless (defined $pass) {      require Net::Netrc;      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);      ($ruser, $pass, $acct) = $rc->lpa()        if ($rc);      $pass = '-anonymous@'        if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));    }    $ok = $ftp->_PASS($pass || "");  }  $ok = $ftp->_ACCT($acct)    if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));  if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {    my ($f, $auth, $resp) = _auth_id($ftp);    $ftp->authorize($auth, $resp) if defined($resp);  }  $ok == CMD_OK;}sub account {  @_ == 2 or croak 'usage: $ftp->account( ACCT )';  my $ftp  = shift;  my $acct = shift;  $ftp->_ACCT($acct) == CMD_OK;}sub _auth_id {  my ($ftp, $auth, $resp) = @_;  unless (defined $resp) {    require Net::Netrc;    $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)      || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});    ($auth, $resp) = $rc->lpa()      if ($rc);  }  ($ftp, $auth, $resp);}sub authorize {  @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';  my ($ftp, $auth, $resp) = &_auth_id;  my $ok = $ftp->_AUTH($auth || "");  $ok = $ftp->_RESP($resp || "")    if ($ok == CMD_MORE);  $ok == CMD_OK;}sub rename {  @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';  my ($ftp, $from, $to) = @_;  $ftp->_RNFR($from)    && $ftp->_RNTO($to);}sub type {  my $ftp    = shift;  my $type   = shift;  my $oldval = ${*$ftp}{'net_ftp_type'};  return $oldval    unless (defined $type);  return undef    unless ($ftp->_TYPE($type, @_));  ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);  $oldval;}sub alloc {  my $ftp    = shift;  my $size   = shift;  my $oldval = ${*$ftp}{'net_ftp_allo'};  return $oldval    unless (defined $size);  return undef    unless ($ftp->_ALLO($size, @_));  ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);  $oldval;}sub abort {  my $ftp = shift;  send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB);  $ftp->command(pack("C", $TELNET_DM) . "ABOR");  ${*$ftp}{'net_ftp_dataconn'}->close()    if defined ${*$ftp}{'net_ftp_dataconn'};  $ftp->response();  $ftp->status == CMD_OK;}sub get {  my ($ftp, $remote, $local, $where) = @_;  my ($loc, $len, $buf, $resp, $data);  local *FD;  my $localfd = ref($local) || ref(\$local) eq "GLOB";  ($local = $remote) =~ s#^.*/##    unless (defined $local);  croak("Bad remote filename '$remote'\n")    if $remote =~ /[\r\n]/s;  ${*$ftp}{'net_ftp_rest'} = $where if defined $where;  my $rest = ${*$ftp}{'net_ftp_rest'};  delete ${*$ftp}{'net_ftp_port'};  delete ${*$ftp}{'net_ftp_pasv'};  $data = $ftp->retr($remote)    or return undef;  if ($localfd) {    $loc = $local;  }  else {    $loc = \*FD;    unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {      carp "Cannot open Local file $local: $!\n";      $data->abort;      return undef;    }  }  if ($ftp->type eq 'I' && !binmode($loc)) {    carp "Cannot binmode Local file $local: $!\n";    $data->abort;    close($loc) unless $localfd;    return undef;  }  $buf = '';  my ($count, $hashh, $hashb, $ref) = (0);  ($hashh, $hashb) = @$ref    if ($ref = ${*$ftp}{'net_ftp_hash'});  my $blksize = ${*$ftp}{'net_ftp_blksize'};  local $\;    # Just in case  while (1) {    last unless $len = $data->read($buf, $blksize);    if (trEBCDIC && $ftp->type ne 'I') {      $buf = $ftp->toebcdic($buf);      $len = length($buf);    }    if ($hashh) {      $count += $len;      print $hashh "#" x (int($count / $hashb));      $count %= $hashb;    }    unless (print $loc $buf) {      carp "Cannot write to Local file $local: $!\n";      $data->abort;      close($loc)        unless $localfd;      return undef;    }  }  print $hashh "\n" if $hashh;  unless ($localfd) {    unless (close($loc)) {      carp "Cannot close file $local (perhaps disk space) $!\n";      return undef;    }  }  unless ($data->close())    # implied $ftp->response  {    carp "Unable to close datastream";    return undef;  }  return $local;}sub cwd {  @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';  my ($ftp, $dir) = @_;  $dir = "/" unless defined($dir) && $dir =~ /\S/;  $dir eq ".."    ? $ftp->_CDUP()    : $ftp->_CWD($dir);}sub cdup {  @_ == 1 or croak 'usage: $ftp->cdup()';  $_[0]->_CDUP;}sub pwd {  @_ == 1 || croak 'usage: $ftp->pwd()';  my $ftp = shift;  $ftp->_PWD();  $ftp->_extract_path;}# rmdir( $ftp, $dir, [ $recurse ] )## Removes $dir on remote host via FTP.# $ftp is handle for remote host## If $recurse is TRUE, the directory and deleted recursively.# This means all of its contents and subdirectories.## Initial version contributed by Dinkum Software#sub rmdir {  @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');  # Pick off the args  my ($ftp, $dir, $recurse) = @_;  my $ok;  return $ok    if $ok = $ftp->_RMD($dir)    or !$recurse;  # Try to delete the contents  # Get a list of all the files in the directory  my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);  return undef    unless @filelist;    # failed, it is probably not a directory  # Go thru and delete each file or the directory  my $file;  foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {    next                 # successfully deleted the file      if $ftp->delete($file);    # Failed to delete it, assume its a directory    # Recurse and ignore errors, the final rmdir() will    # fail on any errors here    return $ok      unless $ok = $ftp->rmdir($file, 1);  }  # Directory should be empty  # Try to remove the directory again  # Pass results directly to caller  # If any of the prior deletes failed, this  # rmdir() will fail because directory is not empty  return $ftp->_RMD($dir);}sub restart {  @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';